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.

2 files changed, 29 insertions, 20 deletions

diff --git a/gnu/services/herd.scm b/gnu/services/herd.scm
index 7a9db90012..03bfbf1d78 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 ca6f76c0f8..41f50c0e7a 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)))))