[shepherd] 04/08: service: Catch exceptions of essential tasks.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository shepherd.

commit f56c5872b36d740583e9e99d9df65e99e9875c56
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Sat Mar 25 18:38:57 2023 +0100

    service: Catch exceptions of essential tasks.
    
    * modules/shepherd/service.scm (essential-task-launcher): New procedure.
    (spawn-process-monitor, spawn-service-registry): Define in terms of
    'essential-task-launcher'.
---
 modules/shepherd/service.scm | 49 +++++++++++++++++++++++++++-----------------
 1 file changed, 30 insertions(+), 19 deletions(-)

diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index 7cd36fd..5b9ae19 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -998,16 +998,36 @@ requests arriving on @var{channel}."
        (put-message reply (vlist->list registered))
        (loop registered)))))
 
-(define (spawn-service-registry)
-  "Spawn a new service monitor fiber and return a channel to send it requests."
-  (define channel
-    (make-channel))
+(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)."
+  (lambda ()
+    (define channel
+      (make-channel))
 
-  (spawn-fiber
-   (lambda ()
-     (service-registry 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)))
 
-  channel)
+         ;; Restarting is not enough to recover because all state has been
+         ;; lost, but it might be enough to halt the system.
+         (loop))))
+
+    channel))
+
+(define spawn-service-registry
+  (essential-task-launcher 'service-registry service-registry))
 
 (define current-registry-channel
   ;; The channel to communicate with the current service monitor.
@@ -2207,17 +2227,8 @@ otherwise by updating its state."
              (put-message reply 0)
              (loop waiters)))))))
 
-(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 spawn-process-monitor
+  (essential-task-launcher 'process-monitor process-monitor))
 
 (define current-process-monitor
   ;; Channel to communicate with the process monitoring fiber.