scripts: system: Add support for container network sharing.release_11

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.

2 files changed, 85 insertions, 25 deletions

diff --git a/gnu/system.scm b/gnu/system.scm
index c4404f5932..d629ad18d4 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -428,7 +428,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
@@ -436,6 +436,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))
@@ -460,7 +463,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))
@@ -480,11 +484,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?)))
 
 
 ;;;
@@ -553,7 +560,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"))
@@ -632,19 +639,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.
@@ -752,20 +762,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)))
@@ -786,17 +804,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))))