[shepherd] 03/06: service: ‘spawn-via-monitor’ associates a logger with the calling service.

[Ludovic Courtès]

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

commit c5c308afbd3331d3cee3c12f0574e73faf77970c
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Mon Mar 18 15:13:05 2024 +0100

    service: ‘spawn-via-monitor’ associates a logger with the calling service.
    
    * modules/shepherd/service.scm (process-monitor): Add ‘service’ argument
    to (spawn …) message.  Parameterize ‘current-service’ around
    ‘fork+exec-command’ call.
    (spawn-via-monitor): Adjust accordingly.
    (service-controller): Adjust debugging message in (register-logger …)
    handling.
    * tests/basic.sh: Add test.
---
 modules/shepherd/service.scm | 14 +++++++++-----
 tests/basic.sh               |  3 ++-
 2 files changed, 11 insertions(+), 6 deletions(-)

diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index a96a0a6..b02587b 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -712,9 +712,10 @@ denoting what the service provides."
        (loop))
       (('register-logger new-logger)              ;no reply
        (when logger
-         ;; Shouldn't happen.
+         ;; This happens when, for example, the 'start' procedure calls
+         ;; 'fork+exec-command' several times: each call creates a new logger.
          (local-output
-          (l10n "Adding logger to ~a, which already has one!")
+          (l10n "Registering new logger for ~a.")
           (service-canonical-name service))
          (put-message logger 'terminate))
        (loop (logger new-logger)))
@@ -2672,13 +2673,16 @@ may never terminate, even after sending it 
SIGKILL---e.g., kthreadd on Linux."
                          vlist-null
                          waiters)))
 
-      (('spawn arguments reply)
+      (('spawn arguments service reply)
        ;; Spawn the command as specified by ARGUMENTS; send the spawn result
        ;; (PID or exception) to REPLY; send its exit status to REPLY when it
        ;; terminates.  This operation is atomic: the WAITERS table is updated
        ;; before termination of PID can possibly be handled.
        (let ((result (boxed-errors
-                      (apply fork+exec-command arguments))))
+                      ;; Set 'current-service' so the logger for that process
+                      ;; can be attached to SERVICE.
+                      (parameterize ((current-service service))
+                        (apply fork+exec-command arguments)))))
          (put-message reply result)
          (match result
            (('exception . _)
@@ -2715,7 +2719,7 @@ context.  The process monitoring fiber is responsible for 
handling
 (define (spawn-via-monitor arguments)
   (let ((reply (make-channel)))
     (put-message (current-process-monitor)
-                 `(spawn ,arguments ,reply))
+                 `(spawn ,arguments ,(current-service) ,reply))
     (unboxed-errors (get-message reply))
     (get-message reply)))
 
diff --git a/tests/basic.sh b/tests/basic.sh
index 41f9b2c..e52139d 100644
--- a/tests/basic.sh
+++ b/tests/basic.sh
@@ -1,5 +1,5 @@
 # GNU Shepherd --- Test basic communication capabilities.
-# Copyright © 2013-2014, 2016-2019, 2022-2023 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2013-2014, 2016-2019, 2022-2024 Ludovic Courtès <ludo@gnu.org>
 # Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
 # Copyright © 2014 Alex Sassmannshausen <alex.sassmannshausen@gmail.com>
 #
@@ -158,6 +158,7 @@ $herd status broken | grep "stopped"
 # Check 'make-system-constructor' and 'make-system-destructor'.
 $herd start spawn-with-system
 $herd status spawn-with-system | grep running
+$herd status spawn-with-system | grep "starting from " # recent messages
 $herd stop spawn-with-system
 $herd status spawn-with-system | grep "stopped"