[shepherd] 03/08: service: Turn 'action' method into a procedure.

[Ludovic Courtès]

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

commit a3c83a5cea8426ddfaf4635611a3cf1e4e85df8b
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Tue Apr 11 22:15:56 2023 +0200

    service: Turn 'action' method into a procedure.
    
    * modules/shepherd/service.scm (lookup-service): Make public.
    (action): Rename to...
    (perform-service-action): ... this.  Turn into a procedure.
    (issue-deprecation-warning): New procedure.
    (define-deprecated-method): Use it.
    (define-deprecated-method/rest): New macro.
    (action): Define as a deprecated method.
    * modules/shepherd/support.scm (make-bare-init-file): Suggest
    'perform-service-action', not 'action'.
    (Managing User Services): Likewise.
    * modules/shepherd.scm (process-command): Define 'service'.  Call
    'perform-service-action' instead of 'action'.
    * tests/basic.sh: Likewise.
    * doc/shepherd.texi (Methods of services): Adjust accordingly.
    (Service Convenience): Remove 'action'.
---
 doc/shepherd.texi            | 17 ++++-------
 modules/shepherd.scm         | 15 +++++++--
 modules/shepherd/service.scm | 72 +++++++++++++++++++++++++-------------------
 modules/shepherd/support.scm |  2 +-
 tests/basic.sh               |  2 +-
 5 files changed, 61 insertions(+), 47 deletions(-)

diff --git a/doc/shepherd.texi b/doc/shepherd.texi
index 62c123e..d05b773 100644
--- a/doc/shepherd.texi
+++ b/doc/shepherd.texi
@@ -754,11 +754,11 @@ succeed, though.  Otherwise, the behaviour is very 
similar to the
 value, thus @code{#f} if the service was stopped.
 @end deffn
 
-@deffn {method} action (obj <service>) the-action . args
-Calls the action @var{the-action} (a symbol) of the service @var{obj},
-with the specified @var{args}, which have a meaning depending on the
-particular action.
-@end deffn
+@defun perform-service-action @var{service} @var{the-action} . @var{args}
+Perform @var{the-action} (a symbol such as @code{'restart} or @code{'status})
+on @var{service}, passing it @var{args}.  The meaning of @var{args} depends on
+the action.
+@end defun
 
 @defun service-canonical-name @var{service}
 Return the @dfn{canonical name} of @var{service}, which is the first
@@ -842,11 +842,6 @@ interact right away with shepherd using the @command{herd} 
command.
 Stop a registered service providing @var{obj}.
 @end deffn
 
-@deffn {method} action (obj <symbol>) the-action . args
-The same as the @code{action} method of class @code{<service>}, but
-uses a service that provides @var{obj} and is running.
-@end deffn
-
 @deffn {procedure} for-each-service proc
 Call @var{proc}, a procedure taking one argument, once for each
 registered service.
@@ -1305,7 +1300,7 @@ load individual service definitions from
              ((ice-9 ftw) #:select (scandir)))
 
 ;; Send shepherd into the background
-(action 'shepherd 'daemonize)
+(perform-service-action 'shepherd 'daemonize)
 
 ;; Load all the files in the directory 'init.d' with a suffix '.scm'.
 (for-each
diff --git a/modules/shepherd.scm b/modules/shepherd.scm
index 7812177..76bf231 100644
--- a/modules/shepherd.scm
+++ b/modules/shepherd.scm
@@ -30,6 +30,7 @@
   #:use-module (srfi srfi-1)    ;; List library.
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
   #:use-module (shepherd config)
   #:use-module (shepherd support)
   #:use-module (shepherd service)
@@ -505,14 +506,22 @@ fork in the child process."
                                                   (get-messages))
                                    port)))
 
+             (define service
+               (or (lookup-service service-symbol)
+                   (raise (condition
+                           (&missing-service-error (name service-symbol))))))
+
              (define result
                (case the-action
                  ((start) (apply start service-symbol args))
                  ((stop) (apply stop service-symbol args))
 
-                 ;; Actions which have the semantics of `action' are
-                 ;; handled there.
-                 (else (apply action service-symbol the-action args))))
+                 ;; XXX: This used to return a list of action results, on the
+                 ;; grounds that there could be several services called NAME.
+                 ;; Clients like 'herd' expect a list so now we return a
+                 ;; singleton.
+                 (else (list (apply perform-service-action
+                                    service the-action args)))))
 
              (write-reply (command-reply command result #f (get-messages))
                           port))))
diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index 7fe1b5b..9ca96ba 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -67,6 +67,7 @@
             lookup-service-action
             service-defines-action?
             with-service-registry
+            lookup-service
             service-name-count
 
             action?
@@ -76,7 +77,7 @@
             start
             start-in-the-background
             stop
-            action
+            perform-service-action
 
             for-each-service
             respawn-service
@@ -152,6 +153,7 @@
             enabled?
             enable
             disable
+            action
             action-list
             lookup-action
             defines-action?
@@ -840,8 +842,10 @@ is not already running, and will return SERVICE's 
canonical name in a list."
 
         (cons name stopped-dependents))))
 
-;; Call action THE-ACTION with ARGS.
-(define-method (action (obj <service>) the-action . args)
+(define (perform-service-action service the-action . args)
+  "Perform @var{the-action} (a symbol such as @code{'restart} or 
@code{'status})
+on @var{service}, passing it @var{args}.  The meaning of @var{args} depends on
+the action."
   (define default-action
     ;; All actions which are handled here might be called even if the
     ;; service is not running, so they have to take this into account.
@@ -849,34 +853,34 @@ is not already running, and will return SERVICE's 
canonical name in a list."
       ;; Restarting is done in the obvious way.
       ((restart)
        (lambda (running . args)
-         (let ((stopped-services (stop obj)))
+         (let ((stopped-services (stop service)))
            (for-each start stopped-services)
            #t)))
       ((status)
        ;; Return the service itself.  It is automatically converted to an sexp
        ;; via 'result->sexp' and sent to the client.
-       (lambda (_) obj))
+       (lambda (_) service))
       ((enable)
        (lambda (_)
-         (enable-service obj)
+         (enable-service service)
          (local-output (l10n "Enabled service ~a.")
-                       (service-canonical-name obj))))
+                       (service-canonical-name service))))
       ((disable)
        (lambda (_)
-         (disable-service obj)
+         (disable-service service)
          (local-output (l10n "Disabled service ~a.")
-                       (service-canonical-name obj))))
+                       (service-canonical-name service))))
       ((doc)
        (lambda (_ . args)
-         (apply display-service-documentation obj args)))
+         (apply display-service-documentation service args)))
       (else
        (lambda _
          ;; FIXME: Unknown service.
          (raise (condition (&unknown-action-error
-                            (service obj)
+                            (service service)
                             (action the-action))))))))
 
-  (let ((proc (or (and=> (lookup-service-action obj the-action)
+  (let ((proc (or (and=> (lookup-service-action service the-action)
                          action-procedure)
                  default-action)))
     ;; Invoking THE-ACTION is allowed even when the service is not running, as
@@ -888,13 +892,13 @@ is not already running, and will return SERVICE's 
canonical name in a list."
         ;; single value.  Deal with it gracefully.
         (call-with-values
             (lambda ()
-              (apply proc (service-running-value obj) args))
+              (apply proc (service-running-value service) args))
           (case-lambda
             (() *unspecified*)
             ((first . rest) first))))
       (lambda (key . args)
         ;; Special case: 'root' may quit.
-        (and (eq? root-service obj)
+        (and (eq? root-service service)
              (eq? key 'quit)
              (apply quit args))
 
@@ -904,7 +908,7 @@ is not already running, and will return SERVICE's canonical 
name in a list."
               ((eq? key '%exception)              ;Guile 3.x
                (raise-exception (car args)))
               (else
-               (report-exception the-action obj key args)))))))
+               (report-exception the-action service key args)))))))
 
 ;; Display documentation about the service.
 (define (display-service-documentation service . args)
@@ -1142,18 +1146,6 @@ Used by `start'."
          '()
          (apply stop service args)))))
 
-(define-method (action (name <symbol>) the-action . args)
-  "Perform THE-ACTION on all the services named OBJ.  Return the list of
-results."
-  (match (lookup-service name)
-    (#f
-     (raise (condition (&missing-service-error (name name)))))
-    (service
-     ;; XXX: This used to return a list of action results, on the grounds that
-     ;; there could be several services called NAME.  Clients like 'herd'
-     ;; expect a list so now we return a singleton.
-     (list (apply action service the-action args)))))
-
 (define (start-in-the-background services)
   "Start the services named by @var{services}, a list of symbols, in the
 background.  In other words, this procedure returns immediately without
@@ -2490,14 +2482,22 @@ requested to be removed."
 ;;; Deprecated aliases.
 ;;;
 
+(define (issue-method-deprecation-warning name alias)
+  (issue-deprecation-warning
+   (format #f "GOOPS method '~a' is \
+deprecated in favor of procedure '~a'"
+           name alias)))
+
 (define-syntax-rule (define-deprecated-method (name (service class) formals 
...) alias)
   (define-method (name (service class) formals ...)
-    (issue-deprecation-warning
-     (format #f "GOOPS method '~a' is \
-deprecated in favor of procedure '~a'"
-             'name 'alias))
+    (issue-method-deprecation-warning 'name 'alias)
     (alias service formals ...)))
 
+(define-syntax-rule (define-deprecated-method/rest (name (service class)) 
alias)
+  (define-method (name (service class) . rest)
+    (issue-method-deprecation-warning 'name 'alias)
+    (apply alias service rest)))
+
 (define-syntax-rule (define-deprecated-service-getter name alias)
   (define-deprecated-method (name (service <service>)) alias))
 
@@ -2522,6 +2522,16 @@ deprecated in favor of procedure '~a'"
 (define-deprecated-method (defines-action? (service <service>) action)
   service-defines-action?)
 
+(define-deprecated-method/rest (action (service <service>))
+  perform-service-action)
+(define-method (action (name <symbol>) the-action . args)
+  "Perform THE-ACTION on all the services named OBJ.  Return the list of
+results."
+  (match (lookup-service name)
+    (#f
+     (raise (condition (&missing-service-error (name name)))))
+    (service
+     (list (apply action service the-action args)))))
 
 
 
diff --git a/modules/shepherd/support.scm b/modules/shepherd/support.scm
index 445ccbe..a298c36 100644
--- a/modules/shepherd/support.scm
+++ b/modules/shepherd/support.scm
@@ -335,7 +335,7 @@ TARGET should be a string representing a filepath + name."
         "(register-services)\n\n"
         (l10n "\
 ;; Send shepherd into the background\n")
-        "(action 'shepherd 'daemonize)\n\n"
+        "(perform-service-action 'shepherd 'daemonize)\n\n"
         (l10n "\
 ;; Services to start when shepherd starts:
 ;; Add the name of each service that should be started to the list
diff --git a/tests/basic.sh b/tests/basic.sh
index 181c81b..70b0677 100644
--- a/tests/basic.sh
+++ b/tests/basic.sh
@@ -222,7 +222,7 @@ $herd status test-loaded | grep -i "running.*#<unspecified>"
 $herd stop test-loaded
 
 # Deregister 'test-loaded' via 'eval'.
-$herd eval root "(action root-service 'unload \"test-loaded\")"
+$herd eval root "(perform-service-action root-service 'unload \"test-loaded\")"
 if $herd status test-loaded
 then false; else true; fi