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'.

2 files changed, 50 insertions, 32 deletions

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)))))
 
 
 ;;;