02/08: services: herd: Provide <live-service> objects.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 183605c8533ad321ff8bba209b64071a9e84714a
Author: Ludovic Courtès <address@hidden>
Date:   Tue Aug 30 17:59:15 2016 +0200

    services: herd: Provide <live-service> objects.
    
    * gnu/services/herd.scm (<live-service>): New record type.
    (current-services): Change to return a single value: #f or a list of
    <live-service>.
    * guix/scripts/system.scm (call-with-service-upgrade-info): Adjust
    accordingly.
    * gnu/tests/base.scm (run-basic-test)["shepherd services"]: Adjust
    accordingly.
---
 gnu/services/herd.scm   |   37 ++++++++++++++++++++--------------
 gnu/tests/base.scm      |   12 ++++++-----
 guix/scripts/system.scm |   51 ++++++++++++++++++++++++++---------------------
 3 files changed, 57 insertions(+), 43 deletions(-)

diff --git a/gnu/services/herd.scm b/gnu/services/herd.scm
index 7a9db90..03bfbf1 100644
--- a/gnu/services/herd.scm
+++ b/gnu/services/herd.scm
@@ -17,8 +17,8 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu services herd)
-  #:use-module (guix combinators)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
@@ -37,6 +37,11 @@
             unknown-shepherd-error?
             unknown-shepherd-error-sexp
 
+            live-service?
+            live-service-provision
+            live-service-requirement
+            live-service-running
+
             current-services
             unload-services
             unload-service
@@ -165,25 +170,27 @@ of pairs."
      (let ((key (and=> (assoc-ref alist 'key) car)) ...)
        exp ...))))
 
+;; Information about live Shepherd services.
+(define-record-type <live-service>
+  (live-service provision requirement running)
+  live-service?
+  (provision    live-service-provision)           ;list of symbols
+  (requirement  live-service-requirement)         ;list of symbols
+  (running      live-service-running))            ;#f | object
+
 (define (current-services)
-  "Return two lists: the list of currently running services, and the list of
-currently stopped services.  Return #f and #f if the list of services could
-not be obtained."
+  "Return the list of currently defined Shepherd services, represented as
+<live-service> objects.  Return #f if the list of services could not be
+obtained."
   (with-shepherd-action 'root ('status) services
     (match services
       ((('service ('version 0 _ ...) _ ...) ...)
-       (fold2 (lambda (service running-services stopped-services)
-                (alist-let* service (provides running)
-                  (if running
-                      (values (cons (first provides) running-services)
-                              stopped-services)
-                      (values running-services
-                              (cons (first provides) stopped-services)))))
-              '()
-              '()
-              services))
+       (map (lambda (service)
+              (alist-let* service (provides requires running)
+                (live-service provides requires running)))
+            services))
       (x
-       (values #f #f)))))
+       #f))))
 
 (define (unload-service service)
   "Unload SERVICE, a symbol name; return #t on success."
diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm
index ca6f76c..41f50c0 100644
--- a/gnu/tests/base.scm
+++ b/gnu/tests/base.scm
@@ -122,11 +122,13 @@ info --version")
                               (operating-system-user-accounts os))))))
 
           (test-assert "shepherd services"
-            (let ((services (marionette-eval '(begin
-                                                (use-modules (gnu services 
herd))
-                                                (call-with-values 
current-services
-                                                  append))
-                                             marionette)))
+            (let ((services (marionette-eval
+                             '(begin
+                                (use-modules (gnu services herd))
+
+                                (map (compose car live-service-provision)
+                                     (current-services)))
+                             marionette)))
               (lset= eq?
                      (pk 'services services)
                      '(root #$@(operating-system-shepherd-service-names os)))))
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index a9fe7d5..55a8e47 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -283,29 +283,34 @@ unload."
     (map (compose first shepherd-service-provision)
          new-services))
 
-  (let-values (((running stopped) (current-services)))
-    (if (and running stopped)
-        (let* ((to-load
-                ;; Only load services that are either new or currently stopped.
-                (remove (lambda (service)
-                          (memq (first (shepherd-service-provision service))
-                                running))
-                        new-services))
-               (to-unload
-                ;; Unload services that are (1) no longer required, or (2) are
-                ;; in TO-LOAD.
-                (remove essential?
-                        (append (remove (lambda (service)
-                                          (memq service new-service-names))
-                                        (append running stopped))
-                                (filter (lambda (service)
-                                          (memq service stopped))
-                                        (map shepherd-service-canonical-name
-                                             to-load))))))
-          (mproc to-load to-unload))
-        (with-monad %store-monad
-          (warning (_ "failed to obtain list of shepherd services~%"))
-          (return #f)))))
+  (match (current-services)
+    ((services ...)
+     (let* ((running (map (compose first live-service-provision)
+                          (filter live-service-running services)))
+            (stopped (map (compose first live-service-provision)
+                          (remove live-service-running services)))
+            (to-load
+             ;; Only load services that are either new or currently stopped.
+             (remove (lambda (service)
+                       (memq (first (shepherd-service-provision service))
+                             running))
+                     new-services))
+            (to-unload
+             ;; Unload services that are (1) no longer required, or (2) are
+             ;; in TO-LOAD.
+             (remove essential?
+                     (append (remove (lambda (service)
+                                       (memq service new-service-names))
+                                     (append running stopped))
+                             (filter (lambda (service)
+                                       (memq service stopped))
+                                     (map shepherd-service-canonical-name
+                                          to-load))))))
+       (mproc to-load to-unload)))
+    (#f
+     (with-monad %store-monad
+       (warning (_ "failed to obtain list of shepherd services~%"))
+       (return #f)))))
 
 (define (upgrade-shepherd-services os)
   "Upgrade the Shepherd (PID 1) by unloading obsolete services and loading new