[shepherd] 01/02: service: Spawn a fiber responsible for process monitoring.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository shepherd.

commit 039c7a8f3f4ecc359c91bffad2ac770db12ab33c
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Sun Nov 13 21:14:52 2022 +0100

    service: Spawn a fiber responsible for process monitoring.
    
    * modules/shepherd/service.scm (process-monitor)
    (spawn-process-monitor, call-with-process-monitor): New procedures.
    (current-process-monitor): New variable.
    (with-process-monitor): New macro.
    (handle-SIGCHLD): Change to delegate process termination handling
    to (current-process-monitor) by sending it a message.
    * modules/shepherd.scm (main): Wrap 'run-daemon' call in
    'with-process-monitor'.
---
 .dir-locals.el               |  3 +-
 modules/shepherd.scm         | 13 ++++----
 modules/shepherd/service.scm | 70 ++++++++++++++++++++++++++++++++++----------
 3 files changed, 64 insertions(+), 22 deletions(-)

diff --git a/.dir-locals.el b/.dir-locals.el
index 3e64a3e..d5cc60b 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -11,6 +11,7 @@
       . "<https?://\\(debbugs\\|bugs\\)\\.gnu\\.org/\\([0-9]+\\)>")))
  (scheme-mode
   . ((indent-tabs-mode . nil)
-     (eval . (put 'with-blocked-signals 'scheme-indent-function 1))))
+     (eval . (put 'with-blocked-signals 'scheme-indent-function 1))
+     (eval . (put 'with-process-monitor 'scheme-indent-function 0))))
  (texinfo-mode    . ((indent-tabs-mode . nil)
                      (fill-column . 72))))
diff --git a/modules/shepherd.scm b/modules/shepherd.scm
index 91f3318..2fa7f31 100644
--- a/modules/shepherd.scm
+++ b/modules/shepherd.scm
@@ -415,12 +415,13 @@ already ~a threads running, disabling 'signalfd' support")
        (lambda ()
          (catch 'quit
            (lambda ()
-             (run-daemon #:socket-file socket-file
-                         #:config-file config-file
-                         #:pid-file pid-file
-                         #:signal-port signal-port
-                         #:poll-services? poll-services?
-                         #:persistency persistency))
+             (with-process-monitor
+               (run-daemon #:socket-file socket-file
+                           #:config-file config-file
+                           #:pid-file pid-file
+                           #:signal-port signal-port
+                           #:poll-services? poll-services?
+                           #:persistency persistency)))
            (case-lambda
              ((key value . _)
               (primitive-exit value))
diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index e851406..144edef 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -26,6 +26,7 @@
 (define-module (shepherd service)
   #:use-module ((fibers)
                 #:hide (sleep))
+  #:use-module (fibers channels)
   #:use-module (fibers scheduler)
   #:use-module (oop goops)
   #:use-module (srfi srfi-1)
@@ -75,6 +76,7 @@
             lookup-services
             respawn-service
             handle-SIGCHLD
+            with-process-monitor
             %precious-signals
             register-services
             provided-by
@@ -1784,21 +1786,59 @@ otherwise by updating its state."
        ;; Nothing left to wait for.
        #t)
       ((pid . status)
-       (let ((serv (find-service (lambda (serv)
-                                   (and (enabled? serv)
-                                        (match (service-running-value serv)
-                                          ((? number? pid*)
-                                           (= pid pid*))
-                                          (_ #f)))))))
-
-         ;; SERV can be #f for instance when this code runs just after a
-         ;; service's 'stop' method killed its process and completed.
-         (when serv
-           (handle-service-termination serv status))
-
-         ;; As noted in libc's manual (info "(libc) Process Completion"),
-         ;; loop so we don't miss any terminated child process.
-         (loop))))))
+       ;; Let the process monitor handle it.
+       (put-message (current-process-monitor)
+                    `(handle-process-termination ,pid ,status))
+
+       ;; As noted in libc's manual (info "(libc) Process Completion"),
+       ;; loop so we don't miss any terminated child process.
+       (loop)))))
+
+(define (process-monitor channel)
+  "Run a process monitor that handles requests received over @var{channel}."
+  (let loop ()
+    (match (get-message channel)
+      (('handle-process-termination pid status)
+       ;; Handle the termination of PID.
+       (match (find-service (lambda (serv)
+                              (and (enabled? serv)
+                                   (match (service-running-value serv)
+                                     ((? number? pid*)
+                                      (= pid pid*))
+                                     (_ #f)))))
+         (#f
+          ;; SERV can be #f for instance when this code runs just after a
+          ;; service's 'stop' method killed its process and completed.
+          #f)
+         ((? service? service)
+          (handle-service-termination service status)))
+       (loop)))))
+
+(define (spawn-process-monitor)
+  "Spawn a process monitoring fiber and return a channel to communicate with
+it."
+  (define channel
+    (make-channel))
+
+  (spawn-fiber
+   (lambda ()
+     (process-monitor channel)))
+
+  channel)
+
+(define current-process-monitor
+  ;; Channel to communicate with the process monitoring fiber.
+  (make-parameter #f))
+
+(define (call-with-process-monitor thunk)
+  (parameterize ((current-process-monitor (spawn-process-monitor)))
+    (thunk)))
+
+(define-syntax-rule (with-process-monitor exp ...)
+  "Spawn a process monitoring fiber and evaluate @var{exp}... within that
+context.  The process monitoring fiber is responsible for handling
+@code{SIGCHLD} and generally dealing with process creation and termination."
+  (call-with-process-monitor (lambda () exp ...)))
 
 (define (handle-service-termination service status)
   "Handle the termination of the process associated with @var{service}, whose