diff options
| -rw-r--r-- | gnu/system.scm | 109 | ||||
| -rw-r--r-- | gnu/system/linux-container.scm | 84 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 18 |
3 files changed, 147 insertions, 64 deletions
diff --git a/gnu/system.scm b/gnu/system.scm index ad0c9e57dc..e9310e3d5b 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -445,32 +445,40 @@ OS." (file-append (operating-system-kernel os) "/" (system-linux-image-file-name os))) -(define* (operating-system-directory-base-entries os) +(define* (operating-system-directory-base-entries os #:key container?) "Return the basic entries of the 'system' directory of OS for use as the value of the SYSTEM-SERVICE-TYPE service." (let ((locale (operating-system-locale-directory os))) - (mlet %store-monad ((kernel -> (operating-system-kernel os)) - (initrd -> (operating-system-initrd-file os)) - (params (operating-system-boot-parameters-file os))) - (return `(("kernel" ,kernel) - ("parameters" ,params) - ("initrd" ,initrd) - ("locale" ,locale)))))) ;used by libc - -(define* (essential-services os) + (with-monad %store-monad + (if container? + (return `(("locale" ,locale))) + (mlet %store-monad + ((kernel -> (operating-system-kernel os)) + (initrd -> (operating-system-initrd-file os)) + (params (operating-system-boot-parameters-file os))) + (return `(("kernel" ,kernel) + ("parameters" ,params) + ("initrd" ,initrd) + ("locale" ,locale)))))))) ;used by libc + +(define* (essential-services os #:key container? container-shared-network?) "Return the list of essential services for OS. These are special services that implement part of what's declared in OS are responsible for low-level bookkeeping." (define known-fs (map file-system-mount-point (operating-system-file-systems os))) + (if (and container-shared-network? (not container?)) + (error "cannot specify container-shared-network? without container? #t")) + (let* ((mappings (device-mapping-services os)) (root-fs (root-file-system-service)) (other-fs (non-boot-file-system-service os)) (swaps (swap-services os)) (procs (service user-processes-service-type)) (host-name (host-name-service (operating-system-host-name os))) - (entries (operating-system-directory-base-entries os))) + (entries (operating-system-directory-base-entries + os #:container? container?))) (cons* (service system-service-type entries) %boot-service @@ -486,7 +494,8 @@ bookkeeping." (account-service (append (operating-system-accounts os) (operating-system-groups os)) (operating-system-skeletons os)) - (operating-system-etc-service os) + (operating-system-etc-service + os #:container-shared-network? container-shared-network?) (service fstab-service-type '()) (session-environment-service (operating-system-environment-variables os)) @@ -498,16 +507,23 @@ bookkeeping." other-fs (append mappings swaps - ;; Add the firmware service. - (list %linux-bare-metal-service - (service firmware-service-type - (operating-system-firmware os))))))) - -(define* (operating-system-services os) - "Return all the services of OS, including \"essential\" services." + ;; Add the firmware service, unless we are building for a + ;; container. + (if container? + (list %containerized-shepherd-service) + (list %linux-bare-metal-service + (service firmware-service-type + (operating-system-firmware os)))))))) + +(define* (operating-system-services os #:key container? container-shared-network?) + "Return all the services of OS, including \"internal\" services that do not +explicitly appear in OS." (instantiate-missing-services (append (operating-system-user-services os) - (operating-system-essential-services os)))) + (essential-services + os + #:container? container? + #:container-shared-network? container-shared-network?)))) ;;; @@ -576,7 +592,7 @@ This is the GNU system. Welcome.\n") "Return the default /etc/hosts file." (plain-file "hosts" (local-host-aliases host-name))) -(define* (operating-system-etc-service os) +(define* (operating-system-etc-service os #:key container-shared-network?) "Return a <service> that builds containing the static part of the /etc directory." (let ((login.defs @@ -678,24 +694,23 @@ then source /run/current-system/profile/etc/profile.d/bash_completion.sh fi\n"))) (etc-service - `(("services" ,(file-append net-base "/etc/services")) - ("protocols" ,(file-append net-base "/etc/protocols")) + `(("protocols" ,(file-append net-base "/etc/protocols")) ("rpc" ,(file-append net-base "/etc/rpc")) ("login.defs" ,#~#$login.defs) ("issue" ,#~#$issue) ("nsswitch.conf" ,#~#$nsswitch) ("profile" ,#~#$profile) ("bashrc" ,#~#$bashrc) - ("hosts" ,#~#$(or (operating-system-hosts-file os) - (default-/etc/hosts (operating-system-host-name os)))) - ;; Write the operating-system-host-name to /etc/hostname to prevent - ;; NetworkManager from changing the system's hostname when connecting - ;; to certain networks. Some discussion at - ;; https://lists.gnu.org/archive/html/help-guix/2017-09/msg00037.html ("hostname" ,(plain-file "hostname" (operating-system-host-name os))) ("localtime" ,(file-append tzdata "/share/zoneinfo/" (operating-system-timezone os))) - ("sudoers" ,(operating-system-sudoers-file os)))))) + ("sudoers" ,(operating-system-sudoers-file os)) + ,@(if container-shared-network? + '() + `(("services" ,(file-append net-base "/etc/services")) + ("hosts" ,#~#$(or (operating-system-hosts-file os) + (default-/etc/hosts + (operating-system-host-name os)))))))))) (define %root-account ;; Default root account. @@ -805,19 +820,28 @@ use 'plain-file' instead~%") root ALL=(ALL) ALL %wheel ALL=(ALL) ALL\n")) -(define* (operating-system-activation-script os) +(define* (operating-system-activation-script os #:key container? + container-shared-network?) "Return the activation script for OS---i.e., the code that \"activates\" the stateful part of OS, including user accounts and groups, special directories, etc." - (let* ((services (operating-system-services os)) + (let* ((services (operating-system-services + os + #:container? container? + #:container-shared-network? container-shared-network?)) (activation (fold-services services #:target-type activation-service-type))) (activation-service->script activation))) -(define* (operating-system-boot-script os) +(define* (operating-system-boot-script os #:key container? + container-shared-network?) "Return the boot script for OS---i.e., the code started by the initrd once -we're running in the final root." - (let* ((services (operating-system-services os)) +we're running in the final root. When CONTAINER? is true, skip all +hardware-related operations as necessary when booting a Linux container." + (let* ((services (operating-system-services + os + #:container? container? + #:container-shared-network? container-shared-network?)) (boot (fold-services services #:target-type boot-service-type))) (service-value boot))) @@ -837,17 +861,24 @@ we're running in the final root." #:target-type shepherd-root-service-type)))) -(define* (operating-system-derivation os) +(define* (operating-system-derivation os #:key container? + container-shared-network?) "Return a derivation that builds OS." - (let* ((services (operating-system-services os)) + (let* ((services (operating-system-services + os + #:container? container? + #:container-shared-network? container-shared-network?)) (system (fold-services services))) ;; SYSTEM contains the derivation as a monadic value. (service-value system))) -(define* (operating-system-profile os) +(define* (operating-system-profile os #:key container? container-shared-network?) "Return a derivation that builds the system profile of OS." (mlet* %store-monad - ((services -> (operating-system-services os)) + ((services -> (operating-system-services + os + #:container? container? + #:container-shared-network? container-shared-network?)) (profile (fold-services services #:target-type profile-service-type))) (match profile diff --git a/gnu/system/linux-container.scm b/gnu/system/linux-container.scm index 37a053cdc3..48d6df4348 100644 --- a/gnu/system/linux-container.scm +++ b/gnu/system/linux-container.scm @@ -93,35 +93,73 @@ containerized OS." %container-file-systems user-file-systems)))) -(define* (container-script os #:key (mappings '())) + +(define %network-configuration-files + '("/etc/resolv.conf" + "/etc/services" + "/etc/hosts")) + +(define* (container-script os #:key (mappings '()) + container-shared-network?) "Return a derivation of a script that runs OS as a Linux container. MAPPINGS is a list of <file-system> objects that specify the files/directories that will be shared with the host system." - (let* ((os (containerized-operating-system os mappings)) + (let* ((os (containerized-operating-system + os + (append + mappings + (if + container-shared-network? + (filter-map (lambda (file) + (and (file-exists? file) + (file-system-mapping + (source file) + (target file) + ;; XXX: On some GNU/Linux + ;; systems, /etc/resolv.conf is a + ;; symlink to a file in a tmpfs + ;; which, for an unknown reason, + ;; cannot be bind mounted + ;; read-only within the + ;; container. + (writable? + (string=? + file "/etc/resolv.conf"))))) + %network-configuration-files) + '())))) (file-systems (filter file-system-needed-for-boot? (operating-system-file-systems os))) (specs (map file-system->spec file-systems))) - (define script - (with-imported-modules (source-module-closure - '((guix build utils) - (gnu build linux-container))) - #~(begin - (use-modules (gnu build linux-container) - (gnu system file-systems) ;spec->file-system - (guix build utils)) + (mlet* %store-monad ((os-drv + (operating-system-derivation + os + #:container? #t + #:container-shared-network? container-shared-network?))) + + (define script + (with-imported-modules (source-module-closure + '((guix build utils) + (gnu build linux-container))) + #~(begin + (use-modules (gnu build linux-container) + (gnu system file-systems) ;spec->file-system + (guix build utils)) - (call-with-container (map spec->file-system '#$specs) - (lambda () - (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)))) + (call-with-container (map spec->file-system '#$specs) + (lambda () + (setenv "HOME" "/root") + (setenv "TMPDIR" "/tmp") + (setenv "GUIX_NEW_SYSTEM" #$os-drv) + (for-each mkdir-p '("/run" "/bin" "/etc" "/home" "/var")) + (primitive-load (string-append #$os-drv "/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 #$container-shared-network? + (delq 'net %namespaces) + %namespaces))))) - (gexp->script "run-container" script))) + (gexp->script "run-container" script)))) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 78aa6cf644..cd6e7eeb92 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -756,13 +756,15 @@ checking this by themselves in their 'check' procedure." (define* (system-derivation-for-action os action #:key image-size file-system-type - full-boot? mappings) + full-boot? mappings + container-shared-network?) "Return as a monadic value the derivation for OS according to ACTION." (case action ((build init reconfigure) (operating-system-derivation os)) ((container) - (container-script os #:mappings mappings)) + (container-script os #:mappings mappings + #:container-shared-network? container-shared-network?)) ((vm-image) (system-qemu-image os #:disk-image-size image-size)) ((vm) @@ -826,6 +828,7 @@ and TARGET arguments." dry-run? derivations-only? use-substitutes? bootloader-target target image-size file-system-type full-boot? + container-shared-network? (mappings '()) (gc-root #f)) "Perform ACTION for OS. INSTALL-BOOTLOADER? specifies whether to install @@ -834,6 +837,8 @@ target root directory; IMAGE-SIZE is the size of the image to be built, for the 'vm-image' and 'disk-image' actions. The root file system is created as a FILE-SYSTEM-TYPE file system. FULL-BOOT? is used for the 'vm' action; it determines whether to boot directly to the kernel or to the bootloader. +CONTAINER-SHARED_NETWORK? determines if the container will use a use a +separate network namespace. When DERIVATIONS-ONLY? is true, print the derivation file name(s) without building anything. @@ -883,6 +888,7 @@ static checks." #:file-system-type file-system-type #:image-size image-size #:full-boot? full-boot? + #:container-shared-network? container-shared-network? #:mappings mappings)) ;; For 'init' and 'reconfigure', always build BOOTCFG, even if @@ -1020,6 +1026,8 @@ Some ACTIONS support additional ARGS.\n")) (display (G_ " --share=SPEC for 'vm', share host file system according to SPEC")) (display (G_ " + -N, --network for 'container', allow containers to access the network")) + (display (G_ " -r, --root=FILE for 'vm', 'vm-image', 'disk-image', 'container', and 'build', make FILE a symlink to the result, and register it as a garbage collector root")) @@ -1066,6 +1074,9 @@ Some ACTIONS support additional ARGS.\n")) (lambda (opt name arg result) (alist-cons 'image-size (size->number arg) result))) + (option '(#\N "network") #f #f + (lambda (opt name arg result) + (alist-cons 'container-shared-network? #t result))) (option '("no-bootloader" "no-grub") #f #f (lambda (opt name arg result) (alist-cons 'install-bootloader? #f result))) @@ -1182,6 +1193,9 @@ resulting from command-line parsing." #:file-system-type (assoc-ref opts 'file-system-type) #:image-size (assoc-ref opts 'image-size) #:full-boot? (assoc-ref opts 'full-boot?) + #:container-shared-network? (assoc-ref + opts + 'container-shared-network?) #:mappings (filter-map (match-lambda (('file-system-mapping . m) m) |