03/07: services: Add 'profile-service-type'.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit af4c3fd5e37d477bffce167909fbc0776a860204
Author: Ludovic Courtès <address@hidden>
Date:   Mon Nov 2 21:52:28 2015 +0100

    services: Add 'profile-service-type'.
    
    * gnu/services.scm (packages->profile-entry): New procedure.
      (profile-service-type): New variable.
    * gnu/system.scm (operating-system-directory-base-entries): Remove
      the "profile" entry.
      (essential-services): Add a PROFILE-SERVICE-TYPE instance.
      (operating-system-profile): Rewrite in terms of 'fold-services'.
    * doc/guix.texi (Service Reference): Add 'profile-service-type'.
    * doc/images/service-graph.dot: Likewise.
---
 doc/guix.texi                |    6 ++++++
 doc/images/service-graph.dot |    2 ++
 gnu/services.scm             |   19 +++++++++++++++++++
 gnu/system.scm               |   24 ++++++++++++++----------
 4 files changed, 41 insertions(+), 10 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 6ab98de..8976752 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -7899,6 +7899,12 @@ executable file names, passed as gexps, and adds them to 
the set of
 setuid-root programs on the system (@pxref{Setuid Programs}).
 @end defvr
 
address@hidden {Scheme Variable} profile-service-type
+Type of the service that populates the @dfn{system profile}---i.e., the
+programs under @file{/run/current-system/profile}.  Other services can
+extend it by passing it lists of packages to add to the system profile.
address@hidden defvr
+
 
 @node dmd Services
 @subsubsection dmd Services
diff --git a/doc/images/service-graph.dot b/doc/images/service-graph.dot
index 04f231b..b084005 100644
--- a/doc/images/service-graph.dot
+++ b/doc/images/service-graph.dot
@@ -2,6 +2,7 @@ digraph "Service Type Dependencies" {
   dmd [shape = box, fontname = Helvetica];
   pam [shape = box, fontname = Helvetica];
   etc [shape = box, fontname = Helvetica];
+  profile [shape = box, fontname = Helvetica];
   accounts [shape = box, fontname = Helvetica];
   activation [shape = box, fontname = Helvetica];
   boot [shape = box, fontname = Helvetica];
@@ -35,4 +36,5 @@ digraph "Service Type Dependencies" {
   guix -> accounts;
   boot -> system;
   etc -> system;
+  profile -> system;
 }
diff --git a/gnu/services.scm b/gnu/services.scm
index 8a66d45..0e1c74b 100644
--- a/gnu/services.scm
+++ b/gnu/services.scm
@@ -21,6 +21,7 @@
   #:use-module (guix monads)
   #:use-module (guix store)
   #:use-module (guix records)
+  #:use-module (guix profiles)
   #:use-module (guix sets)
   #:use-module (guix ui)
   #:use-module (gnu packages base)
@@ -68,6 +69,7 @@
             etc-service-type
             etc-directory
             setuid-program-service-type
+            profile-service-type
             firmware-service-type
 
             %boot-service
@@ -414,6 +416,23 @@ FILES must be a list of name/file-like object pairs."
                 (compose concatenate)
                 (extend append)))
 
+(define (packages->profile-entry packages)
+  "Return a system entry for the profile containing PACKAGES."
+  (mlet %store-monad ((profile (profile-derivation
+                                (manifest (map package->manifest-entry
+                                               (delete-duplicates packages 
eq?))))))
+    (return `(("profile" ,profile)))))
+
+(define profile-service-type
+  ;; The service that populates the system's profile---i.e.,
+  ;; /run/current-system/profile.  It is extended by package lists.
+  (service-type (name 'profile)
+                (extensions
+                 (list (service-extension system-service-type
+                                          packages->profile-entry)))
+                (compose concatenate)
+                (extend append)))
+
 (define (firmware->activation-gexp firmware)
   "Return a gexp to make the packages listed in FIRMWARE loadable by the
 kernel."
diff --git a/gnu/system.scm b/gnu/system.scm
index c26d270..85a596d 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -257,11 +257,9 @@ from the initrd."
 (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)))
+  (mlet %store-monad ((locale (operating-system-locale-directory os)))
     (if container?
-        (return `(("profile" ,profile)
-                  ("locale" ,locale)))
+        (return `(("locale" ,locale)))
         (mlet %store-monad
             ((kernel  ->  (operating-system-kernel os))
              (initrd      (operating-system-initrd-file os))
@@ -269,7 +267,6 @@ value of the SYSTEM-SERVICE-TYPE service."
           (return `(("kernel" ,kernel)
                     ("parameters" ,params)
                     ("initrd" ,initrd)
-                    ("profile" ,profile)
                     ("locale" ,locale)))))))      ;used by libc
 
 (define* (essential-services os #:key container?)
@@ -305,6 +302,8 @@ a container or that of a \"bare metal\" system."
            host-name procs root-fs unmount
            (service setuid-program-service-type
                     (operating-system-setuid-programs os))
+           (service profile-service-type
+                    (operating-system-packages os))
            (append other-fs mappings swaps
 
                    ;; Add the firmware service, unless we are building for a
@@ -534,11 +533,6 @@ fi\n")))
                                       #$(operating-system-timezone os)))
        ("sudoers" ,(operating-system-sudoers-file os))))))
 
-(define (operating-system-profile os)
-  "Return a derivation that builds the system profile of OS."
-  (profile-derivation (manifest (map package->manifest-entry
-                                     (operating-system-packages os)))))
-
 (define %root-account
   ;; Default root account.
   (user-account
@@ -639,6 +633,16 @@ hardware-related operations as necessary when booting a 
Linux container."
     ;; SYSTEM contains the derivation as a monadic value.
     (service-parameters system)))
 
+(define* (operating-system-profile os #:key container?)
+  "Return a derivation that builds the system profile of OS."
+  (mlet* %store-monad
+      ((services -> (operating-system-services os #:container? container?))
+       (profile (fold-services services
+                               #:target-type profile-service-type)))
+    (match profile
+      (("profile" profile)
+       (return profile)))))
+
 (define (operating-system-root-file-system os)
   "Return the root file system of OS."
   (find (match-lambda