gnu: Fix typo in description of xfce-desktop-service.

[jackhill/guix/guix.git] / gnu / services / shepherd.scm

diff --git a/gnu/services/shepherd.scm b/gnu/services/shepherd.scm
index a14f515..3273184 100644 (file)
--- a/gnu/services/shepherd.scm
+++ b/gnu/services/shepherd.scm
@@ -25,6 +25,7 @@
   #:use-module (guix records)
   #:use-module (guix derivations)                 ;imported-modules, etc.
   #:use-module (gnu services)
+  #:use-module (gnu services herd)
   #:use-module (gnu packages admin)
   #:use-module (ice-9 match)
   #:use-module (ice-9 vlist)
@@ -52,7 +53,9 @@
 
             shepherd-service-file
 
-            shepherd-service-back-edges))
+            shepherd-service-lookup-procedure
+            shepherd-service-back-edges
+            shepherd-service-upgrade))
 
 ;;; Commentary:
 ;;;
@@ -249,20 +252,35 @@ stored."
 
     (gexp->file "shepherd.conf" config)))
 
-(define (shepherd-service-back-edges services)
+(define* (shepherd-service-lookup-procedure services
+                                            #:optional
+                                            (provision
+                                             shepherd-service-provision))
+  "Return a procedure that, when passed a symbol, return the item among
+SERVICES that provides this symbol.  PROVISION must be a one-argument
+procedure that takes a service and returns the list of symbols it provides."
+  (let ((services (fold (lambda (service result)
+                          (fold (cut vhash-consq <> service <>)
+                                result
+                                (provision service)))
+                        vlist-null
+                        services)))
+    (lambda (name)
+      (match (vhash-assq name services)
+        ((_ . service) service)
+        (#f            #f)))))
+
+(define* (shepherd-service-back-edges services
+                                      #:key
+                                      (provision shepherd-service-provision)
+                                      (requirement shepherd-service-requirement))
   "Return a procedure that, when given a <shepherd-service> from SERVICES,
-returns the list of <shepherd-service> that depend on it."
+returns the list of <shepherd-service> that depend on it.
+
+Use PROVISION and REQUIREMENT as one-argument procedures that return the
+symbols provided/required by a service."
   (define provision->service
-    (let ((services (fold (lambda (service result)
-                            (fold (cut vhash-consq <> service <>)
-                                  result
-                                  (shepherd-service-provision service)))
-                          vlist-null
-                          services)))
-      (lambda (name)
-        (match (vhash-assq name services)
-          ((_ . service) service)
-          (#f            #f)))))
+    (shepherd-service-lookup-procedure services provision))
 
   (define edges
     (fold (lambda (service edges)
@@ -270,11 +288,59 @@ returns the list of <shepherd-service> that depend on it."
                     (vhash-consq (provision->service requirement) service
                                  edges))
                   edges
-                  (shepherd-service-requirement service)))
+                  (requirement service)))
           vlist-null
           services))
 
   (lambda (service)
     (vhash-foldq* cons '() service edges)))
 
+(define (shepherd-service-upgrade live target)
+  "Return two values: the subset of LIVE (a list of <live-service>) that needs
+to be unloaded, and the subset of TARGET (a list of <shepherd-service>) that
+needs to be loaded."
+  (define (essential? service)
+    (memq (first (live-service-provision service))
+          '(root shepherd)))
+
+  (define lookup-target
+    (shepherd-service-lookup-procedure target
+                                       shepherd-service-provision))
+
+  (define lookup-live
+    (shepherd-service-lookup-procedure live
+                                       live-service-provision))
+
+  (define (running? service)
+    (and=> (lookup-live (shepherd-service-canonical-name service))
+           live-service-running))
+
+  (define (stopped service)
+    (match (lookup-live (shepherd-service-canonical-name service))
+      (#f #f)
+      (service (and (not (live-service-running service))
+                    service))))
+
+  (define live-service-dependents
+    (shepherd-service-back-edges live
+                                 #:provision live-service-provision
+                                 #:requirement live-service-requirement))
+
+  (define (obsolete? service)
+    (match (lookup-target (first (live-service-provision service)))
+      (#f (every obsolete? (live-service-dependents service)))
+      (_  #f)))
+
+  (define to-load
+    ;; Only load services that are either new or currently stopped.
+    (remove running? target))
+
+  (define to-unload
+    ;; Unload services that are (1) no longer required, or (2) are in TO-LOAD.
+    (remove essential?
+            (append (filter obsolete? live)
+                    (filter-map stopped to-load))))
+
+  (values to-unload to-load))
+
 ;;; shepherd.scm ends here