From a7ff0bf51b16ddd2ea2ab277bef5b2263fff854d Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Fri, 27 Jan 2017 06:15:09 +0000 Subject: scripts: system: Add support for container network sharing. This is a port of the functionality in the Guix environment command to the guix system container command. This requires additional changes to the operating-system definitions used, in particular, networking related services may need removing if the host network is shared. * guix/scripts/system.scm (system-derivation-for-action): Add #:container-shared-network? argument. (perform-action): Add #:container-shared-network? argument. (show-help): Add "-N, --network" help information. (%options): Add network option. (process-action): Call perform-action with #:container-shared-network?. * gnu/system/linux-container.scm (%network-configuration-files): New variable. (container-script): Add support for returning a container script that shares the host network. * gnu/system.scm (essential-services): Add #:container-shared-network? argument. (operating-system-services): Add #:container-shared-network? argument. (operating-system-etc-service): Add #:container-shared-network? argument, and support for ommiting some configuration if the network is shared. (operating-system-activation-script): Add #:container-shared-network? argument, and pass this through to the operating-system-services procedure. (operating-system-boot-script): Add #:container-shared-network? argument, and pass this through to the operating-system-services procedure. (operating-system-derivation): Add the #:container-shared-network? argument, and pass this through to the operating-system-services procedure. (operating-system-profile): Add the #:container-shared-network? argument, and pass this through to the operating-system-services procedure. --- gnu/system.scm | 59 +++++++++++++++++++++++++++++------------- gnu/system/linux-container.scm | 46 +++++++++++++++++++++++++++----- guix/scripts/system.scm | 18 +++++++++++-- 3 files changed, 97 insertions(+), 26 deletions(-) diff --git a/gnu/system.scm b/gnu/system.scm index a5a8f40d66..070b624b8a 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -449,7 +449,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 @@ -457,6 +457,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)) @@ -480,7 +483,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)) @@ -500,12 +504,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?)))) ;;; @@ -574,7 +579,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 that builds containing the static part of the /etc directory." (let ((login.defs @@ -676,16 +681,13 @@ 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 @@ -693,7 +695,13 @@ 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")) + ("hosts" ,#~#$(or (operating-system-hosts-file os) + (default-/etc/hosts + (operating-system-host-name os)))))))))) (define %root-account ;; Default root account. @@ -802,20 +810,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))) (service-value boot))) @@ -835,17 +851,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..d28c39c624 100644 --- a/gnu/system/linux-container.scm +++ b/gnu/system/linux-container.scm @@ -60,18 +60,49 @@ 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 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 +124,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 d92ec7d5a5..7853e2e8b2 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -752,13 +752,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) @@ -813,6 +815,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 @@ -821,6 +824,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. @@ -870,6 +875,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 @@ -1004,6 +1010,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")) @@ -1048,6 +1056,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))) @@ -1158,6 +1169,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) -- cgit v1.2.3