scripts: system: Add support for container network sharing.system-container-networking

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.

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)