[shepherd] 02/04: service: Record recent process exit statuses.

[Ludovic Courtès]

civodul pushed a commit to branch devel
in repository shepherd.

commit 5f36759ca7e4145fb80e623f5b3a085f0c635c9f
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Wed Feb 21 23:10:21 2024 +0100

    service: Record recent process exit statuses.
    
    * modules/shepherd/service.scm (%max-recorded-exit-statuses): New
    variable.
    (service-controller): Add ‘exit-statuses’ loop variable.  Handle
    'exit-statuses messages.  In 'handle-termination handler, record
    EXIT-STATUS.  Handle 'record-process-exit-status messages.
    (service-process-exit-statuses): New procedure.
    (service->sexp): Add ‘service-statuses’.
    (make-kill-destructor): Send 'record-process-exit-status message to the
    current service.
    * tests/status-sexp.sh: Adjust accordingly.
---
 doc/shepherd.texi            |  5 +++++
 modules/shepherd/service.scm | 41 ++++++++++++++++++++++++++++++++++-------
 tests/status-sexp.sh         |  4 ++++
 3 files changed, 43 insertions(+), 7 deletions(-)

diff --git a/doc/shepherd.texi b/doc/shepherd.texi
index 3dbf45a..57230c3 100644
--- a/doc/shepherd.texi
+++ b/doc/shepherd.texi
@@ -1035,6 +1035,11 @@ Return the list of startup failure times or respawn 
times of
 @var{service}.
 @end deffn
 
+@deffn {Procedure} service-process-exit-statuses @var{services}
+Return the list of last exit statuses of @var{service}'s main process
+(most recent first).
+@end deffn
+
 @cindex replacement, or a service
 @deffn {Procedure} service-replacement @var{service}
 Return the @dfn{replacement} of @var{service}, or @code{#f} if there is
diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index 78a0e1d..7514aec 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -69,6 +69,7 @@
             service-respawn-times
             service-startup-failures
             service-status-changes
+            service-process-exit-statuses
             service-replacement
             service-recent-messages
             service-log-file
@@ -444,6 +445,10 @@ denoting what the service provides."
   ;; Maximum number of service startup failures that are recorded.
   10)
 
+(define %max-recorded-exit-statuses
+  ;; Maximum number of service process exit statuses that are recorded.
+  10)
+
 (define (service-controller service channel)
   "Encapsulate @var{service} state and serve requests arriving on
 @var{channel}."
@@ -467,6 +472,8 @@ denoting what the service provides."
                   (failures                    ;list of timestamps
                    (ring-buffer %max-recorded-startup-failures))
                   (respawns '())               ;list of timestamps
+                  (exit-statuses
+                   (ring-buffer %max-recorded-exit-statuses))
                   (replacement #f)
                   (logger #f))                 ;channel of the logger
     (define (update-status-changes status)
@@ -492,6 +499,9 @@ denoting what the service provides."
       (('status-changes reply)
        (put-message reply changes)
        (loop))
+      (('exit-statuses reply)
+       (put-message reply exit-statuses)
+       (loop))
 
       ('enable                                    ;no reply
        (loop (enabled? #t)))
@@ -674,8 +684,16 @@ denoting what the service provides."
                   (put-message logger 'terminate))))
              (loop (status 'stopped)
                    (changes (update-status-changes 'stopped))
+                   (exit-statuses
+                    (ring-buffer-insert (cons exit-status (current-time))
+                                        exit-statuses))
                    (value #f) (condition #f) (logger #f)))))
 
+      (('record-process-exit-status pid status)
+       (loop (exit-statuses
+              (ring-buffer-insert (cons status (current-time))
+                                  exit-statuses))))
+
       ('record-respawn-time                       ;no reply
        (loop (respawns (cons (current-time) respawns))))
 
@@ -818,6 +836,12 @@ channel and wait for its reply."
   (compose ring-buffer->list
            (service-control-message 'status-changes)))
 
+(define service-process-exit-statuses
+  ;; Return the list of last exit statuses of @var{service}'s main process
+  ;; (most recent first).
+  (compose ring-buffer->list
+           (service-control-message 'exit-statuses)))
+
 (define service-enabled?
   ;; Return true if @var{service} is enabled, false otherwise.
   (service-control-message 'enabled?))
@@ -1159,6 +1183,7 @@ clients."
             (transient? ,(transient-service? service))
             (respawn-limit ,(service-respawn-limit service))
             (respawn-delay ,(service-respawn-delay service))
+            (exit-statuses ,(service-process-exit-statuses service))
             (recent-messages ,(service-recent-messages service))
             (log-file ,(service-log-file service))))
 
@@ -1947,13 +1972,15 @@ process is still running after @var{grace-period} 
seconds, send it
     ;; the process group ID is the PID of the process that "daemonized".  If
     ;; this procedure is called, between the process fork and exec, the PGID
     ;; will still be zero (the Shepherd PGID). In that case, use the PID.
-    (let ((pgid (getpgid pid)))
-      (if (= (getpgid 0) pgid)
-          (terminate-process pid signal           ;don't kill ourself
-                             #:grace-period grace-period)
-          (terminate-process (- pgid) signal
-                             #:grace-period grace-period)))
-    #f))
+    (let* ((pgid (getpgid pid))
+           (status (if (= (getpgid 0) pgid)
+                       (terminate-process pid signal ;don't kill ourself
+                                          #:grace-period grace-period)
+                       (terminate-process (- pgid) signal
+                                          #:grace-period grace-period))))
+      (put-message (service-control (current-service))
+                   `(record-process-exit-status ,pid ,status))
+      #f)))
 
 (define (spawn-shell-command command)
   "Spawn @var{command} (a string) using the shell.
diff --git a/tests/status-sexp.sh b/tests/status-sexp.sh
index 4fdc211..e095542 100644
--- a/tests/status-sexp.sh
+++ b/tests/status-sexp.sh
@@ -82,6 +82,7 @@ root_service_sexp="
       (transient? #f)
       (respawn-limit (5 . 7))
       (respawn-delay 0.1)
+      (exit-statuses ())
       (recent-messages ())
       (log-file #f))"
 
@@ -124,6 +125,7 @@ $define_reset_timestamps
                (status running)
                (one-shot? #f) (transient? #f)
                (respawn-limit (5 . 7)) (respawn-delay 1)
+               (exit-statuses ())
               (recent-messages ())
               (log-file #f))
              (service (version 0)
@@ -136,6 +138,7 @@ $define_reset_timestamps
                (status stopped)
                (one-shot? #f) (transient? #f)
                (respawn-limit (5 . 7)) (respawn-delay 1)
+               (exit-statuses ())
                (recent-messages ())
               (log-file #f)))))))
 "
@@ -166,6 +169,7 @@ $define_reset_timestamps
                (status running)
                (one-shot? #f) (transient? #f)
                (respawn-limit (5 . 7)) (respawn-delay 1)
+               (exit-statuses ())
               (recent-messages ())
               (log-file #f))))))
 "