From d62e201cfd0f1e48c14586489d0e2b80ce943d4f Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Mon, 2 Nov 2015 18:44:17 +0100
Subject: 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.
---
 gnu/system.scm | 54 +++++++++++++++++++++++++++++++-----------------------
 1 file changed, 31 insertions(+), 23 deletions(-)

(limited to 'gnu/system.scm')

diff --git a/gnu/system.scm b/gnu/system.scm
index 8fed857b39..c26d27028b 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
-- 
cgit v1.2.3