02/07: services: Add 'system-service-type'.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit d62e201cfd0f1e48c14586489d0e2b80ce943d4f
Author: Ludovic Courtès <address@hidden>
Date:   Mon Nov 2 18:44:17 2015 +0100

    services: Add 'system-service-type'.
    
    * gnu/services.scm (system-derivation): New procedure.
      (system-service-type): New variable.
      (boot-script-entry): New procedure.
      (boot-service-type): Extend SYSTEM-SERVICE-TYPE.
      (etc-entry): New procedure.
      (etc-service-type): Extend SYSTEM-SERVICE-TYPE.
      (fold-services): Change default #:target-type to SYSTEM-SERVICE-TYPE.
    * gnu/system.scm (operating-system-directory-base-entries): New procedure.
      (essential-services): Use it.  Add an instance of
      SYSTEM-SERVICE-TYPE.
      (operating-system-boot-script): Pass #:target-type to 'fold-services'.
      (operating-system-derivation): Rewrite in terms of 'fold-services'.
    * gnu/system/linux-container.scm (system-container): Remove.
      (container-script): Use 'operating-system-derivation'.
    * guix/scripts/system.scm (export-extension-graph): Replace
      BOOT-SERVICE-TYPE by SYSTEM-SERVICE-TYPE.
    * doc/images/service-graph.dot: Add 'system' node and edges.
    * doc/guix.texi (Service Composition): Mention SYSTEM-SERVICE-TYPE.
      (Service Reference): Document it.  Update 'fold-services'
      documentation.
---
 doc/guix.texi                  |   26 +++++++++++++------
 doc/images/service-graph.dot   |    5 +++-
 gnu/services.scm               |   51 ++++++++++++++++++++++++++++++++-----
 gnu/system.scm                 |   54 +++++++++++++++++++++++-----------------
 gnu/system/linux-container.scm |   18 ++-----------
 guix/scripts/system.scm        |    6 ++--
 6 files changed, 103 insertions(+), 57 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 74e0977..6ab98de 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -7589,8 +7589,11 @@ as arrows, a typical system might provide something like 
this:
 
 @image{images/service-graph,,5in,Typical service extension graph.}
 
-At the bottom, we see the @dfn{boot service}, which produces the boot
-script that is executed at boot time from the initial RAM disk.
address@hidden system service
+At the bottom, we see the @dfn{system service}, which produces the
+directory containing everything to run and boot the system, as returned
+by the @command{guix system build} command.  @xref{Service Reference},
+to learn about the other service types shown here.
 @xref{system-extension-graph, the @command{guix system extension-graph}
 command}, for information on how to generate this representation for a
 particular operating system definition.
@@ -7853,12 +7856,14 @@ Return true if @var{obj} is a service extension.
 
 At the core of the service abstraction lies the @code{fold-services}
 procedure, which is responsible for ``compiling'' a list of services
-down to a single boot script.  In essence, it propagates service
-extensions down the service graph, updating each node parameters on the
-way, until it reaches the root node.
+down to a single directory that contains everything needed to boot and
+run the system---the directory shown by the @command{guix system build}
+command (@pxref{Invoking guix system}).  In essence, it propagates
+service extensions down the service graph, updating each node parameters
+on the way, until it reaches the root node.
 
 @deffn {Scheme Procedure} fold-services @var{services} @
-                            [#:target-type @var{boot-service-type}]
+                            [#:target-type @var{system-service-type}]
 Fold @var{services} by propagating their extensions down to the root of
 type @var{target-type}; return the root service adjusted accordingly.
 @end deffn
@@ -7866,9 +7871,14 @@ type @var{target-type}; return the root service adjusted 
accordingly.
 Lastly, the @code{(gnu services)} module also defines several essential
 service types, some of which are listed below.
 
address@hidden {Scheme Variable} system-service-type
+This is the root of the service graph.  It produces the system directory
+as returned by the @command{guix system build} command.
address@hidden defvr
+
 @defvr {Scheme Variable} boot-service-type
-The type of the ``boot service'', which is the root of the service
-graph.
+The type of the ``boot service'', which produces the @dfn{boot script}.
+The boot script is what the initial RAM disk runs when booting.
 @end defvr
 
 @defvr {Scheme Variable} etc-service-type
diff --git a/doc/images/service-graph.dot b/doc/images/service-graph.dot
index 3397b87..04f231b 100644
--- a/doc/images/service-graph.dot
+++ b/doc/images/service-graph.dot
@@ -4,7 +4,8 @@ digraph "Service Type Dependencies" {
   etc [shape = box, fontname = Helvetica];
   accounts [shape = box, fontname = Helvetica];
   activation [shape = box, fontname = Helvetica];
-  boot [shape = house, fontname = Helvetica];
+  boot [shape = box, fontname = Helvetica];
+  system [shape = house, fontname = Helvetica];
   lshd -> dmd;
   lshd -> pam;
   udev -> dmd;
@@ -32,4 +33,6 @@ digraph "Service Type Dependencies" {
   guix -> dmd;
   guix -> activation;
   guix -> accounts;
+  boot -> system;
+  etc -> system;
 }
diff --git a/gnu/services.scm b/gnu/services.scm
index ecf3532..8a66d45 100644
--- a/gnu/services.scm
+++ b/gnu/services.scm
@@ -60,6 +60,7 @@
             ambiguous-target-service-error-service
             ambiguous-target-service-error-target-type
 
+            system-service-type
             boot-service-type
             activation-service-type
             activation-service->script
@@ -89,9 +90,10 @@
 ;;; by providing one procedure to compose extensions, and one procedure to
 ;;; extend itself.
 ;;;
-;;; A notable service type is BOOT-SERVICE-TYPE, which has a single instance,
-;;; %BOOT-SERVICE.  %BOOT-SERVICE constitutes the root of the service DAG.  It
-;;; produces the boot script that the initrd loads.
+;;; A notable service type is SYSTEM-SERVICE-TYPE, which has a single
+;;; instance, which is the root of the service DAG.  Its value is the
+;;; derivation that produces the 'system' directory as returned by
+;;; 'operating-system-derivation'.
 ;;;
 ;;; The 'fold-services' procedure can be passed a list of procedures, which it
 ;;; "folds" by propagating extensions down the graph; it returns the root
@@ -182,6 +184,25 @@ This is a shorthand for (map (lambda (svc) ...) 
%base-services)."
 ;;; Core services.
 ;;;
 
+(define (system-derivation mentries mextensions)
+  "Return as a monadic value the derivation of the 'system' directory
+containing the given entries."
+  (mlet %store-monad ((entries    mentries)
+                      (extensions (sequence %store-monad mextensions)))
+    (lower-object
+     (file-union "system"
+                 (append entries (concatenate extensions))))))
+
+(define system-service-type
+  ;; This is the ultimate service type, the root of the service DAG.  The
+  ;; service of this type is extended by monadic name/item pairs.  These items
+  ;; end up in the "system directory" as returned by
+  ;; 'operating-system-derivation'.
+  (service-type (name 'system)
+                (extensions '())
+                (compose identity)
+                (extend system-derivation)))
+
 (define (compute-boot-script _ mexps)
   (mlet %store-monad ((gexps (sequence %store-monad mexps)))
     (gexp->file "boot"
@@ -203,17 +224,25 @@ This is a shorthand for (map (lambda (svc) ...) 
%base-services)."
                     ;; Activate the system and spawn dmd.
                     address@hidden))))
 
+(define (boot-script-entry mboot)
+  "Return, as a monadic value, an entry for the boot script in the system
+directory."
+  (mlet %store-monad ((boot mboot))
+    (return `(("boot" ,boot)))))
+
 (define boot-service-type
   ;; The service of this type is extended by being passed gexps as monadic
   ;; values.  It aggregates them in a single script, as a monadic value, which
   ;; becomes its 'parameters'.  It is the only service that extends nothing.
   (service-type (name 'boot)
-                (extensions '())
+                (extensions
+                 (list (service-extension system-service-type
+                                          boot-script-entry)))
                 (compose append)
                 (extend compute-boot-script)))
 
 (define %boot-service
-  ;; This is the ultimate service, the root of the service DAG.
+  ;; The service that produces the boot script.
   (service boot-service-type #t))
 
 (define* (file-union name files)                  ;FIXME: Factorize.
@@ -351,6 +380,12 @@ ACTIVATION-SCRIPT-TYPE."
 (define (files->etc-directory files)
   (file-union "etc" files))
 
+(define (etc-entry files)
+  "Return an entry for the /etc directory consisting of FILES in the system
+directory."
+  (with-monad %store-monad
+    (return `(("etc" ,(files->etc-directory files))))))
+
 (define etc-service-type
   (service-type (name 'etc)
                 (extensions
@@ -359,7 +394,8 @@ ACTIVATION-SCRIPT-TYPE."
                                      (lambda (files)
                                        (let ((etc
                                               (files->etc-directory files)))
-                                         #~(activate-etc #$etc))))))
+                                         #~(activate-etc #$etc))))
+                  (service-extension system-service-type etc-entry)))
                 (compose concatenate)
                 (extend append)))
 
@@ -450,7 +486,8 @@ kernel."
     (lambda (node)
       (reverse (vhash-foldq* cons '() node edges)))))
 
-(define* (fold-services services #:key (target-type boot-service-type))
+(define* (fold-services services
+                        #:key (target-type system-service-type))
   "Fold SERVICES by propagating their extensions down to the root of type
 TARGET-TYPE; return the root service adjusted accordingly."
   (define dependents
diff --git a/gnu/system.scm b/gnu/system.scm
index 8fed857..c26d270 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -254,6 +254,24 @@ from the initrd."
   "Return the list of swap services for OS."
   (map swap-service (operating-system-swap-devices 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."
+  (mlet* %store-monad ((profile (operating-system-profile os))
+                       (locale  (operating-system-locale-directory os)))
+    (if container?
+        (return `(("profile" ,profile)
+                  ("locale" ,locale)))
+        (mlet %store-monad
+            ((kernel  ->  (operating-system-kernel os))
+             (initrd      (operating-system-initrd-file os))
+             (params      (operating-system-parameters-file os)))
+          (return `(("kernel" ,kernel)
+                    ("parameters" ,params)
+                    ("initrd" ,initrd)
+                    ("profile" ,profile)
+                    ("locale" ,locale)))))))      ;used by libc
+
 (define* (essential-services os #:key container?)
   "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
@@ -269,8 +287,11 @@ a container or that of a \"bare metal\" system."
          (swaps     (swap-services os))
          (procs     (user-processes-service
                      (map service-parameters other-fs)))
-         (host-name (host-name-service (operating-system-host-name os))))
-    (cons* %boot-service
+         (host-name (host-name-service (operating-system-host-name os)))
+         (entries   (operating-system-directory-base-entries
+                     os #:container? container?)))
+    (cons* (service system-service-type entries)
+           %boot-service
 
            ;; %DMD-ROOT-SERVICE must come first so that the gexp that execs
            ;; dmd comes last in the boot script (XXX).
@@ -607,10 +628,17 @@ etc."
 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?))
-         (boot     (fold-services services)))
+         (boot     (fold-services services #:target-type boot-service-type)))
     ;; BOOT is the script as a monadic value.
     (service-parameters boot)))
 
+(define* (operating-system-derivation os #:key container?)
+  "Return a derivation that builds OS."
+  (let* ((services (operating-system-services os #:container? container?))
+         (system   (fold-services services)))
+    ;; SYSTEM contains the derivation as a monadic value.
+    (service-parameters system)))
+
 (define (operating-system-root-file-system os)
   "Return the root file system of OS."
   (find (match-lambda
@@ -693,24 +721,4 @@ this file is the reconstruction of GRUB menu entries for 
old configurations."
                                     #$(operating-system-kernel-arguments os))
                                    (initrd #$initrd)))))
 
-(define (operating-system-derivation os)
-  "Return a derivation that builds OS."
-  (mlet* %store-monad
-      ((profile     (operating-system-profile os))
-       (etc ->      (operating-system-etc-directory os))
-       (boot        (operating-system-boot-script os))
-       (kernel  ->  (operating-system-kernel os))
-       (initrd      (operating-system-initrd-file os))
-       (locale      (operating-system-locale-directory os))
-       (params      (operating-system-parameters-file os)))
-    (lower-object
-     (file-union "system"
-                 `(("boot" ,#~#$boot)
-                   ("kernel" ,#~#$kernel)
-                   ("parameters" ,#~#$params)
-                   ("initrd" ,initrd)
-                   ("profile" ,#~#$profile)
-                   ("locale" ,#~#$locale)         ;used by libc
-                   ("etc" ,#~#$etc))))))
-
 ;;; system.scm ends here
diff --git a/gnu/system/linux-container.scm b/gnu/system/linux-container.scm
index c2eb773..4f38c5c 100644
--- a/gnu/system/linux-container.scm
+++ b/gnu/system/linux-container.scm
@@ -47,20 +47,6 @@
        (check? #f)
        (create-mount-point? #t)))))
 
-(define (system-container os)
-  "Return a derivation that builds OS as a Linux container."
-  (mlet* %store-monad
-      ((profile (operating-system-profile os))
-       (etc  -> (operating-system-etc-directory os))
-       (boot    (operating-system-boot-script os #:container? #t))
-       (locale  (operating-system-locale-directory os)))
-    (lower-object
-     (file-union "system-container"
-                 `(("boot" ,#~#$boot)
-                   ("profile" ,#~#$profile)
-                   ("locale" ,#~#$locale)
-                   ("etc" ,#~#$etc))))))
-
 (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
@@ -95,7 +81,9 @@ 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 (system-container os)))
+    (mlet* %store-monad ((os-drv (operating-system-derivation
+                                  os
+                                  #:container? #t)))
 
       (define script
         #~(begin
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 7be7347..7a8a751 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -491,10 +491,10 @@ building anything."
 (define (export-extension-graph os port)
   "Export the service extension graph of OS to PORT."
   (let* ((services (operating-system-services os))
-         (boot     (find (lambda (service)
-                           (eq? (service-kind service) boot-service-type))
+         (system   (find (lambda (service)
+                           (eq? (service-kind service) system-service-type))
                          services)))
-    (export-graph (list boot) (current-output-port)
+    (export-graph (list system) (current-output-port)
                   #:node-type (service-node-type services)
                   #:reverse-edges? #t)))