Add support for sharing the host network to guix system container

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.

3 files changed, 99 insertions, 27 deletions

diff --git a/gnu/system.scm b/gnu/system.scm
index 1006c842c9..68e0a2f14d 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -280,7 +280,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
@@ -288,6 +288,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))
@@ -312,7 +315,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))
@@ -332,11 +336,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?)))
 
 
 ;;;
@@ -398,7 +405,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"))
@@ -477,19 +484,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.
@@ -595,20 +605,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-parameters boot)))
@@ -629,17 +647,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-parameters 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 144a7fd377..86c22694e8 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -554,13 +554,15 @@ PATTERN, a string.  When PATTERN is #f, display all the system generations."
 ;;;
 
 (define* (system-derivation-for-action os action
-                                       #:key image-size full-boot? mappings)
+                                       #:key image-size 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)
@@ -593,6 +595,7 @@ PATTERN, a string.  When PATTERN is #f, display all the system generations."
                          #:key grub? dry-run? derivations-only?
                          use-substitutes? device target
                          image-size full-boot?
+                         container-shared-network?
                          (mappings '()))
   "Perform ACTION for OS.  GRUB? specifies whether to install GRUB; DEVICE is
 the target devices for GRUB; TARGET is the target root directory; IMAGE-SIZE
@@ -612,6 +615,7 @@ building anything."
       ((sys       (system-derivation-for-action os action
                                                 #:image-size image-size
                                                 #:full-boot? full-boot?
+                                                #:container-shared-network? container-shared-network?
                                                 #:mappings mappings))
        (grub      (package->derivation (grub-configuration-grub
                                         (operating-system-bootloader os))))
@@ -739,6 +743,8 @@ Some ACTIONS support additional ARGS.\n"))
   (display (_ "
       --no-grub          for 'init', do not install GRUB"))
   (display (_ "
+  -N, --network          for 'container', allow containers to access the network"))
+  (display (_ "
       --share=SPEC       for 'vm', share host file system according to SPEC"))
   (display (_ "
       --expose=SPEC      for 'vm', expose host file system according to SPEC"))
@@ -772,6 +778,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-grub") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'install-grub? #f result)))
@@ -857,6 +866,9 @@ resulting from command-line parsing."
                              #:use-substitutes? (assoc-ref opts 'substitutes?)
                              #: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)