[bug#28128] [PATCH] scripts: system: Add support for container network sharing.

[Christopher Baines]

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                 | 63 +++++++++++++++++++++++++++++-------------
 gnu/system/linux-container.scm | 47 +++++++++++++++++++++++++++----
 guix/scripts/system.scm        | 18 ++++++++++--
 3 files changed, 101 insertions(+), 27 deletions(-)

diff --git a/gnu/system.scm b/gnu/system.scm
index fdb5be287..a8a7ac005 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -415,7 +415,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
@@ -423,6 +423,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))
@@ -447,7 +450,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))
@@ -467,11 +471,14 @@ 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."
   (append (operating-system-user-services os)
-          (essential-services os #:container? container?)))
+          (essential-services
+           os
+           #:container? container?
+           #:container-shared-network? container-shared-network?)))
 
 
 ;;;
@@ -534,7 +541,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"))
@@ -613,19 +620,22 @@ 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))))
        ("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.
@@ -733,20 +743,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)))
@@ -767,17 +785,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 bceea4133..538b1f19c 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 5a2811e75..2fe687cdb 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -561,13 +561,15 @@ PATTERN, a string.  When PATTERN is #f, display all the 
system generations."
 
 (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)
@@ -617,6 +619,7 @@ and TARGET arguments."
                          dry-run? derivations-only?
                          use-substitutes? device 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
@@ -626,6 +629,8 @@ root directory; IMAGE-SIZE is the size of the image to be 
built, for the
 The root filesystem is created as a FILE-SYSTEM-TYPE filesystem.
 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.
@@ -643,6 +648,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)))
@@ -795,6 +801,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"))
@@ -834,6 +842,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)))
@@ -928,6 +939,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)
-- 
2.14.1