[bug#32128] [PATCH 0/2] Support custom actions for Shepherd services

[bug#32128] [PATCH 0/2] Support custom actions for Shepherd services

[Ludovic Courtès]

Hello Guix!

This is a long-awaited feature—nothing fancy, but it can certainly be
useful as illustrated by the ‘herd schedule mcron’ example below.

I suppose we can add actions for hot-swapping and reconfiguration of
services that support it, such as nginx: <https://bugs.gnu.org/26830>.

Feedback welcome!

Ludo’.

Ludovic Courtès (2):
  services: shepherd: Support custom actions.
  services: mcron: Add 'schedule' action.

 doc/guix.texi             | 74 +++++++++++++++++++++++++++++++++++++++
 gnu/services/herd.scm     |  3 ++
 gnu/services/mcron.scm    | 67 ++++++++++++++++++++++++++---------
 gnu/services/shepherd.scm | 23 +++++++++++-
 gnu/tests/base.scm        |  7 ++++
 5 files changed, 156 insertions(+), 18 deletions(-)

-- 
2.18.0

[bug#32128] [PATCH 1/2] services: shepherd: Support custom actions.

[Ludovic Courtès]

* gnu/services/shepherd.scm (<shepherd-service>)[actions]: New field.
(<shepherd-action>): New record type.
(shepherd-service-file): Pass #:actions to 'make'.
* doc/guix.texi (Shepherd Services): Document custom actions.
---
 doc/guix.texi             | 59 +++++++++++++++++++++++++++++++++++++++
 gnu/services/shepherd.scm | 23 ++++++++++++++-
 2 files changed, 81 insertions(+), 1 deletion(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 8026bea35..0a6b2244d 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -21963,6 +21963,17 @@ Constructors,,, shepherd, The GNU Shepherd Manual}).  They are given as
 G-expressions that get expanded in the Shepherd configuration file
 (@pxref{G-Expressions}).
 
+@item @code{actions} (default: @code{'()})
+@cindex actions, of Shepherd services
+This is a list of @code{shepherd-action} objects (see below) defining
+@dfn{actions} supported by the service, in addition to the standard
+@code{start} and @code{stop} actions.  Actions listed here become available as
+@command{herd} sub-commands:
+
+@example
+herd @var{action} @var{service} [@var{arguments}@dots{}]
+@end example
+
 @item @code{documentation}
 A documentation string, as shown when running:
 
@@ -21980,6 +21991,54 @@ This is the list of modules that must be in scope when @code{start} and
 @end table
 @end deftp
 
+@deftp {Data Type} shepherd-action
+This is the data type that defines additional actions implemented by a
+Shepherd service (see above).
+
+@table @code
+@item name
+Symbol naming the action.
+
+@item documentation
+This is a documentation string for the action.  It can be viewed by running:
+
+@example
+herd doc @var{service} action @var{action}
+@end example
+
+@item procedure
+This should be a gexp that evaluates to a procedure of at least one argument,
+which is the ``running value'' of the service (@pxref{Slots of services,,,
+shepherd, The GNU Shepherd Manual}).
+@end table
+
+The following example defines an action called @code{say-hello} that kindly
+greets the user:
+
+@example
+(shepherd-action
+  (name 'say-hello)
+  (documentation "Say hi!")
+  (procedure #~(lambda (running . args)
+                 (format #t "Hello, friend! arguments: ~s\n"
+                         args)
+                 #t)))
+@end example
+
+Assuming this action is added to the @code{example} service, then you can do:
+
+@example
+# herd say-hello example
+Hello, friend! arguments: ()
+# herd say-hello example a b c
+Hello, friend! arguments: ("a" "b" "c")
+@end example
+
+This, as you can see, is a fairly sophisticated way to say hello.
+@xref{Service Convenience,,, shepherd, The GNU Shepherd Manual}, for more
+info on actions.
+@end deftp
+
 @defvr {Scheme Variable} shepherd-root-service-type
 The service type for the Shepherd ``root service''---i.e., PID@tie{}1.
 
diff --git a/gnu/services/shepherd.scm b/gnu/services/shepherd.scm
index 6ca53faa3..4cd224984 100644
--- a/gnu/services/shepherd.scm
+++ b/gnu/services/shepherd.scm
@@ -49,6 +49,12 @@
             shepherd-service-auto-start?
             shepherd-service-modules
 
+            shepherd-action
+            shepherd-action?
+            shepherd-action-name
+            shepherd-action-documentation
+            shepherd-action-procedure
+
             %default-modules
 
             shepherd-service-file
@@ -146,11 +152,20 @@ DEFAULT is given, use it as the service's default value."
   (start         shepherd-service-start)               ;g-expression (procedure)
   (stop          shepherd-service-stop                 ;g-expression (procedure)
                  (default #~(const #f)))
+  (actions       shepherd-service-actions              ;list of <shepherd-action>
+                 (default '()))
   (auto-start?   shepherd-service-auto-start?          ;Boolean
                  (default #t))
   (modules       shepherd-service-modules              ;list of module names
                  (default %default-modules)))
 
+(define-record-type* <shepherd-action>
+  shepherd-action make-shepherd-action
+  shepherd-action?
+  (name          shepherd-action-name)            ;symbol
+  (procedure     shepherd-action-procedure)       ;gexp
+  (documentation shepherd-action-documentation))  ;string
+
 (define (shepherd-service-canonical-name service)
   "Return the 'canonical name' of SERVICE."
   (first (shepherd-service-provision service)))
@@ -223,7 +238,13 @@ stored."
                        #:requires '#$(shepherd-service-requirement service)
                        #:respawn? '#$(shepherd-service-respawn? service)
                        #:start #$(shepherd-service-start service)
-                       #:stop #$(shepherd-service-stop service))))))
+                       #:stop #$(shepherd-service-stop service)
+                       #:actions
+                       (make-actions
+                        #$@(map (match-lambda
+                                  (($ <shepherd-action> name proc doc)
+                                   #~(#$name #$doc #$proc)))
+                                (shepherd-service-actions service))))))))
 
 (define (shepherd-configuration-file services)
   "Return the shepherd configuration file for SERVICES."
-- 
2.18.0

[bug#32128] [PATCH 2/2] services: mcron: Add 'schedule' action.

[Ludovic Courtès]

Inspired by
<https://lists.gnu.org/archive/html/help-guix/2018-07/msg00035.html>.

* gnu/services/mcron.scm (shepherd-schedule-action): New procedure.
(mcron-shepherd-services): Add 'actions' field.
* gnu/tests/base.scm (run-mcron-test)["schedule action"]: New test.
* doc/guix.texi (Scheduled Job Execution): Mention 'herd schedule'.
---
 doc/guix.texi          | 15 ++++++++++
 gnu/services/herd.scm  |  3 ++
 gnu/services/mcron.scm | 67 +++++++++++++++++++++++++++++++-----------
 gnu/tests/base.scm     |  7 +++++
 4 files changed, 75 insertions(+), 17 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 0a6b2244d..8f72ab2b8 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -10844,6 +10844,21 @@ gexps to introduce job definitions that are passed to mcron
 for more information on mcron job specifications.  Below is the
 reference of the mcron service.
 
+On a running system, you can use the @code{schedule} action of the service to
+visualize the mcron jobs that will be executed next:
+
+@example
+# herd schedule mcron
+@end example
+
+@noindent
+The example above lists the next five tasks that will be executed, but you can
+also specify the number of tasks to display:
+
+@example
+# herd schedule mcron 10
+@end example
+
 @deffn {Scheme Procedure} mcron-service @var{jobs} [#:mcron @var{mcron}]
 Return an mcron service running @var{mcron} that schedules @var{jobs}, a
 list of gexps denoting mcron job specifications.
diff --git a/gnu/services/herd.scm b/gnu/services/herd.scm
index d882c232c..8c96b7073 100644
--- a/gnu/services/herd.scm
+++ b/gnu/services/herd.scm
@@ -45,6 +45,7 @@
             live-service-requirement
             live-service-running
 
+            with-shepherd-action
             current-services
             unload-services
             unload-service
@@ -168,6 +169,8 @@ return #f."
 
 (define-syntax-rule (with-shepherd-action service (action args ...)
                       result body ...)
+  "Invoke ACTION on SERVICE with the given ARGS, and evaluate BODY with RESULT
+bound to the action's result."
   (invoke-action service action (list args ...)
                  (lambda (result) body ...)))
 
diff --git a/gnu/services/mcron.scm b/gnu/services/mcron.scm
index 5bee02a58..759d9c8b3 100644
--- a/gnu/services/mcron.scm
+++ b/gnu/services/mcron.scm
@@ -60,29 +60,62 @@
 (define (job-file job)
   (scheme-file "mcron-job" job))
 
+(define (shepherd-schedule-action mcron files)
+  "Return a Shepherd action that runs MCRON with '--schedule' for the given
+files."
+  (shepherd-action
+   (name 'schedule)
+   (documentation
+    "Display jobs that are going to be scheduled.")
+   (procedure
+    #~(lambda* (_ #:optional (n "5"))
+        ;; XXX: This is a global side effect.
+        (setenv "GUILE_AUTO_COMPILE" "0")
+
+        ;; Run 'mcron' in a pipe so we can explicitly redirect its output to
+        ;; 'current-output-port', which at this stage is bound to the client
+        ;; connection.
+        (let ((pipe (open-pipe* OPEN_READ
+                                #$(file-append mcron "/bin/mcron")
+                                (string-append "--schedule=" n)
+                                #$@files)))
+          (let loop ()
+            (match (read-line pipe 'concat)
+              ((? eof-object?)
+               (zero? (close-pipe pipe)))
+              (line
+               (display line)
+               (loop)))))))))
+
 (define mcron-shepherd-services
   (match-lambda
     (($ <mcron-configuration> mcron ())           ;nothing to do!
      '())
     (($ <mcron-configuration> mcron jobs)
-     (list (shepherd-service
-            (provision '(mcron))
-            (requirement '(user-processes))
-            (modules `((srfi srfi-1)
-                       (srfi srfi-26)
-                       ,@%default-modules))
-            (start #~(make-forkexec-constructor
-                      (list (string-append #$mcron "/bin/mcron")
-                            #$@(map job-file jobs))
+     (let ((files (map job-file jobs)))
+       (list (shepherd-service
+              (provision '(mcron))
+              (requirement '(user-processes))
+              (modules `((srfi srfi-1)
+                         (srfi srfi-26)
+                         (ice-9 popen)            ;for the 'schedule' action
+                         (ice-9 rdelim)
+                         (ice-9 match)
+                         ,@%default-modules))
+              (start #~(make-forkexec-constructor
+                        (list (string-append #$mcron "/bin/mcron") #$@files)
 
-                      ;; Disable auto-compilation of the job files and set a
-                      ;; sane value for 'PATH'.
-                      #:environment-variables
-                      (cons* "GUILE_AUTO_COMPILE=0"
-                             "PATH=/run/current-system/profile/bin"
-                             (remove (cut string-prefix? "PATH=" <>)
-                                     (environ)))))
-            (stop #~(make-kill-destructor)))))))
+                        ;; Disable auto-compilation of the job files and set a
+                        ;; sane value for 'PATH'.
+                        #:environment-variables
+                        (cons* "GUILE_AUTO_COMPILE=0"
+                               "PATH=/run/current-system/profile/bin"
+                               (remove (cut string-prefix? "PATH=" <>)
+                                       (environ)))))
+              (stop #~(make-kill-destructor))
+
+              (actions
+               (list (shepherd-schedule-action mcron files)))))))))
 
 (define mcron-service-type
   (service-type (name 'mcron)
diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm
index 0efb4a6e5..f27064af8 100644
--- a/gnu/tests/base.scm
+++ b/gnu/tests/base.scm
@@ -632,6 +632,13 @@ non-ASCII names from /tmp.")
             (wait-for-file "/root/witness-touch" marionette
                            #:read '(@ (ice-9 rdelim) read-string)))
 
+          ;; Make sure the 'schedule' action is accepted.
+          (test-equal "schedule action"
+            '(#t)                                 ;one value, #t
+            (marionette-eval '(with-shepherd-action 'mcron ('schedule) result
+                                result)
+                             marionette))
+
           (test-end)
           (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
 
-- 
2.18.0

[bug#32128] [PATCH 0/2] Support custom actions for Shepherd services

[Clément Lassieur]

Hi Ludo,

Ludovic Courtès <ludo@gnu.org> writes:

> Hello Guix!
>
> This is a long-awaited feature—nothing fancy, but it can certainly be
> useful as illustrated by the ‘herd schedule mcron’ example below.
>
> I suppose we can add actions for hot-swapping and reconfiguration of
> services that support it, such as nginx: <https://bugs.gnu.org/26830>.

This is fantastic!  Thank you :-)  And it looks good to me.

A few notes though (more about the Shepherd):

- It would be great to be able to use actions even when services are not
  started.  In the case of the "mcron" service, for example, it makes
  sense: one may not want to risk spawning a program while wanting to
  debug the schedule.

- It seems that sometimes the SIGCHLD handler is invoked, when the
  'running' field is not yet set.  Should CALL-WITH-BLOCKED-ASYNCS be
  used?
  
Clément

bug#32128: [PATCH 0/2] Support custom actions for Shepherd services

[Ludovic Courtès]

Hello Clément,

Clément Lassieur <clement@lassieur.org> skribis:

> Ludovic Courtès <ludo@gnu.org> writes:
>
>> Hello Guix!
>>
>> This is a long-awaited feature—nothing fancy, but it can certainly be
>> useful as illustrated by the ‘herd schedule mcron’ example below.
>>
>> I suppose we can add actions for hot-swapping and reconfiguration of
>> services that support it, such as nginx: <https://bugs.gnu.org/26830>.
>
> This is fantastic!  Thank you :-)  And it looks good to me.

Thanks!  I’ve pushed it.

> A few notes though (more about the Shepherd):
>
> - It would be great to be able to use actions even when services are not
>   started.  In the case of the "mcron" service, for example, it makes
>   sense: one may not want to risk spawning a program while wanting to
>   debug the schedule.

Indeed, I think this restriction should be waived, and this comment from
ca. 2003 in shepherd/service.scm suggests it’s unfounded:

    ;; Calling default-action will be allowed even when the service is
    ;; not running, as it provides generally useful functionality and
    ;; information.
    ;; FIXME: Why should the user-implementations not be allowed to be
    ;; called this way?

Done in Shepherd commit 5ab8cbc9bcfce586a5389ad95a65f011d02bd289.

> - It seems that sometimes the SIGCHLD handler is invoked, when the
>   'running' field is not yet set.  Should CALL-WITH-BLOCKED-ASYNCS be
>   used?

As discussed on IRC, the error we were getting when doing things like
“herd schedule mcron 50” (“waitpid: No child processes”), came from the
fact that ‘close-pipe’ invokes ‘waitpid’, but there’s a race with the
Shepherd’s SIGCHLD handler, which might get to call ‘waitpid’ earlier.

I’ve adjusted to code to protect against it but without blocking asyncs,
which seems safer.

Thank you!

Ludo’.