system: Add 'essential-services' field to <operating-system>.

* gnu/system.scm (<operating-system>)[essential-services]: New field.
(operating-system-directory-base-entries): Remove #:container? keyword
and keep only the not-container branch.
(essential-services): Likewise.
(operating-system-services): Likewise, and call
'operating-system-essential-services' instead of 'essential-services'.
(operating-system-activation-script): Remove #:container?.
(operating-system-boot-script): Likewise.
(operating-system-derivation): Likewise.
* gnu/system/linux-container.scm (container-essential-services): New procedure.
(containerized-operating-system): Use it and set the
'essential-services' field.
(container-script): Remove call to 'operating-system-derivation'.
* gnu/system/vm.scm (system-docker-image): Likewise.
* doc/guix.texi (operating-system Reference): Document 'essential-services'.

4 files changed, 90 insertions, 72 deletions

diff --git a/doc/guix.texi b/doc/guix.texi
index 37fef40522..7d80c00530 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -10531,6 +10531,13 @@ details.
 @item @code{services} (default: @var{%base-services})
 A list of service objects denoting system services.  @xref{Services}.
 
+@cindex essential services
+@item @code{essential-services} (default: ...)
+The list of ``essential services''---i.e., things like instances of
+@code{system-service-type} and @code{host-name-service-type} (@pxref{Service
+Reference}), which are derived from the operating system definition itself.
+As a user you should @emph{never} need to touch this field.
+
 @item @code{pam-services} (default: @code{(base-pam-services)})
 @cindex PAM
 @cindex pluggable authentication modules
diff --git a/gnu/system.scm b/gnu/system.scm
index 035bbd82a1..9887d72c41 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -69,6 +69,7 @@
 
             operating-system-bootloader
             operating-system-services
+            operating-system-essential-services
             operating-system-user-services
             operating-system-packages
             operating-system-host-name
@@ -201,6 +202,9 @@
   (name-service-switch operating-system-name-service-switch ; <name-service-switch>
                        (default %default-nss))
 
+  (essential-services operating-system-essential-services ; list of services
+                      (thunked)
+                      (default (essential-services this-record)))
   (services operating-system-user-services        ; list of services
             (default %base-services))
 
@@ -438,27 +442,22 @@ OS."
   (file-append (operating-system-kernel os)
                "/" (system-linux-image-file-name os)))
 
-(define* (operating-system-directory-base-entries os #:key container?)
+(define* (operating-system-directory-base-entries os)
   "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)))
-    (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?)
+    (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)
   "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
-a container or that of a \"bare metal\" system."
+bookkeeping."
   (define known-fs
     (map file-system-mount-point (operating-system-file-systems os)))
 
@@ -468,8 +467,7 @@ a container or that of a \"bare metal\" system."
          (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 #:container? container?)))
+         (entries   (operating-system-directory-base-entries os)))
     (cons* (service system-service-type entries)
            %boot-service
 
@@ -497,20 +495,16 @@ a container or that of a \"bare metal\" system."
            other-fs
            (append mappings swaps
 
-                   ;; 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?)
-  "Return all the services of OS, including \"internal\" services that do not
-explicitly appear in OS."
+                   ;; 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."
   (instantiate-missing-services
    (append (operating-system-user-services os)
-           (essential-services os #:container? container?))))
+           (operating-system-essential-services os))))
 
 
 ;;;
@@ -808,20 +802,19 @@ 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)
   "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))
          (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)
   "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?))
+we're running in the final root."
+  (let* ((services (operating-system-services os))
          (boot     (fold-services services #:target-type boot-service-type)))
     (service-value boot)))
 
@@ -841,17 +834,17 @@ 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)
   "Return a derivation that builds OS."
-  (let* ((services (operating-system-services os #:container? container?))
+  (let* ((services (operating-system-services os))
          (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)
   "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))
        (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 3fe3482d7f..37a053cdc3 100644
--- a/gnu/system/linux-container.scm
+++ b/gnu/system/linux-container.scm
@@ -29,12 +29,31 @@
   #:use-module (gnu build linux-container)
   #:use-module (gnu services)
   #:use-module (gnu services base)
+  #:use-module (gnu services shepherd)
   #:use-module (gnu system)
   #:use-module (gnu system file-systems)
   #:export (system-container
             containerized-operating-system
             container-script))
 
+(define (container-essential-services os)
+  "Return a list of essential services corresponding to OS, a
+non-containerized OS.  This procedure essentially strips essential services
+from OS that are needed on the bare metal and not in a container."
+  (define base
+    (remove (lambda (service)
+              (memq (service-kind service)
+                    (list (service-kind %linux-bare-metal-service)
+                          firmware-service-type
+                          system-service-type)))
+            (operating-system-essential-services os)))
+
+  (cons (service system-service-type
+                 (let ((locale (operating-system-locale-directory os)))
+                   (with-monad %store-monad
+                     (return `(("locale" ,locale))))))
+        (append base (list %containerized-shepherd-service))))
+
 (define (containerized-operating-system os mappings)
   "Return an operating system based on OS for use in a Linux container
 environment.  MAPPINGS is a list of <file-system-mapping> to realize in the
@@ -62,8 +81,10 @@ containerized OS."
           mingetty-service-type
           agetty-service-type))
 
-  (operating-system (inherit os)
+  (operating-system
+    (inherit os)
     (swap-devices '()) ; disable swap
+    (essential-services (container-essential-services os))
     (services (remove (lambda (service)
                         (memq (service-kind service)
                               useless-services))
@@ -81,30 +102,26 @@ that will be shared with the host system."
                                (operating-system-file-systems os)))
          (specs        (map file-system->spec file-systems)))
 
-    (mlet* %store-monad ((os-drv (operating-system-derivation
-                                  os
-                                  #:container? #t)))
-
-      (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))
+    (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-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))))
+            (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))))
 
-      (gexp->script "run-container" script))))
+    (gexp->script "run-container" script)))
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 5068cb3068..667624621f 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -58,6 +58,7 @@
   #:use-module (gnu bootloader grub)
   #:use-module (gnu system shadow)
   #:use-module (gnu system pam)
+  #:use-module (gnu system linux-container)
   #:use-module (gnu system linux-initrd)
   #:use-module (gnu bootloader)
   #:use-module (gnu system file-systems)
@@ -473,9 +474,9 @@ should set REGISTER-CLOSURES? to #f."
          (local-file (search-path %load-path
                                   "guix/store/schema.sql"))))
 
-  (mlet %store-monad ((os-drv (operating-system-derivation os #:container? #t))
-                      (name -> (string-append name ".tar.gz"))
-                      (graph -> "system-graph"))
+  (let ((os    (containerized-operating-system os '()))
+        (name  (string-append name ".tar.gz"))
+        (graph "system-graph"))
     (define build
       (with-extensions (cons guile-json           ;for (guix docker)
                              gcrypt-sqlite3&co)   ;for (guix store database)
@@ -505,7 +506,7 @@ should set REGISTER-CLOSURES? to #f."
                      (initialize (root-partition-initializer
                                   #:closures '(#$graph)
                                   #:register-closures? #$register-closures?
-                                  #:system-directory #$os-drv
+                                  #:system-directory #$os
                                   ;; De-duplication would fail due to
                                   ;; cross-device link errors, so don't do it.
                                   #:deduplicate? #f))
@@ -523,7 +524,7 @@ should set REGISTER-CLOSURES? to #f."
                              (call-with-input-file
                                  (string-append "/xchg/" #$graph)
                                read-reference-graph)))
-                 #$os-drv
+                 #$os
                  #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
                  #:creation-time (make-time time-utc 0 1)
                  #:transformations `((,root-directory -> "")))
@@ -534,7 +535,7 @@ should set REGISTER-CLOSURES? to #f."
      name build
      #:make-disk-image? #f
      #:single-file-output? #t
-     #:references-graphs `((,graph ,os-drv)))))
+     #:references-graphs `((,graph ,os)))))
 
 
 ;;;