linux-container: container-script: Parse command line options.
* gnu/system/linux-container.scm (container-script): Accept command line options to bind mount host directories into the container. * doc/guix.texi (Invoking guix system): Document options.
Ricardo Wurmus
parent
f194df2bb4
commit
26af06b66b
|
|
@ -37500,6 +37500,10 @@ guix system container my-config.scm \
|
||||||
--expose=$HOME --share=$HOME/tmp=/exchange
|
--expose=$HOME --share=$HOME/tmp=/exchange
|
||||||
@end example
|
@end example
|
||||||
|
|
||||||
|
The @option{--share} and @option{--expose} options can also be passed to
|
||||||
|
the generated script to bind-mount additional directories into the
|
||||||
|
container.
|
||||||
|
|
||||||
@quotation Note
|
@quotation Note
|
||||||
This option requires Linux-libre 3.19 or newer.
|
This option requires Linux-libre 3.19 or newer.
|
||||||
@end quotation
|
@end quotation
|
||||||
|
|
|
||||||
|
|
@ -4,6 +4,7 @@
|
||||||
;;; Copyright © 2019 Arun Isaac <arunisaac@systemreboot.net>
|
;;; Copyright © 2019 Arun Isaac <arunisaac@systemreboot.net>
|
||||||
;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
|
;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
|
||||||
;;; Copyright © 2020 Google LLC
|
;;; Copyright © 2020 Google LLC
|
||||||
|
;;; Copyright © 2022 Ricardo Wurmus <rekado@elephly.net>
|
||||||
;;;
|
;;;
|
||||||
;;; This file is part of GNU Guix.
|
;;; This file is part of GNU Guix.
|
||||||
;;;
|
;;;
|
||||||
|
|
@ -202,16 +203,49 @@ that will be shared with the host system."
|
||||||
(guix build utils)
|
(guix build utils)
|
||||||
(guix i18n)
|
(guix i18n)
|
||||||
(guix diagnostics)
|
(guix diagnostics)
|
||||||
(srfi srfi-1))
|
(srfi srfi-1)
|
||||||
|
(srfi srfi-37)
|
||||||
|
(ice-9 match))
|
||||||
|
|
||||||
(define file-systems
|
(define (show-help)
|
||||||
(filter-map (lambda (spec)
|
(display (G_ "Usage: run-container [OPTION ...]
|
||||||
(let* ((fs (spec->file-system spec))
|
Run the container with the given options."))
|
||||||
(flags (file-system-flags fs)))
|
(newline)
|
||||||
(and (or (not (memq 'bind-mount flags))
|
(display (G_ "
|
||||||
(file-exists? (file-system-device fs)))
|
--share=SPEC share host file system with read/write access
|
||||||
fs)))
|
according to SPEC"))
|
||||||
'#$specs))
|
(display (G_ "
|
||||||
|
--expose=SPEC expose host file system directory as read-only
|
||||||
|
according to SPEC"))
|
||||||
|
(newline)
|
||||||
|
(display (G_ "
|
||||||
|
-h, --help display this help and exit"))
|
||||||
|
(newline))
|
||||||
|
|
||||||
|
(define %options
|
||||||
|
;; Specifications of the command-line options.
|
||||||
|
(list (option '(#\h "help") #f #f
|
||||||
|
(lambda args
|
||||||
|
(show-help)
|
||||||
|
(exit 0)))
|
||||||
|
(option '("share") #t #f
|
||||||
|
(lambda (opt name arg result)
|
||||||
|
(alist-cons 'file-system-mapping
|
||||||
|
(specification->file-system-mapping arg #t)
|
||||||
|
result)))
|
||||||
|
(option '("expose") #t #f
|
||||||
|
(lambda (opt name arg result)
|
||||||
|
(alist-cons 'file-system-mapping
|
||||||
|
(specification->file-system-mapping arg #f)
|
||||||
|
result)))))
|
||||||
|
|
||||||
|
(define (parse-options args options)
|
||||||
|
(args-fold args options
|
||||||
|
(lambda (opt name arg . rest)
|
||||||
|
(report-error (G_ "~A: unrecognized option~%") name)
|
||||||
|
(exit 1))
|
||||||
|
(lambda (op res) (cons op res))
|
||||||
|
'()))
|
||||||
|
|
||||||
(define (explain pid)
|
(define (explain pid)
|
||||||
;; XXX: We can't quite call 'bindtextdomain' so there's actually
|
;; XXX: We can't quite call 'bindtextdomain' so there's actually
|
||||||
|
|
@ -225,22 +259,35 @@ that will be shared with the host system."
|
||||||
(info (G_ "or run 'sudo nsenter -a -t ~a' to get a shell into it.~%") pid)
|
(info (G_ "or run 'sudo nsenter -a -t ~a' to get a shell into it.~%") pid)
|
||||||
(newline (guix-warning-port)))
|
(newline (guix-warning-port)))
|
||||||
|
|
||||||
(call-with-container file-systems
|
(let* ((opts (parse-options (cdr (command-line)) %options))
|
||||||
(lambda ()
|
(mappings (filter-map (match-lambda
|
||||||
(setenv "HOME" "/root")
|
(('file-system-mapping . mapping) mapping)
|
||||||
(setenv "TMPDIR" "/tmp")
|
(_ #f))
|
||||||
(setenv "GUIX_NEW_SYSTEM" #$os)
|
opts))
|
||||||
(for-each mkdir-p '("/run" "/bin" "/etc" "/home" "/var"))
|
(file-systems
|
||||||
(primitive-load (string-append #$os "/boot")))
|
(filter-map (lambda (fs)
|
||||||
;; A range of 65536 uid/gids is used to cover 16 bits worth of
|
(let ((flags (file-system-flags fs)))
|
||||||
;; users and groups, which is sufficient for most cases.
|
(and (or (not (memq 'bind-mount flags))
|
||||||
;;
|
(file-exists? (file-system-device fs)))
|
||||||
;; See: http://www.freedesktop.org/software/systemd/man/systemd-nspawn.html#--private-users=
|
fs)))
|
||||||
#:host-uids 65536
|
(append (map file-system-mapping->bind-mount mappings)
|
||||||
#:namespaces (if #$shared-network?
|
(map spec->file-system '#$specs)))))
|
||||||
(delq 'net %namespaces)
|
(call-with-container file-systems
|
||||||
%namespaces)
|
(lambda ()
|
||||||
#:process-spawned-hook explain))))
|
(setenv "HOME" "/root")
|
||||||
|
(setenv "TMPDIR" "/tmp")
|
||||||
|
(setenv "GUIX_NEW_SYSTEM" #$os)
|
||||||
|
(for-each mkdir-p '("/run" "/bin" "/etc" "/home" "/var"))
|
||||||
|
(primitive-load (string-append #$os "/boot")))
|
||||||
|
;; A range of 65536 uid/gids is used to cover 16 bits worth of
|
||||||
|
;; users and groups, which is sufficient for most cases.
|
||||||
|
;;
|
||||||
|
;; See: http://www.freedesktop.org/software/systemd/man/systemd-nspawn.html#--private-users=
|
||||||
|
#:host-uids 65536
|
||||||
|
#:namespaces (if #$shared-network?
|
||||||
|
(delq 'net %namespaces)
|
||||||
|
%namespaces)
|
||||||
|
#:process-spawned-hook explain)))))
|
||||||
|
|
||||||
(gexp->script "run-container" script)))
|
(gexp->script "run-container" script)))
|
||||||
|
|
||||||
|
|
|
||||||
Reference in New Issue