[shepherd] 14/16: service: Allow 'running' value to be a thunk.

[Ludovic Courtès]

civodul pushed a commit to branch wip-fibers
in repository shepherd.

commit ef0a6c87272881e820a77320047522d88872faa6
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Sat Mar 26 10:28:21 2022 +0100

    service: Allow 'running' value to be a thunk.
    
    Constructors may now return a thunk whose return value changes over
    time.
    
    * modules/shepherd/service.scm (service-running-value): New procedure.
    (running?, start, action, stop, service->sexp, handle-SIGCHLD)
    (check-for-dead-services): Call it instead of accessing the 'running'
    slot directly.
---
 doc/shepherd.texi            |  3 ++-
 modules/shepherd/service.scm | 26 ++++++++++++++++----------
 2 files changed, 18 insertions(+), 11 deletions(-)

diff --git a/doc/shepherd.texi b/doc/shepherd.texi
index ca00f28..649b69e 100644
--- a/doc/shepherd.texi
+++ b/doc/shepherd.texi
@@ -641,7 +641,8 @@ be set to the return value of the procedure in the 
@code{start} slot.
 It will also be passed as an argument to the procedure in the
 @code{stop} slot.  If it is set a value that is an integer, it is
 assumed to be a process id, and shepherd will monitor the process for
-unexpected exits.  This slot can not be initialized with a keyword.
+unexpected exits.  If it is a procedure, that procedure is called to get
+at the underlying value.  This slot cannot be initialized with a keyword.
 
 @item
 @vindex respawn? (slot of <service>)
diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index 2de3671..4831c90 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -292,9 +292,15 @@ wire."
 (define-method (canonical-name (obj <service>))
   (car (provided-by obj)))
 
+;; Return the "running value" of OBJ.
+(define-method (service-running-value (obj <service>))
+  (match (slot-ref obj 'running)
+    ((? procedure? proc) (proc))
+    (value value)))
+
 ;; Return whether the service is currently running.
 (define-method (running? (obj <service>))
-  (and (slot-ref obj 'running) #t))
+  (and (service-running-value obj) #t))
 
 ;; Return a list of all actions implemented by OBJ. 
 (define-method (action-list (obj <service>))
@@ -326,18 +332,18 @@ wire."
   (cond ((running? obj)
         (local-output (l10n "Service ~a is already running.")
                       (canonical-name obj))
-         (slot-ref obj 'running))
+         (service-running-value obj))
        ((not (enabled? obj))
         (local-output (l10n "Service ~a is currently disabled.")
                       (canonical-name obj))
-         (slot-ref obj 'running))
+         (service-running-value obj))
        ((let ((conflicts (conflicts-with-running obj)))
           (or (null? conflicts)
               (local-output (l10n "Service ~a conflicts with running services 
~a.")
                             (canonical-name obj)
                             (map canonical-name conflicts)))
           (not (null? conflicts)))
-        (slot-ref obj 'running))
+        (service-running-value obj))
        (else
         ;; It is not running and does not conflict with anything
         ;; that's running, so we can go on and launch it.
@@ -358,7 +364,7 @@ wire."
                                                              key args)))))
 
           ;; Status message.
-           (let ((running (slot-ref obj 'running)))
+           (let ((running (service-running-value obj)))
              (when (one-shot? obj)
                (slot-set! obj 'running #f))
              (local-output (if running
@@ -424,7 +430,7 @@ is not already running, and will return SERVICE's canonical 
name in a list."
                (catch #t
                  (lambda ()
                    (apply (slot-ref service 'stop)
-                          (slot-ref service 'running)
+                          (service-running-value service)
                           args))
                  (lambda (key . args)
                    ;; Special case: 'root' may quit.
@@ -497,7 +503,7 @@ is not already running, and will return SERVICE's canonical 
name in a list."
     ;; it provides generally useful functionality and information.
     (catch #t
       (lambda ()
-        (apply proc (slot-ref obj 'running) args))
+        (apply proc (service-running-value obj) args))
       (lambda (key . args)
         ;; Special case: 'root' may quit.
         (and (eq? root-service obj)
@@ -583,7 +589,7 @@ clients."
             ;; that whole thing is valid read syntax; we do not want things
             ;; like #<undefined> to be sent to the client.
             (enabled? ,(enabled? service))
-            (running ,(result->sexp (slot-ref service 'running)))
+            (running ,(result->sexp (service-running-value service)))
             (conflicts ,(map canonical-name (conflicts-with service)))
             (last-respawns ,(slot-ref service 'last-respawns))
             ,@(if (slot-ref service 'one-shot?)
@@ -1383,7 +1389,7 @@ otherwise by updating its state."
       ((pid . _)
        (let ((serv (find-service (lambda (serv)
                                    (and (enabled? serv)
-                                        (match (slot-ref serv 'running)
+                                        (match (service-running-value serv)
                                           ((? number? pid*)
                                            (= pid pid*))
                                           (_ #f)))))))
@@ -1577,7 +1583,7 @@ where prctl/PR_SET_CHILD_SUBREAPER is unsupported."
     (catch-system-error (kill pid 0) #t))
 
   (for-each-service (lambda (service)
-                      (let ((running (slot-ref service 'running)))
+                      (let ((running (service-running-value service)))
                         (when (and (integer? running)
                                    (not (process-exists? running)))
                           (local-output (l10n "PID ~a (~a) is dead!")