diff options
| -rw-r--r-- | gnu/system.scm | 61 | ||||
| -rw-r--r-- | gnu/system/linux-container.scm | 47 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 18 |
3 files changed, 99 insertions, 27 deletions
diff --git a/gnu/system.scm b/gnu/system.scm index 39452304ba..87fb12dc39 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -437,7 +437,7 @@ value of the SYSTEM-SERVICE-TYPE service." ("initrd" ,initrd) ("locale" ,locale)))))))) ;used by libc -(define* (essential-services os #:key container?) +(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. CONTAINER? determines whether to return the list of services for @@ -445,6 +445,9 @@ a container or that of a \"bare metal\" system." (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)) @@ -469,7 +472,8 @@ a container or that of a \"bare metal\" system." (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)) @@ -489,12 +493,13 @@ a container or that of a \"bare metal\" system." (service firmware-service-type (operating-system-firmware os)))))))) -(define* (operating-system-services os #:key container?) +(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) - (essential-services os #:container? container?)))) + (essential-services os #:container? container? + #:container-shared-network? container-shared-network?)))) ;;; @@ -562,7 +567,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 (plain-file "login.defs" "# Empty for now.\n")) @@ -648,16 +653,12 @@ 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 @@ -665,7 +666,14 @@ fi\n"))) ("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")) + ("nsswitch.conf" ,#~#$nsswitch) + ("hosts" ,#~#$(or (operating-system-hosts-file os) + (default-/etc/hosts + (operating-system-host-name os)))))))))) (define %root-account ;; Default root account. @@ -774,20 +782,28 @@ use 'plain-file' instead~%") root ALL=(ALL) ALL %wheel ALL=(ALL) ALL\n")) -(define* (operating-system-activation-script os #:key container?) +(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 #:container? container?)) + (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 #:key container?) +(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. When CONTAINER? is true, skip all hardware-related operations as necessary when booting a Linux container." - (let* ((services (operating-system-services os #:container? container?)) + (let* ((services (operating-system-services + os + #:container? container? + #:container-shared-network? container-shared-network?)) (boot (fold-services services #:target-type boot-service-type))) ;; BOOT is the script as a monadic value. (service-value boot))) @@ -808,17 +824,24 @@ hardware-related operations as necessary when booting a Linux container." #:target-type shepherd-root-service-type)))) -(define* (operating-system-derivation os #:key container?) +(define* (operating-system-derivation os #:key container? + container-shared-network?) "Return a derivation that builds OS." - (let* ((services (operating-system-services os #:container? container?)) + (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 #:key container?) +(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 #:container? container?)) + ((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 bceea41332..538b1f19cb 100644 --- a/gnu/system/linux-container.scm +++ b/gnu/system/linux-container.scm @@ -60,18 +60,50 @@ containerized OS." %container-file-systems user-file-systems)))) -(define* (container-script os #:key (mappings '())) + +(define %network-configuration-files + '("/etc/resolv.conf" + "/etc/nsswitch.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))) - (mlet* %store-monad ((os-drv (operating-system-derivation - os - #:container? #t))) + (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 @@ -93,6 +125,9 @@ that will be shared with the host system." ;; 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)))) + #:host-uids 65536 + #:namespaces (if #$container-shared-network? + (delq 'net %namespaces) + %namespaces))))) (gexp->script "run-container" script)))) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 999ffb010b..cced8d03da 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -647,13 +647,15 @@ procedure of its type." (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) @@ -706,6 +708,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 @@ -714,6 +717,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. @@ -739,6 +744,7 @@ output when building a system derivation, such as a disk image." #:file-system-type file-system-type #:image-size image-size #:full-boot? full-boot? + #:container-shared-network? container-shared-network? #:mappings mappings)) (bootloader -> (bootloader-configuration-bootloader (operating-system-bootloader os))) @@ -894,6 +900,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")) @@ -936,6 +944,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))) @@ -1038,6 +1049,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) |