civodul pushed a commit to branch devel
in repository shepherd.
commit 8ad7997fb92276aecab6b667d9e3aadfe44561d3
Author: Ludovic Courtès <[email protected]>
AuthorDate: Sat Oct 12 11:28:10 2024 +0200
timer: Add ‘timer’ service with ‘schedule’ action.
* modules/shepherd/service/timer.scm (invalid-argument)
(string->calendar-event, timer-arguments->calendar-event+command)
(schedule-timer, timer-service): New procedures.
* tests/services/timer-at.sh: New file.
* Makefile.am (TESTS): Add it.
* tests/services/timer-events.scm ("timer-arguments->calendar-event,
simple")
("timer-arguments->calendar-event, \"as\"")
("timer-arguments->calendar-event, wrong-type-arg"): New tests.
* doc/shepherd.texi (Timers): Document it.
---
Makefile.am | 1 +
doc/shepherd.texi | 41 +++++++++++++-
modules/shepherd/service/timer.scm | 113 ++++++++++++++++++++++++++++++++++++-
tests/services/timer-at.sh | 65 +++++++++++++++++++++
tests/services/timer-events.scm | 34 +++++++++++
5 files changed, 252 insertions(+), 2 deletions(-)
diff --git a/Makefile.am b/Makefile.am
index 2d8e70b..d530dc6 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -287,6 +287,7 @@ TESTS = \
tests/services/monitoring.sh \
tests/services/repl.sh \
tests/services/timer.sh \
+ tests/services/timer-at.sh \
tests/services/timer-events.scm \
tests/services/log-rotation.sh \
tests/services/log-rotation-internal.scm \
diff --git a/doc/shepherd.texi b/doc/shepherd.texi
index 8857627..1b4f995 100644
--- a/doc/shepherd.texi
+++ b/doc/shepherd.texi
@@ -1570,7 +1570,7 @@ These arguments are the same as for
@code{fork+exec-command} and related
procedures (@pxref{exec-command, @code{fork+exec-command}}).
@end deffn
-Last, it's also possible to add a @code{trigger} action to timer
+It's also possible to add a @code{trigger} action to timer
services, such that one can trigger it with:
@example
@@ -1587,6 +1587,45 @@ to invoke the action passed to
@code{make-timer-constructor}.
@xref{timer-example, timer example}, to see how to put it all together.
+@cindex timer service, like @command{at}
+@cindex @command{at} command, with timer service
+Last, the @code{(shepherd service timer)} provides a sort of ``meta''
+timer service that lets you dynamically create timed services, from the
+command line, in a way similar to the traditional @command{at} command:
+
+@example
+# Run the 'mail' command, as root, as 12PM.
+herd schedule timer at 12:00 -- \
+ mail --to=charlie -s "Lunch time!"
+
+# Run the 'mpg123' command as user 'charlie' at 7AM, from charlie's
+# home directory.
+herd schedule timer at 07:00 as charlie -- \
+ mpg123 Music/alarm.mp3
+@end example
+
+Each of these @command{herd schedule timer} commands creates a new timed
+service, which, like any other service, can be inspected and stopped;
+those services are transient and vanish after they have executed their
+command (@pxref{Defining Services}).
+
+This @code{timer} service can be added to your configuration like so:
+
+@lisp
+(use-modules (shepherd service timer))
+
+(register-services (list (timer-service)))
+@end lisp
+
+The reference follows.
+
+@deffn {Procedure} timer-service [@var{provision}] @
+ [#:requirement '()]
+Return a timer service with the given @var{provision} and
+@var{requirement}. The service has a @code{schedule} action that lets users
+schedule command execution similar to the venerable @command{at} command.
+@end deffn
+
@c @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
@node The root Service
diff --git a/modules/shepherd/service/timer.scm
b/modules/shepherd/service/timer.scm
index 1c3ad85..0e10d40 100644
--- a/modules/shepherd/service/timer.scm
+++ b/modules/shepherd/service/timer.scm
@@ -58,7 +58,10 @@
make-timer-destructor
trigger-timer
- timer-trigger-action))
+ timer-trigger-action
+
+ timer-arguments->calendar-event+command
+ timer-service))
;;; Commentary:
;;;
@@ -804,3 +807,111 @@ doing nothing."))))
(define timer-trigger-action
(action 'trigger trigger-timer
"Trigger the action associated with this timer."))
+
+
+;;;
+;;; 'at'-like timer.
+;;;
+
+(define (invalid-argument message . args)
+ "Raise an exception with the given @var{message} and format @var{args} using
+a good old key/arguments exception, such that the message is properly
+serialized as an action exception returned to the client, which, in turn, can
+display it correctly."
+ (apply throw 'wrong-type-arg #f message args '()))
+
+(define (string->calendar-event str)
+ "Parse @var{str}, a string such as @code{\"17:14\"}, and return the
+corresponding calendar event."
+ (define (hour? obj)
+ (and (integer? obj) (exact? obj)
+ (>= obj 0) (< obj 24)))
+ (define (minute? obj)
+ (and (integer? obj) (exact? obj)
+ (>= obj 0) (< obj 60)))
+ (define second? minute?)
+
+ (match (string-split str #\:)
+ (((= string->number (? hour? hour))
+ (= string->number (? minute? minute)))
+ (calendar-event #:seconds '(0)
+ #:minutes (list minute)
+ #:hours (list hour)))
+ (((= string->number (? hour? hour))
+ (= string->number (? minute? minute))
+ (= string->number (? second? second)))
+ (calendar-event #:seconds (list second)
+ #:minutes (list minute)
+ #:hours (list hour)))
+ (_
+ (invalid-argument (l10n "~a: invalid calendar time specification")
+ str))))
+
+(define (timer-arguments->calendar-event+command spec)
+ "Parse @var{spec}, a list of arguments passed to the @code{schedule} timer
+action, and return two values: a calendar event and a command to run on the
+first occurrence of that event. Raise an error if @var{spec} is invalid."
+ (define user-group
+ (compose group:name getgrnam passwd:gid getpwnam))
+
+ (define user-home
+ (compose passwd:dir getpwnam))
+
+ (let loop ((spec spec)
+ (event #f)
+ (user #f)
+ (arguments '()))
+ (match spec
+ (()
+ (unless event
+ (invalid-argument (l10n "Timer spec lacks 'at TIME'.")))
+ (unless (pair? arguments)
+ (invalid-argument (l10n "Timer spec lacks a command to run.")))
+ (values event
+ (command arguments
+ #:user user
+ #:group (and=> user user-group)
+ #:directory
+ (or (and=> user user-home)
+ (default-service-directory)))))
+ (("at" time-spec rest ...)
+ (loop rest (string->calendar-event time-spec) user arguments))
+ (("as" user rest ...)
+ (loop rest event user arguments))
+ ((lst ...)
+ (if event
+ (loop '() event user lst)
+ (invalid-argument (l10n "Timer spec lacks 'at TIME'.")))))))
+
+(define* (schedule-timer spec #:key (requirement '()))
+ "Schedule a timer according to @var{spec}, a list of strings such as
+@code{'(\"at\" \"12:00\" \"xlock\")}. The resulting timer is a registered as
+a transient timed service and started. Raise an error if @var{spec} is
+invalid."
+ (let* ((event command (timer-arguments->calendar-event+command spec))
+ (timer (service (list (gensym "timer-"))
+ #:requirement requirement
+ #:transient? #t
+ #:start (make-timer-constructor
+ event command
+ #:occurrences 1)
+ #:stop (make-timer-destructor)
+ #:actions (list timer-trigger-action))))
+ (register-services (list timer))
+ (start-service timer)))
+
+(define* (timer-service #:optional (provision '(timer))
+ #:key (requirement '()))
+ "Return a timer service with the given @var{provision} and
+@var{requirement}. The service has a @code{schedule} action that lets users
+schedule command execution similar to the venerable @command{at} command."
+ (define schedule-action
+ (action 'schedule
+ (lambda (_ . args)
+ (schedule-timer args
+ #:requirement (list (first provision))))))
+
+ (service provision
+ #:start (const #t)
+ #:stop (const #f)
+ #:actions (list schedule-action)))
diff --git a/tests/services/timer-at.sh b/tests/services/timer-at.sh
new file mode 100644
index 0000000..60d49ec
--- /dev/null
+++ b/tests/services/timer-at.sh
@@ -0,0 +1,65 @@
+# GNU Shepherd --- Test timers.
+# Copyright © 2024 Ludovic Courtès <[email protected]>
+#
+# This file is part of the GNU Shepherd.
+#
+# The GNU Shepherd is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or (at
+# your option) any later version.
+#
+# The GNU Shepherd is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with the GNU Shepherd. If not, see <http://www.gnu.org/licenses/>.
+
+shepherd --version
+herd --version
+
+socket="t-socket-$$"
+conf="t-conf-$$"
+log="t-log-$$"
+pid="t-pid-$$"
+witness="t-witness-$$"
+
+herd="herd -s $socket"
+
+trap "cat $log || true; rm -f $socket $conf $log $witness;
+ test -f $pid && kill \`cat $pid\` || true; rm -f $pid" EXIT
+
+cat > "$conf" <<EOF
+(use-modules (shepherd service timer))
+
+(register-services (list (timer-service)))
+(start-in-the-background '(timer))
+EOF
+
+rm -f "$pid"
+shepherd -I -s "$socket" -c "$conf" -l "$log" --pid="$pid" &
+
+# Wait till it's ready.
+while ! test -f "$pid" ; do sleep 0.3 ; done
+
+shepherd_pid="`cat $pid`"
+
+function soonish
+{
+ guile -c '(use-modules (srfi srfi-19))
+(let* ((now (current-time time-utc))
+ (soon (make-time time-utc 0 (+ 5 (time-second now)))))
+ (display (date->string (time-utc->date soon) "~H:~M:~S")))'
+}
+
+$herd schedule timer at $(soonish) -- \
+ sh -c "echo TIMER; echo success > $PWD/$witness"
+
+until test -f "$witness"; do sleep 0.5; done
+grep TIMER "$log"
+
+$herd schedule timer at whatever && false
+$herd schedule timer do something && false
+
+$herd stop timer
diff --git a/tests/services/timer-events.scm b/tests/services/timer-events.scm
index 8da8f00..e373a18 100644
--- a/tests/services/timer-events.scm
+++ b/tests/services/timer-events.scm
@@ -226,4 +226,38 @@ invalid ~a field"
(test-cron-error "30 4 22 * 9" 'days-of-week)
(test-cron-error "0-99 4 22 * *" 'minutes))
+(test-equal "timer-arguments->calendar-event, simple"
+ (list (calendar-event #:seconds '(0)
+ #:minutes '(14)
+ #:hours '(17))
+ (command '("echo" "hello")))
+ (call-with-values
+ (lambda ()
+ (timer-arguments->calendar-event+command
+ '("at" "17:14" "echo" "hello")))
+ list))
+
+(test-equal "timer-arguments->calendar-event, \"as\""
+ (list (calendar-event #:seconds '(56)
+ #:minutes '(34)
+ #:hours '(12))
+ (let ((me (getpwuid (getuid))))
+ (command '("echo" "hello")
+ #:user (passwd:name me)
+ #:group (group:name (getgrgid (passwd:gid me)))
+ #:directory (passwd:dir me))))
+ (call-with-values
+ (lambda ()
+ (timer-arguments->calendar-event+command
+ `("at" "12:34:56" "as" ,(passwd:name (getpwuid (getuid)))
+ "echo" "hello")))
+ list))
+
+(test-assert "timer-arguments->calendar-event, wrong-type-arg"
+ (catch 'wrong-type-arg
+ (lambda ()
+ (timer-arguments->calendar-event+command '("echo" "forgot something"))
+ #f)
+ (const #t)))
+
(test-end "timer")
