[PATCH shepherd] service: Add custom printer for <service>.

[PATCH shepherd] service: Add custom printer for <service>.

[attila.lendvai]

From: Attila Lendvai <attila@lendvai.name>

* modules/shepherd/service.scm (print-service): New function.
---
 modules/shepherd/service.scm | 6 ++++++
 1 file changed, 6 insertions(+)

diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index 8c9d1c6..b018e39 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -34,6 +34,7 @@
   #:use-module (fibers timers)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module ((srfi srfi-35) #:hide (make-condition))
@@ -358,6 +359,11 @@ Log abnormal termination reported by @var{status}."
   ;; requests such as 'start' and 'stop' on this channel.
   (control   %service-control set-service-control!))
 
+(define (print-service service port)
+  (format port "#<service ~s>" (service-canonical-name service)))
+
+(set-record-type-printer! <service> print-service)
+
 (define* (service provision
                   #:key
                   (requirement '())

base-commit: 9f2d5ea865a7a769fe2c7ef5cd13ff84cf277ec5
-- 
2.45.2

[PATCH shepherd] service: Rename to QUERY-SERVICE-CONTROLLER and use CUT.

[attila.lendvai]

From: Attila Lendvai <attila@lendvai.name>

* modules/shepherd/service.scm (query-service-controller): New function based
on the previous SERVICE-CONTROL-MESSAGE.  Use CUT instead of the now deleted
SERVICE-CONTROL-MESSAGE.
(service-control-message): Deleted.
---
 modules/shepherd/service.scm | 31 +++++++++++++++----------------
 1 file changed, 15 insertions(+), 16 deletions(-)

diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index b018e39..d9dc0d5 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -776,55 +776,54 @@ wire."
   "Return the \"canonical\" name of @var{service}."
   (car (service-provision service)))
 
-(define (service-control-message message)
-  "Return a procedure to send @var{message} to the given service's control
-channel and wait for its reply."
-  (lambda (service)
-    (let ((reply (make-channel)))
-      (put-message (service-control service) (list message reply))
-      (get-message reply))))
+(define (query-service-controller service message)
+  "Send @var{message} to the service's control channel of @var{message} and
+wait for its reply."
+  (let ((reply (make-channel)))
+    (put-message (service-control service) (list message reply))
+    (get-message reply)))
 
 (define service-running-value
   ;; Return the "running value" of @var{service}.
-  (service-control-message 'running))
+  (cut query-service-controller <> 'running))
 
 (define service-status
   ;; Return the status of @var{service}, one of @code{stopped},
   ;; @code{starting}, @code{running}, or @code{stopping}.
-  (service-control-message 'status))
+  (cut query-service-controller <> 'status))
 
 (define service-respawn-times
   ;; Return the list of respawn times of @var{service}.
-  (service-control-message 'respawn-times))
+  (cut query-service-controller <> 'respawn-times))
 
 (define service-startup-failures
   ;; Return the list of recent startup failure times for @var{service}.
   (compose ring-buffer->list
-           (service-control-message 'startup-failures)))
+           (cut query-service-controller <> 'startup-failures)))
 
 (define service-status-changes
   ;; Return the list of symbol/timestamp pairs representing recent state
   ;; changes for @var{service}.
   (compose ring-buffer->list
-           (service-control-message 'status-changes)))
+           (cut query-service-controller <> '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)))
+           (cut query-service-controller <> 'exit-statuses)))
 
 (define service-enabled?
   ;; Return true if @var{service} is enabled, false otherwise.
-  (service-control-message 'enabled?))
+  (cut query-service-controller <> 'enabled?))
 
 (define service-replacement
   ;; Return the replacement of @var{service}, #f if there is none.
-  (service-control-message 'replacement))
+  (cut query-service-controller <> 'replacement))
 
 (define service-logger
   ;; Return the logger of @var{service}, #f if there is none.
-  (service-control-message 'logger))
+  (cut query-service-controller <> 'logger))
 
 (define (service-recent-messages service)
   "Return the list of recent messages logged for @var{service}."
-- 
2.45.2

[PATCH shepherd] service: Factor out SEND-TO-PROCESS-MONITOR.

[attila.lendvai]

From: Attila Lendvai <attila@lendvai.name>

Assert that (CURRENT-PROCESS-MONITOR) is valid.

* modules/shepherd/service.scm (send-to-process-monitor): New function.
(handle-SIGCHLD), (process-monitor), (monitor-service-process),
(terminate-process): Use it.
---
 modules/shepherd/service.scm | 16 ++++++++--------
 1 file changed, 8 insertions(+), 8 deletions(-)

diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index d9dc0d5..e1c602c 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -2351,8 +2351,7 @@ otherwise by updating its state."
        #t)
       ((pid . status)
        ;; Let the process monitor handle it.
-       (put-message (current-process-monitor)
-                    `(handle-process-termination ,pid ,status))
+       (send-to-process-monitor `(handle-process-termination ,pid ,status))
 
        ;; As noted in libc's manual (info "(libc) Process Completion"),
        ;; loop so we don't miss any terminated child process.
@@ -2488,10 +2487,13 @@ which its completion status will be sent."
     (values (unboxed-errors (get-message reply))
             reply)))
 
+(define (send-to-process-monitor message)
+  (assert (current-process-monitor))
+  (put-message (current-process-monitor) message))
+
 (define (spawn-via-monitor arguments)
   (let ((reply (make-channel)))
-    (put-message (current-process-monitor)
-                 `(spawn ,arguments ,(current-service) ,reply))
+    (send-to-process-monitor `(spawn ,arguments ,(current-service) ,reply))
     (unboxed-errors (get-message reply))
     (get-message reply)))
 
@@ -2539,8 +2541,7 @@ while waiting for @var{program} to terminate."
   "Monitor process @var{pid} and notify @var{service} when it terminates."
   (assert (current-process-monitor))
   (let ((reply (make-channel)))
-    (put-message (current-process-monitor)
-                 `(await ,pid ,reply))
+    (send-to-process-monitor `(await ,pid ,reply))
     (spawn-fiber
      (lambda ()
        (let ((status (get-message reply)))
@@ -2583,7 +2584,7 @@ group; wait for @var{pid} to terminate and return its exit status.  If
 @var{pid} is still running @var{grace-period} seconds after @var{signal} has
 been sent, send it @code{SIGKILL}."
   (let ((reply (make-channel)))
-    (put-message (current-process-monitor) `(await ,(abs pid) ,reply))
+    (send-to-process-monitor `(await ,(abs pid) ,reply))
     (catch-system-error (kill pid signal))
 
     (match (get-message* reply grace-period #f)
@@ -2904,4 +2905,3 @@ we want to receive these signals."
       "This does not work for the 'root' service."
       (lambda (running)
 	(local-output (l10n "You must be kidding.")))))))
-
-- 
2.45.2

[PATCH shepherd] service: Factor out SEND-TO-REGISTRY.

[attila.lendvai]

From: Attila Lendvai <attila@lendvai.name>

Also assert that (CURRENT-REGISTRY-CHANNEL) is valid.

* modules/shepherd/service.scm (with-service-registry): New function.
(stop-service), (fold-services), (service-name-count), (lookup-service),
(respawn-service), (register-services), (unregister-services): Use it.
---
 modules/shepherd/service.scm | 22 +++++++++++-----------
 1 file changed, 11 insertions(+), 11 deletions(-)

diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index e1c602c..b5f3e23 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -1030,8 +1030,7 @@ in a list."
                  (report-exception 'stop service key args))))))
 
         (when (transient-service? service)
-          (put-message (current-registry-channel)
-                       `(unregister ,(list service)))
+          (send-to-registry `(unregister ,(list service)))
           (local-output (l10n "Transient service ~a unregistered.")
                         (service-canonical-name service)))
 
@@ -1290,6 +1289,10 @@ task is one that should never fail)."
   (parameterize ((current-registry-channel (spawn-service-registry)))
     (thunk)))
 
+(define (send-to-registry message)
+  (assert (current-registry-channel))
+  (put-message (current-registry-channel) message))
+
 (define-syntax-rule (with-service-registry exp ...)
   "Spawn a new service monitor and evaluate @var{exp}... within that dynamic extent.
 This allows @var{exp}... and their callees to send requests to delegate
@@ -2286,8 +2289,7 @@ This must be paired with @code{make-systemd-destructor}."
     (lambda (proc init)
       "Apply PROC to the registered services to build a result, and return that
 result.  Works in a manner akin to `fold' from SRFI-1."
-      (put-message (current-registry-channel)
-                   `(service-list ,reply))
+      (send-to-registry `(service-list ,reply))
       (fold (match-lambda*
               (((name . service) result)
                (if (eq? name (service-canonical-name service))
@@ -2311,15 +2313,14 @@ returned in unspecified."
 (define (service-name-count)
   "Return the number of currently-registered service names."
   (let ((reply (make-channel)))
-    (put-message (current-registry-channel)
-                 `(service-name-count ,reply))
+    (send-to-registry `(service-name-count ,reply))
     (get-message reply)))
 
 (define lookup-service
   (let ((reply (make-channel)))
     (lambda (name)
       "Return the service that provides @var{name}, @code{#f} if there is none."
-      (put-message (current-registry-channel) `(lookup ,name ,reply))
+      (send-to-registry `(lookup ,name ,reply))
       (get-message reply))))
 
 (define (lookup-services name)
@@ -2631,7 +2632,7 @@ then disable it."
         (disable-service serv)
 
         (when (transient-service? serv)
-          (put-message (current-registry-channel) `(unregister (,serv)))
+          (send-to-registry `(unregister (,serv)))
           (local-output (l10n "Transient service ~a terminated, now unregistered.")
                         (service-canonical-name serv))))))
 
@@ -2657,7 +2658,7 @@ If it is currently stopped, replace it immediately."
         (assert (list-of-symbols? (service-requirement new)))
         (assert (boolean? (respawn-service? new)))
 
-        (put-message (current-registry-channel) `(register ,new)))
+        (send-to-registry `(register ,new)))
 
       (let ((services (if (service? services)
                           (begin
@@ -2681,8 +2682,7 @@ already stopped."
                 services))
 
   ;; Remove STOPPED from the registry.
-  (put-message (current-registry-channel)
-               `(unregister ,stopped))
+  (send-to-registry `(unregister ,stopped))
   #t)
 
 (define (deregister-service service-name)
-- 
2.45.2

[PATCH shepherd] service: Factor out SEND-TO-SERVICE-CONTROLLER.

[attila.lendvai]

From: Attila Lendvai <attila@lendvai.name>

* modules/shepherd/service.scm (service-running-value): New function.
(query-service-controller), (enable-service), (disable-service),
(record-service-respawn-time), (start-service), (stop-service),
(service-registry), (handle-service-termination): Use it.
---
 modules/shepherd/service.scm | 24 +++++++++++++-----------
 1 file changed, 13 insertions(+), 11 deletions(-)

diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index b5f3e23..ae9fbed 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -776,11 +776,15 @@ wire."
   "Return the \"canonical\" name of @var{service}."
   (car (service-provision service)))
 
+(define (send-to-service-controller service message)
+  "Send @var{message} to the service's control channel of @var{message}."
+  (put-message (service-control service) message))
+
 (define (query-service-controller service message)
   "Send @var{message} to the service's control channel of @var{message} and
 wait for its reply."
   (let ((reply (make-channel)))
-    (put-message (service-control service) (list message reply))
+    (send-to-service-controller service (list message reply))
     (get-message reply)))
 
 (define service-running-value
@@ -836,11 +840,11 @@ wait for its reply."
 
 (define (enable-service service)
   "Enable @var{service}."
-  (put-message (service-control service) 'enable))
+  (send-to-service-controller service 'enable))
 
 (define (disable-service service)
   "Disable @var{service}."
-  (put-message (service-control service) 'disable))
+  (send-to-service-controller service 'disable))
 
 (define (register-service-logger service logger)
   "Register @var{logger}, a value as returned by
@@ -850,7 +854,7 @@ wait for its reply."
 
 (define (record-service-respawn-time service)
   "Record the current time as the last respawn time for @var{service}."
-  (put-message (service-control service) 'record-respawn-time))
+  (send-to-service-controller service 'record-respawn-time))
 
 (define (service-running? service)
   "Return true if @var{service} is not stopped."
@@ -949,7 +953,7 @@ found in the service registry."
           #f)
         ;; Start the service itself.
         (let ((reply (make-channel)))
-          (put-message (service-control service) `(start ,reply))
+          (send-to-service-controller service `(start ,reply))
           (match (get-message reply)
             (#f
              ;; We lost the race: SERVICE is already running.
@@ -1008,7 +1012,7 @@ in a list."
                             '())))
         ;; Stop the service itself.
         (let ((reply (make-channel)))
-          (put-message (service-control service) `(stop ,reply))
+          (send-to-service-controller service `(stop ,reply))
           (match (get-message reply)
             (#f
              #f)
@@ -1184,7 +1188,7 @@ requests arriving on @var{channel}."
       ;; Terminate the controller of each of SERVICES and return REGISTERED
       ;; minus SERVICES.
       (for-each (lambda (service)
-                  (put-message (service-control service) 'terminate))
+                  (send-to-service-controller service 'terminate))
                 services)
       (vhash-fold (lambda (name service result)
                     (if (memq service services)
@@ -1211,8 +1215,7 @@ requests arriving on @var{channel}."
           (loop (register service)))
          ((_ . old)
           (let ((reply (make-channel)))
-            (put-message (service-control old)
-                         `(replace-if-running ,service ,reply))
+            (send-to-service-controller old `(replace-if-running ,service ,reply))
             (match (get-message reply)
               (#t (loop registered))
               (#f
@@ -2603,8 +2606,7 @@ been sent, send it @code{SIGKILL}."
 @var{service}; @var{status} is the process's exit status as returned by
 @code{waitpid}.  This procedure is called right after the process has
 terminated."
-  (put-message (service-control service)
-               `(handle-termination ,pid ,status)))
+  (send-to-service-controller service `(handle-termination ,pid ,status)))
 
 (define (respawn-service serv)
   "Respawn a service that has stopped running unexpectedly. If we have
-- 
2.45.2