[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[shepherd] 05/06: Add timer services.
|
From: |
Ludovic Courtès |
|
Subject: |
[shepherd] 05/06: Add timer services. |
|
Date: |
Wed, 20 Mar 2024 18:10:43 -0400 (EDT) |
civodul pushed a commit to branch wip-timers
in repository shepherd.
commit 2d7b067a5f24ecd4fdd2558d1f5ad54db8ba63d2
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Sat Mar 16 00:04:00 2024 +0100
Add timer services.
* modules/shepherd/service/timer.scm,
tests/services/timer.sh, tests/services/timer-events.scm: New files.
* Makefile.am (dist_servicesub_DATA, TESTS): Add them.
* modules/shepherd/service.scm (current-service)
(default-service-directory, terminate-process): Export.
* doc/shepherd.texi (Timers): New section.
(Service De- and Constructors): Add cross-reference.
(Service Examples): Add example.
* po/POTFILES.in: Add ‘modules/shepherd/service/timer.scm’.
---
Makefile.am | 9 +-
doc/shepherd.texi | 111 ++++++++++
modules/shepherd/service.scm | 14 +-
modules/shepherd/service/timer.scm | 440 +++++++++++++++++++++++++++++++++++++
po/POTFILES.in | 1 +
tests/services/timer-events.scm | 90 ++++++++
tests/services/timer.sh | 88 ++++++++
7 files changed, 748 insertions(+), 5 deletions(-)
diff --git a/Makefile.am b/Makefile.am
index 25f7429..62c3f5f 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -1,6 +1,6 @@
# Makefile.am -- How to build and install the Shepherd.
# Copyright © 2002, 2003 Wolfgang Jährling <wolfgang@pro-linux.de>
-# Copyright © 2013-2016, 2018-2020, 2022-2023 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2013-2016, 2018-2020, 2022-2024 Ludovic Courtès <ludo@gnu.org>
# Copyright © 2018 Carlo Zancanaro <carlo@zancanaro.id.au>
# Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
#
@@ -49,7 +49,8 @@ nodist_shepherdsub_DATA = \
modules/shepherd/system.scm
dist_servicesub_DATA = \
modules/shepherd/service/monitoring.scm \
- modules/shepherd/service/repl.scm
+ modules/shepherd/service/repl.scm \
+ modules/shepherd/service/timer.scm
shepherdgosubdir = $(guileobjectdir)/shepherd
servicegosubdir = $(guileobjectdir)/shepherd/service
@@ -277,7 +278,9 @@ TESTS = \
tests/daemonize.sh \
tests/eval-load.sh \
tests/services/monitoring.sh \
- tests/services/repl.sh
+ tests/services/repl.sh \
+ tests/services/timer.sh \
+ tests/services/timer-events.scm
TEST_EXTENSIONS = .sh .scm
EXTRA_DIST += $(TESTS)
diff --git a/doc/shepherd.texi b/doc/shepherd.texi
index 57230c3..2584b8f 100644
--- a/doc/shepherd.texi
+++ b/doc/shepherd.texi
@@ -652,6 +652,7 @@ These procedures may not be used in Guile processes other
than
* Interacting with Services:: Accessing service state.
* Service De- and Constructors:: Commonly used ways of starting and
stopping services.
+* Timers:: Timed services.
* The root Service:: The service that comes first.
* Legacy GOOPS Interface:: Deprecated interface and how to migrate.
* Service Examples:: Examples that show how services are used.
@@ -1141,6 +1142,7 @@ because in that case the @code{stop} method of the
@code{<service>}
arranges so that the service is not respawned.
@end deffn
+@anchor{exec-command}
The @code{make-forkexec-constructor} procedure builds upon the following
procedures.
@@ -1401,6 +1403,94 @@ Similar to @code{make-system-constructor}, but returns
@code{#f} if
execution of the @var{command} was successful, @code{#t} if not.
@end deffn
+@xref{Timers}, for other service constructors and destructors: those for
+timers.
+
+@node Timers
+@section Timers
+
+@cindex timers (timed services)
+@cindex timed services (timers)
+@cindex periodic services
+In addition to process, inetd-style, and systemd-style services
+discussed before, another type of service is available: @dfn{timers}.
+
+Timers, you guessed it, execute a command or call a procedure
+periodically. They work like other services: they can be started,
+stopped, unloaded, and so on. The constructor and destructor shown
+below let you define a timer; they are exported by @code{(shepherd
+service timer)}, so make sure to add a line like this to your
+configuration file if you'd like to use them:
+
+@lisp
+(use-modules (shepherd service timer))
+@end lisp
+
+@cindex calendar events, for timers
+@cindex timer periodicity
+Timers fire on calendar events: ``every Sunday at noon'', ``everyday at
+11AM and 8PM'', ``on the first of each month'', etc@. If you ever used
+cron, mcron, or systemd timers, this is similar. Calendar events are
+specified using the @code{calendar-event} procedure, which defines
+@emph{constraints} on each calendar component: months, days of week,
+hours, minutes, and so on. Here are a few examples:
+
+@lisp
+;; Every Sunday and every Wednesday, at noon.
+(calendar-event #:hours '(12) #:minutes '(0)
+ #:days-of-week '(0 3))
+
+;; Everyday at 11AM and 8PM.
+(calendar-event #:hours '(11 20) #:minutes '(0))
+
+;; At 9:10AM on the first and fifteenth of each month.
+(calendar-event #:days-of-month '(1 15)
+ #:hours '(9) #:minutes '(10))
+@end lisp
+
+@deffn {Procedure} calendar-event [#:months any-month] @
+ [#:days-of-month any-day] [#:days-of-week #f] @
+ [#:hours any-hour] [#:minutes any-minute] @
+ [#:seconds '(0)]
+Return a calendar event that obeys the given constraints.
+@end deffn
+
+@deffn {Procedure} make-timer-constructor @var{event} @var{action} @
+ [#:wait-for-termination?]
+Return a procedure for use as the @code{start} method of a service. The
+procedure will perform @var{action} at every occurrence of @code{event}, a
+calendar event as returned by @code{calendar-event}. @var{action} may be
+either a command (returned by @code{command}) or a thunk; in the latter case,
+the thunk must be suspendable or it could block the whole shepherd process.
+
+When @var{wait-for-termination?} is true, wait until @var{action} has finished
+before considering executing it again; otherwise, perform @var{action}
+strictly on every occurrence of @var{event}, at the risk of having multiple
+instances running concurrently.
+@end deffn
+
+@deffn {Procedure} make-timer-destructor
+Return a procedure for the @code{stop} method of a service whose
+constructor was given by @code{make-timer-destructor}.
+@end deffn
+
+As we have seen above, @code{make-timer-destructor} can be passed a
+command to execute. Those are specified using the @code{command}
+procedure below.
+
+@deffn {Procedure} command @var{line} @
+ [#:user #f] [#:group #f] @
+ [#:environment-variables (default-environment-variables)] @
+ [#:directory (default-service-directory)] @
+ [#:resource-limits '()]
+Return a new command for @var{line}, a program name and argument list, to be
+executed as @var{user} and @var{group}, with the given
+@var{environment-variables}, in @var{directory}, and with the given
+@var{resource-limits}.
+
+These arguments are the same as for @code{fork+exec-command} and related
+procedures (@pxref{exec-command, @code{fork+exec-command}}).
+@end deffn
@c @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
@@ -1644,6 +1734,27 @@ passing it the client connection. The
@code{#:max-connections}
parameter instructs @command{shepherd} to accept at most 10 simultaneous
client connections.
+@cindex timer, example
+Let's now look at @dfn{timers}---services that run periodically, on
+chosen calendar events. If you ever used the systemd timers or the
+venerable cron, this is similar. The example below defines a timer that
+fires everyday at noon and runs the @command{updatedb} command as root
+(@pxref{Invoking updatedb,,, find, Finding Files}):
+
+@lisp
+(define updatedb
+ (service
+ '(updatedb)
+ #:start (make-timer-constructor
+ (calendar-event #:hours '(12) #:minutes (0))
+ (command '("/usr/bin/updatedb"
+ "--prunepaths=/tmp")))
+ #:stop (make-timer-destructor)))
+
+(register-services (list updatedb))
+(start-in-the-background '(updatedb))
+@end lisp
+
In these examples, we haven't discussed dependencies among
services---the @code{#:requires} keyword of @code{<service>}---nor did
we discuss systemd-style services. These are extensions of what we've
diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index 7ef2ff0..5530edd 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -79,6 +79,7 @@
with-service-registry
lookup-service
service-name-count
+ current-service
action?
@@ -97,6 +98,8 @@
start-command
spawn-command
spawn-shell-command
+ terminate-process
+ record-process-exit-status
%precious-signals
register-services
unregister-services
@@ -105,6 +108,7 @@
default-respawn-delay
default-service-termination-handler
default-environment-variables
+ default-service-directory
make-forkexec-constructor
make-kill-destructor
default-process-termination-grace-period
@@ -1885,6 +1889,13 @@ environment variable used for systemd-style \"socket
activation\"."
log-input))
pid)))))))
+(define (record-process-exit-status pid status)
+ "Record in the current service, if any, the exit STATUS of process PID."
+ (when (current-service)
+ (put-message (service-control (current-service))
+ `(record-process-exit-status ,pid ,status))
+ #t))
+
(define* (make-forkexec-constructor command
#:key
(user #f)
@@ -1980,8 +1991,7 @@ process is still running after @var{grace-period}
seconds, send it
#:grace-period grace-period)
(terminate-process (- pgid) signal
#:grace-period grace-period))))
- (put-message (service-control (current-service))
- `(record-process-exit-status ,pid ,status))
+ (record-process-exit-status pid status)
#f)))
(define (spawn-shell-command command)
diff --git a/modules/shepherd/service/timer.scm
b/modules/shepherd/service/timer.scm
new file mode 100644
index 0000000..c549017
--- /dev/null
+++ b/modules/shepherd/service/timer.scm
@@ -0,0 +1,440 @@
+;; timer.scm -- Timer service.
+;; Copyright (C) 2024 Ludovic Courtès <ludo@gnu.org>
+;;
+;; 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/>.
+
+(define-module (shepherd service timer)
+ #:use-module (shepherd service)
+ #:use-module (shepherd support)
+ #:use-module (shepherd comm)
+ #:use-module ((fibers) #:hide (sleep))
+ #:use-module (fibers channels)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
+ #:use-module (srfi srfi-19)
+ #:use-module (srfi srfi-71)
+ #:use-module (ice-9 match)
+ #:export (calendar-event
+ calendar-event?
+ calendar-event-months
+ calendar-event-days-of-month
+ calendar-event-days-of-week
+ calendar-event-hours
+ calendar-event-minutes
+ calendar-event-seconds
+
+ next-calendar-event
+
+ command
+ command?
+ command-line
+ command-user
+ command-group
+ command-directory
+ command-resource-limits
+ command-environment-variables
+
+ make-timer-constructor
+ make-timer-destructor))
+
+;;; Commentary:
+;;;
+;;; This module implements constructors and destructors for "timers"--services
+;;; that invoke commands periodically.
+;;;
+;;; Code:
+
+(define-record-type <calendar-event>
+ (%calendar-event seconds minutes hours days-of-month months days-of-week)
+ calendar-event?
+ (seconds calendar-event-seconds)
+ (minutes calendar-event-minutes)
+ (hours calendar-event-hours)
+ (days-of-month calendar-event-days-of-month)
+ (months calendar-event-months)
+ (days-of-week calendar-event-days-of-week))
+
+(define any-minute (iota 60))
+(define any-hour (iota 24))
+(define any-day-of-month (iota 31 1))
+(define any-month (iota 12 1))
+
+(define* (calendar-event #:key
+ (seconds '(0))
+ (minutes any-minute)
+ (hours any-hour)
+ days-of-week
+ (days-of-month
+ (and (not days-of-week) any-day-of-month))
+ (months any-month))
+ "Return a calendar event that obeys the given constraints."
+ (%calendar-event seconds minutes hours days-of-month months days-of-week))
+
+(define-syntax-rule (define-date-setter name getter)
+ (define (name date value)
+ (set-field date (getter) value)))
+
+(define-date-setter set-date-nanosecond date-nanosecond)
+(define-date-setter set-date-second date-second)
+(define-date-setter set-date-minute date-minute)
+(define-date-setter set-date-hour date-hour)
+(define-date-setter set-date-day date-day)
+(define-date-setter set-date-month date-month)
+(define-date-setter set-date-year date-year)
+
+(define (increment-year date)
+ (set-date-year date (+ 1 (date-year date))))
+
+(define (increment-month date)
+ (if (< (date-month date) 12)
+ (set-date-month date (+ (date-month date) 1))
+ (set-date-month (increment-year date) 1)))
+
+(define (increment-day date)
+ (if (< (date-day date)
+ (days-in-month (date-month date) (date-year date)))
+ (set-date-day date (+ (date-day date) 1))
+ (set-date-day (increment-month date) 1)))
+
+(define (increment-hour date)
+ (if (< (date-hour date) 23)
+ (set-date-hour date (+ (date-hour date) 1))
+ (set-date-hour (increment-day date) 0)))
+
+(define (increment-minute date)
+ (if (< (date-minute date) 59)
+ (set-date-minute date (+ (date-minute date) 1))
+ (set-date-minute (increment-hour date) 0)))
+
+(define (increment-second date)
+ (if (< (date-second date) 59)
+ (set-date-second date (+ (date-second date) 1))
+ (set-date-second (increment-minute date) 0)))
+
+(define (days-in-month month year)
+ "Return the number of days in @var{month} of @var{year}."
+ (let* ((next-day (make-date 0 0 0 0
+ 1 (modulo (+ 1 month) 12)
+ (if (= 12 month) (+ 1 year) year)
+ 0))
+ (time (date->time-utc next-day))
+ (date (time-utc->date
+ (make-time time-utc 0
+ (- (time-second time) 3600))
+ 0)))
+ (date-day date)))
+
+(define (sooner current max)
+ "Return a two-argument procedure that returns true when its first argument
+is closer to @var{current} than its second argument. The distance to
+@var{current} is computed modulo @var{max}."
+ (define (distance value)
+ (modulo (- value current) max))
+
+ (lambda (value1 value2)
+ (< (distance value1) (distance value2))))
+
+(define (fit-month date months)
+ (let loop ((candidates (sort months
+ (sooner (date-month date) 12))))
+ (match candidates
+ ((first . rest)
+ (if (and (= first (date-month date))
+ (> (date-day date) 1))
+ (loop rest)
+ (let ((next (if (>= first (date-month date))
+ date
+ (increment-year date))))
+ (set-date-month next first)))))))
+
+(define (fit-day date days)
+ (let loop ((candidates (sort days
+ (sooner (date-day date)
+ (days-in-month (date-month date)
+ (date-year date))))))
+ (match candidates
+ ((first . rest)
+ (if (and (= first (date-day date))
+ (> (date-hour date) 0))
+ (loop rest)
+ (let ((next (if (>= first (date-day date))
+ date
+ (increment-month date))))
+ (set-date-day next first)))))))
+
+(define (fit-hour date hours)
+ (let loop ((candidates (sort hours
+ (sooner (date-hour date) 24))))
+ (match candidates
+ ((first . rest)
+ (if (and (= first (date-hour date))
+ (> (date-minute date) 0))
+ (loop rest)
+ (let ((next (if (>= first (date-hour date))
+ date
+ (increment-day date))))
+ (set-date-hour next first)))))))
+
+(define (fit-minute date minutes)
+ (let loop ((candidates (sort minutes
+ (sooner (date-minute date) 60))))
+ (match candidates
+ ((first . rest)
+ (if (and (= first (date-minute date))
+ (> (date-second date) 0))
+ (loop rest)
+ (let ((next (if (>= first (date-minute date))
+ date
+ (increment-hour date))))
+ (set-date-minute next first)))))))
+
+(define (fit-second date seconds)
+ (let loop ((candidates (sort seconds
+ (sooner (date-second date) 60))))
+ (match candidates
+ ((first . rest)
+ (if (and (= first (date-second date))
+ (> (date-nanosecond date) 0))
+ (loop rest)
+ (let ((next (if (>= first (date-second date))
+ date
+ (increment-minute date))))
+ (set-date-second next first)))))))
+
+(define (week-days->month-days week-days month year)
+ "Given @var{week-days}, a list of week-days (between 0 and 6, where 0 is
+Sunday), return the corresponding list of days in @var{month} of @var{year}."
+ (let loop ((date (make-date 0 0 0 0 1 month year 0))
+ (days '()))
+ (if (= (date-month date) month)
+ (loop (increment-day date)
+ (if (memv (date-week-day date) week-days)
+ (cons (date-day date) days)
+ days))
+ (reverse days))))
+
+(define (next-calendar-event event date)
+ "Return the date following @var{date} that matches @var{event}, a calendar
+event record."
+ (define (month date)
+ (if (memv (date-month date) (calendar-event-months event))
+ date
+ (fit-month date (calendar-event-months event))))
+
+ (define (day date)
+ (let ((days (append
+ (or (calendar-event-days-of-month event) '())
+ (match (calendar-event-days-of-week event)
+ (#f
+ '())
+ (days (week-days->month-days days
+ (date-month date)
+ (date-year date)))))))
+ (if (memv (date-day date) days)
+ date
+ (fit-day date days))))
+
+ (define (hour date)
+ (if (memv (date-hour date) (calendar-event-hours event))
+ date
+ (fit-hour date (calendar-event-hours event))))
+
+ (define (minute date)
+ (if (memv (date-minute date) (calendar-event-minutes event))
+ date
+ (fit-minute date (calendar-event-minutes event))))
+
+ (define (second date)
+ (if (memv (date-second date) (calendar-event-seconds event))
+ date
+ (fit-second date (calendar-event-seconds event))))
+
+ (define (nanosecond date)
+ ;; Clear nanoseconds and jump to the next second.
+ (increment-second (set-date-nanosecond date 0)))
+
+ ;; TODO: Adjust timezone.
+ (month (day (hour (minute (second (nanosecond date)))))))
+
+(define (seconds-to-wait event)
+ "Return the number of seconds to wait before the next occurrence of
+@var{event} (the result is always greater than zero)."
+ (define (next-second time)
+ (make-time time-utc
+ (time-nanosecond time) (+ 1 (time-second time))))
+
+ (let* ((now (next-second (current-time time-utc)))
+ (then (next-calendar-event event (time-utc->date now))))
+ (+ 1 (time-second (time-difference (date->time-utc then) now)))))
+
+
+;;;
+;;; Timer services.
+;;;
+
+;; Timer value returned by 'make-timer-constructor'.
+(define-record-type <timer>
+ (timer channel event action)
+ timer?
+ (channel timer-channel) ;channel
+ (event timer-event) ;<calendar-event>
+ (action timer-action)) ;<command> | procedure
+
+;; Command to be executed by a timer.
+(define-record-type <command>
+ (%command line user group environment-variables directory resource-limits)
+ command?
+ (line command-line)
+ (user command-user)
+ (group command-group)
+ (environment-variables command-environment-variables)
+ (directory command-directory)
+ (resource-limits command-resource-limits))
+
+(define* (command line #:key user group
+ (environment-variables (default-environment-variables))
+ (directory (default-service-directory))
+ (resource-limits '()))
+ "Return a new command for @var{line}, a program name and argument list, to be
+executed as @var{user} and @var{group}, with the given
+@var{environment-variables}, in @var{directory}, and with the given
+@var{resource-limits}."
+ (%command line user group environment-variables directory
+ resource-limits))
+
+(define (calendar-event->sexp event)
+ `(calendar-event (version 0)
+ (seconds ,(calendar-event-seconds event))
+ (minutes ,(calendar-event-minutes event))
+ (hours ,(calendar-event-hours event))
+ (days-of-month ,(calendar-event-days-of-month event))
+ (days-of-week ,(calendar-event-days-of-week event))
+ (months ,(calendar-event-months event))))
+
+(define (command->sexp command)
+ `(command (version 0)
+ (arguments ,(command-line command))
+ (user ,(command-user command))
+ (group ,(command-group command))
+ (environment-variables ,(command-environment-variables command))
+ (directory ,(command-directory command))
+ (resource-limits ,(command-resource-limits command))))
+
+(define-record-type-serializer (serializer-timer (timer <timer>))
+ ;; Serialize TIMER to clients can inspect it.
+ `(timer (version 0)
+ (event ,(match (timer-event timer)
+ ((? calendar-event? event)
+ (calendar-event->sexp event))
+ (_ #f)))
+ (action ,(match (timer-action timer)
+ ((? command? command) (command->sexp command))
+ (_ 'procedure)))))
+
+(define sleep (@ (fibers) sleep))
+
+(define* (make-timer-constructor event action
+ #:key wait-for-termination?)
+ "Return a procedure for use as the @code{start} method of a service. The
+procedure will perform @var{action} at every occurrence of @code{event}, a
+calendar event as returned by @code{calendar-event}. @var{action} may be
+either a command (returned by @code{command}) or a thunk; in the latter case,
+the thunk must be suspendable or it could block the whole shepherd process.
+
+When @var{wait-for-termination?} is true, wait until @var{action} has finished
+before considering executing it again; otherwise, perform @var{action}
+strictly on every occurrence of @var{event}, at the risk of having multiple
+instances running concurrently."
+ (lambda ()
+ (let ((channel (make-channel))
+ (name (service-canonical-name (current-service))))
+ (spawn-fiber
+ (lambda ()
+ (let loop ((processes '())
+ (termination #f))
+ (match (if (or termination
+ (and (pair? processes) wait-for-termination?))
+ (get-message channel)
+ (get-message* channel (seconds-to-wait event)
+ 'timeout))
+ (('terminate reply)
+ ;; Terminate this timer and its processes. Send #t on REPLY
+ ;; when we're done.
+ (local-output
+ (l10n "Terminating timer '~a' with ~a process running."
+ "Terminating timer '~a' with ~a processes running."
+ (length processes))
+ name (length processes))
+ (for-each (lambda (pid)
+ (terminate-process pid SIGHUP))
+ processes)
+ ;; If there are processes left, keep going until they're gone.
+ (if (pair? processes)
+ (loop processes reply)
+ (put-message reply #t)))
+ (('process-terminated pid status)
+ ;; Process PID completed.
+ (local-output
+ (l10n "Process ~a of timer '~a' terminated with status ~a.")
+ pid name status)
+ (record-process-exit-status pid status)
+ (let ((processes (delv pid processes)))
+ (if (and termination (null? processes))
+ (put-message termination #t) ;done
+ (loop processes termination))))
+ ('timeout
+ ;; Time to perform ACTION.
+ (if (command? action)
+ (let ((pid status (start-command
+ (command-line action)
+ #:user (command-user action)
+ #:group (command-group action)
+ #:environment-variables
+ (command-environment-variables action)
+ #:directory (command-directory action)
+ #:resource-limits
+ (command-resource-limits action))))
+ (spawn-fiber
+ (lambda ()
+ (let ((status (get-message status)))
+ (put-message channel
+ `(process-terminated ,pid ,status)))))
+
+ (local-output (l10n "Timer '~a' spawned process ~a.")
+ name pid)
+ (loop (cons pid processes) termination))
+ (begin
+ (catch #t
+ action
+ (lambda (key . args)
+ (local-output
+ (l10n "Exception caught while calling action of
+timer '~a': ~s~%")
+ name (cons key args))))
+ (loop processes termination))))))))
+
+ (timer channel event action))))
+
+(define (make-timer-destructor)
+ "Return a procedure for the @code{stop} method of a service whose
+constructor was given by @code{make-timer-destructor}."
+ (lambda (timer)
+ (let ((reply (make-channel)))
+ (put-message (timer-channel timer) `(terminate ,reply))
+ ;; Wait until child processes have terminated.
+ (get-message reply))
+ #f))
diff --git a/po/POTFILES.in b/po/POTFILES.in
index e6e92d1..f53e6b0 100644
--- a/po/POTFILES.in
+++ b/po/POTFILES.in
@@ -8,5 +8,6 @@ modules/shepherd/support.scm
modules/shepherd/service.scm
modules/shepherd/service/monitoring.scm
modules/shepherd/service/repl.scm
+modules/shepherd/service/timer.scm
modules/shepherd/args.scm
modules/shepherd.scm
diff --git a/tests/services/timer-events.scm b/tests/services/timer-events.scm
new file mode 100644
index 0000000..bdd10cc
--- /dev/null
+++ b/tests/services/timer-events.scm
@@ -0,0 +1,90 @@
+;; GNU Shepherd --- Test timer service.
+;; Copyright © 2024 Ludovic Courtès <ludo@gnu.org>
+;;
+;; 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/>.
+
+(define-module (test-timer)
+ #:use-module (shepherd service timer)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-19)
+ #:use-module (srfi srfi-64))
+
+(test-begin "timer")
+
+(test-equal "next-calendar-event, leap year"
+ (make-date 0 0 00 12 29 02 2024 3600)
+ (next-calendar-event (calendar-event #:hours '(12) #:minutes '(0))
+ (make-date 123456789 42 44 12 28 02 2024 3600)))
+
+(test-equal "next-calendar-event, non-leap year"
+ (make-date 0 0 00 12 01 03 2023 3600)
+ (next-calendar-event (calendar-event #:hours '(12) #:minutes '(0))
+ (make-date 123456789 42 44 12 28 02 2023 3600)))
+
+(test-equal "next-calendar-event, same day"
+ (make-date 0 0 42 12 28 02 2024 3600)
+ (next-calendar-event (calendar-event #:hours '(12) #:minutes '(42))
+ (make-date 123456789 42 09 12 28 02 2024 3600)))
+
+(test-equal "next-calendar-event, days of week"
+ `(,(make-date 0 0 30 12 02 03 2024 3600)
+ ,(make-date 0 0 30 18 02 03 2024 3600)
+ ,@(append-map (lambda (day)
+ (list (make-date 0 0 30 06 day 03 2024 3600)
+ (make-date 0 0 30 12 day 03 2024 3600)
+ (make-date 0 0 30 18 day 03 2024 3600)))
+ '(03 06 09)))
+ ;; March 2024
+ ;; Su Mo Tu We Th Fr Sa
+ ;; 1 2
+ ;; 3 4 5 6 7 8 9
+ ;; 10 11 12 13 14 15 16
+ ;; 17 18 19 20 21 22 23
+ ;; 24 25 26 27 28 29 30
+ ;; 31
+ (let ((event (calendar-event #:hours '(6 12 18)
+ #:minutes '(30)
+ ;; Sunday, Wednesday, Saturday
+ #:days-of-week '(0 3 6))))
+ (let loop ((date (make-date 123456789 42 09 12
+ ;; Start on Saturday, March 2nd.
+ 02 03 2024 3600))
+ (n 0)
+ (result '()))
+ (if (< n 11)
+ (let ((date (next-calendar-event event date)))
+ (loop date (+ 1 n) (cons date result)))
+ (reverse result)))))
+
+(test-equal "next-calendar-event, once everyday"
+ (append (map (lambda (day)
+ (make-date 0 0 14 17 day 03 2024 3600))
+ (iota 31 1))
+ (map (lambda (day)
+ (make-date 0 0 14 17 day 04 2024 3600))
+ (iota 14 1)))
+ (let ((event (calendar-event #:hours '(17)
+ #:minutes '(14))))
+ (let loop ((date (make-date 123456789 42 09 12
+ 01 03 2024 3600))
+ (n 0)
+ (result '()))
+ (if (< n (+ 31 14))
+ (let ((date (next-calendar-event event date)))
+ (loop date (+ 1 n) (cons date result)))
+ (reverse result)))))
+
+(test-end "timer")
diff --git a/tests/services/timer.sh b/tests/services/timer.sh
new file mode 100644
index 0000000..7fac11c
--- /dev/null
+++ b/tests/services/timer.sh
@@ -0,0 +1,88 @@
+# GNU Shepherd --- Test timed services.
+# Copyright © 2024 Ludovic Courtès <ludo@gnu.org>
+#
+# 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-$$"
+service_pid="t-service-pid-$$"
+
+herd="herd -s $socket"
+
+trap "cat $log || true; rm -f $socket $conf $log $service_pid;
+ test -f $pid && kill \`cat $pid\` || true; rm -f $pid" EXIT
+
+cat > "$conf" <<EOF
+(use-modules (shepherd service timer))
+
+(define endless
+ "echo Started endless timer.; echo \$\$ > $PWD/$service_pid; sleep 500")
+
+(define timers
+ (list (service '(timer-with-command)
+ #:start (make-timer-constructor
+ (calendar-event #:seconds (iota 60))
+ (command '("sh" "-c" "echo Hi from $PWD.")))
+ #:stop (make-timer-destructor))
+ (service '(timer-with-procedure)
+ #:start (make-timer-constructor
+ (calendar-event #:seconds (iota 60))
+ (lambda () (display "Hello from procedure.\n")))
+ #:stop (make-timer-destructor))
+ (service '(endless-timer)
+ #:start (make-timer-constructor
+ (calendar-event #:seconds (iota 60))
+ (command (quasiquote ("sh" "-c" ,endless)))
+ #:wait-for-termination? #t)
+ #:stop (make-timer-destructor))))
+
+(register-services timers)
+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`"
+
+$herd start timer-with-command
+sleep 2
+grep "Hi from " "$log"
+$herd status timer-with-command | grep "Hi from " # recent messages
+$herd stop timer-with-command
+
+$herd start timer-with-procedure
+sleep 2
+grep "Hello from procedure" "$log"
+
+rm -f "$service_pid"
+$herd start endless-timer
+sleep 2
+grep "Started endless timer" "$log"
+$herd status endless-timer | grep "Started endless timer" # recent messages
+kill -0 $(cat "$service_pid")
+$herd stop endless-timer
+kill -0 $(cat "$service_pid") && false
+grep "Process $(cat "$service_pid") of timer 'endless-timer' terminated" "$log"
+
+$herd stop root
- [shepherd] branch wip-timers created (now 57786b0), Ludovic Courtès, 2024/03/20
- [shepherd] 01/06: build: Add support for Scheme tests., Ludovic Courtès, 2024/03/20
- [shepherd] 02/06: service: Fix typo in ‘register-logger’ message., Ludovic Courtès, 2024/03/20
- [shepherd] 04/06: service: Add ‘start-command’., Ludovic Courtès, 2024/03/20
- [shepherd] 03/06: service: ‘spawn-via-monitor’ associates a logger with the calling service., Ludovic Courtès, 2024/03/20
- [shepherd] 06/06: herd: Display information about timers., Ludovic Courtès, 2024/03/20
- [shepherd] 05/06: Add timer services.,
Ludovic Courtès <=