[shepherd] branch master updated: shepherd: Make signal handling fiber an essential task.

[Ludovic Courtès]

This is an automated email from the git hooks/post-receive script.

civodul pushed a commit to branch master
in repository shepherd.

The following commit(s) were added to refs/heads/master by this push:
     new b9a37f3  shepherd: Make signal handling fiber an essential task.
b9a37f3 is described below

commit b9a37f3d7669d6a4d7b73fa4d90c527eeb16bb7c
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Fri May 26 15:52:01 2023 +0200

    shepherd: Make signal handling fiber an essential task.
    
    This ensures the signal handling loop can never exit.  Previously, this
    could in theory happen if, say, 'handle-SIGCHLD' would throw, though
    there is no clear scenario how this can happen.
    
    * modules/shepherd/service.scm (essential-task-thunk): New procedure.
    (essential-task-launcher): Use it.
    * modules/shepherd.scm (run-daemon): Define 'signal-handler'.
    Wrap it with 'essential-task-thunk' when launching it.
---
 modules/shepherd.scm         | 33 ++++++++++++++++++---------------
 modules/shepherd/service.scm | 41 +++++++++++++++++++++++------------------
 2 files changed, 41 insertions(+), 33 deletions(-)

diff --git a/modules/shepherd.scm b/modules/shepherd.scm
index ad74089..6bd30ca 100644
--- a/modules/shepherd.scm
+++ b/modules/shepherd.scm
@@ -157,6 +157,23 @@ already ~a threads running, disabling 'signalfd' support")
 
 (define* (run-daemon #:key (config-file (default-config-file))
                      socket-file pid-file signal-port poll-services?)
+  (define signal-handler
+    ;; Thunk that waits for signals (particularly SIGCHLD) and handles them.
+    (if signal-port
+        (lambda ()
+          (let loop ()
+            (handle-signal-port signal-port)
+            (loop)))
+        (lambda ()
+          ;; When not using signalfd(2), there's always a time window before
+          ;; 'select' during which a handler async can be queued but not
+          ;; executed.  Work around it by exiting 'select' every few seconds.
+          (let loop ()
+            (sleep (if poll-services? 0.5 30))
+            (when poll-services?
+              (check-for-dead-services))
+            (loop)))))
+
   ;; We might have file descriptors inherited from our parent, as well as file
   ;; descriptors wrongfully opened by Guile or Fibers (see
   ;; <https://bugs.gnu.org/57567> and
@@ -197,21 +214,7 @@ already ~a threads running, disabling 'signalfd' support")
 
          ;; Spawn a signal handling fiber.
          (spawn-fiber
-          (if signal-port
-              (lambda ()
-                (let loop ()
-                  (handle-signal-port signal-port)
-                  (loop)))
-              (lambda ()
-                ;; When not using signalfd(2), there's always a time window
-                ;; before 'select' during which a handler async can be
-                ;; queued but not executed.  Work around it by exiting
-                ;; 'select' every few seconds.
-                (let loop ()
-                  (sleep (if poll-services? 0.5 30))
-                  (when poll-services?
-                    (check-for-dead-services))
-                  (loop)))))
+          (essential-task-thunk 'signal-handler signal-handler))
 
          ;; Enter some sort of a REPL for commands.
          (let next-command ()
diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index 63e7155..0f0da09 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -150,6 +150,7 @@
             condition->sexp
 
             get-message*                      ;XXX: for lack of a better place
+            essential-task-thunk
 
             ;; Deprecated bindings.
             provided-by
@@ -1129,6 +1130,27 @@ requests arriving on @var{channel}."
        (put-message reply (vlist-length registered))
        (loop registered)))))
 
+(define (essential-task-thunk name proc . args)
+  "Return a thunk that calls PROC with ARGS and keeps calling it if it returns
+or throws."
+  (lambda ()
+    ;; PROC should never return.  If it does, log the problem and
+    ;; desperately attempt to restart it.
+    (let loop ()
+      (catch #t
+        (lambda ()
+          (apply proc args)
+          (local-output (l10n "Essential task ~a exited unexpectedly.")
+                        name))
+        (lambda args
+          (local-output
+           (l10n "Uncaught exception in essential task ~a: ~s")
+           name args)))
+
+      ;; Restarting is not enough to recover because all state has been
+      ;; lost, but it might be enough to halt the system.
+      (loop))))
+
 (define (essential-task-launcher name proc)
   "Return a thunk that runs @var{proc} in a fiber, endlessly (an essential
 task is one that should never fail)."
@@ -1136,24 +1158,7 @@ task is one that should never fail)."
     (define channel
       (make-channel))
 
-    (spawn-fiber
-     (lambda ()
-       ;; PROC should never return.  If it does, log the problem and
-       ;; desperately attempt to restart it.
-       (let loop ()
-         (catch #t
-           (lambda ()
-             (proc channel)
-             (local-output (l10n "Essential task ~a exited unexpectedly.")
-                           name))
-           (lambda args
-             (local-output
-              (l10n "Uncaught exception in essential task ~a: ~s")
-              name args)))
-
-         ;; Restarting is not enough to recover because all state has been
-         ;; lost, but it might be enough to halt the system.
-         (loop))))
+    (spawn-fiber (essential-task-thunk name proc channel))
 
     channel))