[shepherd] 10/32: shepherd: Use one fiber for signal handling, and one for clients.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository shepherd.

commit 46790f9d924af2a9521adccb9e6db6afd9c1a2e7
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Mon Mar 21 11:37:17 2022 +0100

    shepherd: Use one fiber for signal handling, and one for clients.
    
    * modules/shepherd.scm (unwind-protect): New macro.
    (call-with-server-socket): Use it instead of 'dynamic-wind'.
    (maybe-signal-port): Use it.
    (run-daemon): Spawn a fiber for signal handling.  Write connection
    processing loop in direct style, without 'select'.
    * modules/shepherd/support.scm (non-blocking-port): New procedure.
---
 modules/shepherd.scm         | 91 ++++++++++++++++++++++++++------------------
 modules/shepherd/support.scm |  7 ++++
 2 files changed, 60 insertions(+), 38 deletions(-)

diff --git a/modules/shepherd.scm b/modules/shepherd.scm
index 2345ff9..a8eb238 100644
--- a/modules/shepherd.scm
+++ b/modules/shepherd.scm
@@ -51,23 +51,40 @@
       (listen sock 10)
       sock)))
 
+(define-syntax-rule (unwind-protect body ... conclude)
+  "Evaluate BODY... and return its result(s), but always evaluate CONCLUDE
+before leaving, even if an exception is raised.
+
+This is *not* implemented with 'dynamic-wind' in order to play well with
+delimited continuations and fibers."
+  (let ((conclusion (lambda () conclude)))
+    (catch #t
+      (lambda ()
+        (call-with-values
+            (lambda ()
+              body ...)
+          (lambda results
+            (conclusion)
+            (apply values results))))
+      (lambda args
+        (conclusion)
+        (apply throw args)))))
+
 (define (call-with-server-socket file-name proc)
   "Call PROC, passing it a listening socket at FILE-NAME and deleting the
 socket file at FILE-NAME upon exit of PROC.  Return the values of PROC."
   (let ((sock (open-server-socket file-name)))
-    (dynamic-wind
-      noop
-      (lambda () (proc sock))
-      (lambda ()
-        (close sock)
-        (catch-system-error (delete-file file-name))))))
+    (unwind-protect (proc sock)
+                    (begin
+                      (close sock)
+                      (catch-system-error (delete-file file-name))))))
 
 (define (maybe-signal-port signals)
   "Return a signal port for SIGNALS, using 'signalfd' on GNU/Linux, or #f if
 that is not supported."
   (catch 'system-error
     (lambda ()
-      (let ((port (signalfd -1 signals)))
+      (let ((port (non-blocking-port (signalfd -1 signals))))
         ;; As per the signalfd(2) man page, block SIGNALS.  The tricky bit is
         ;; that SIGNALS must be blocked for all the threads; new threads will
         ;; inherit the signal mask, but we must ensure that neither Guile's
@@ -169,37 +186,35 @@ already ~a threads running, disabling 'signalfd' support")
          ;; "Failed to autoload handle-SIGCHLD in (ice-9 readline):"
          (handle-SIGCHLD)
 
-         (let next-command ((ports (if signal-port
-                                       (list signal-port sock)
-                                       (list sock))))
-           (define (read-from sock)
-             (match (accept sock)
-               ((command-source . client-address)
-                (setvbuf command-source (buffering-mode block) 1024)
-                (process-connection command-source))
-               (_ #f)))
-
-           ;; 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.
-           (match (select ports (list) (list)
-                          (and (not signal-port)
-                               (if poll-services? 0.5 30)))
-             (((port _ ...) _ _)
-              (if (and signal-port (eq? port signal-port))
-                  (handle-signal-port port)
-                  (read-from sock)))
-             (_
-              ;; 'select' returned an empty set, probably due to EINTR.
-              ;; Explicitly call the SIGCHLD handler because we cannot be
-              ;; sure the async will be queued and executed before we call
-              ;; 'select' again.
-              (handle-SIGCHLD)))
-
-           (when poll-services?
-             (check-for-dead-services))
-           (next-command ports))))))
+         ;; 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)))))
+
+         ;; Enter some sort of a REPL for commands.
+         (let next-command ()
+           (match (accept sock)
+             ((command-source . client-address)
+              (setvbuf command-source (buffering-mode block) 1024)
+              (spawn-fiber
+               (lambda ()
+                 (process-connection command-source))))
+             (_ #f))
+
+           (next-command))))))
 
 
 ;; Main program.
diff --git a/modules/shepherd/support.scm b/modules/shepherd/support.scm
index 57e96fe..67bde32 100644
--- a/modules/shepherd/support.scm
+++ b/modules/shepherd/support.scm
@@ -44,6 +44,7 @@
             program-name
             report-error
             display-line
+            non-blocking-port
 
             user-homedir
             user-default-log-file
@@ -243,6 +244,12 @@ There is NO WARRANTY, to the extent permitted by law.")))
   (display message port)
   (newline port))
 
+(define (non-blocking-port port)
+  "Return PORT after putting it in non-blocking mode."
+  (let ((flags (fcntl port F_GETFL)))
+    (fcntl port F_SETFL (logior O_NONBLOCK flags))
+    port))
+
 
 
 ;; Home directory of the user.