civodul pushed a commit to branch devel
in repository shepherd.
commit 0a444bd1685d6613086a020a40428b8bc1130632
Author: Ludovic Courtès <[email protected]>
AuthorDate: Wed Oct 9 15:56:30 2024 +0200
timer: Add #:occurrences to ‘make-timer-constructor’.
* modules/shepherd/service/timer.scm (serialize-timer): Add
‘remaining-occurrences’.
(timer-remaining-occurrences): New procedure.
(make-timer-constructor): Add #:occurrences.
[stop-self]: New procedure.
[run-timer]: Add ‘occurrences’ loop variable. Call ‘stop-self’ when
OCCURRENCES drops to zero. Handle 'remaining-occurrences messages.
Add ‘assert’ statement for OCCURRENCES.
* modules/shepherd/scripts/herd.scm (display-service-status): Check the
‘remaining-occurrences’ value.
* tests/services/timer.sh: Test it, with ‘timer-with-two-occurrences’.
* doc/shepherd.texi (Timers): Update.
---
doc/shepherd.texi | 11 ++++---
modules/shepherd/scripts/herd.scm | 22 +++++++++----
modules/shepherd/service/timer.scm | 63 ++++++++++++++++++++++++++++++--------
tests/services/timer.sh | 10 ++++++
4 files changed, 82 insertions(+), 24 deletions(-)
diff --git a/doc/shepherd.texi b/doc/shepherd.texi
index 52bd526..8857627 100644
--- a/doc/shepherd.texi
+++ b/doc/shepherd.texi
@@ -1524,13 +1524,14 @@ below as its @code{start} and @code{stop} methods
(@pxref{Defining
Services}).
@deffn {Procedure} make-timer-constructor @var{event} @var{action} @
- [#:log-file #f] [#:max-duration #f] @
+ [#:occurrences +inf.0] [#:log-file #f] [#:max-duration #f] @
[#:wait-for-termination? #f]
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.
+procedure will perform @var{action} for @var{occurrences} iterations 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{log-file} is true, log the output of @var{action} to that file
rather than in the global shepherd log.
diff --git a/modules/shepherd/scripts/herd.scm
b/modules/shepherd/scripts/herd.scm
index b1cd43f..15ae02b 100644
--- a/modules/shepherd/scripts/herd.scm
+++ b/modules/shepherd/scripts/herd.scm
@@ -609,12 +609,22 @@ to upgrade).~%"))))
(reverse (at-most log-history-size messages)))))
(match (live-service-running-value service)
- (('timer ('version 0) ('event sexp) _ ...)
- (let ((event (and=> sexp sexp->calendar-event)))
- (when event
- (newline)
- (format #t (highlight (l10n "Upcoming timer alarms:~%")))
- (display-timer-events event))))
+ (('timer ('version 0) properties ...)
+ (alist-let* properties (event remaining-occurrences)
+ (let ((event (and=> event sexp->calendar-event)))
+ (when event
+ (newline)
+ (if (zero? remaining-occurrences)
+ (format #t
+ (highlight/warn
+ (l10n "No upcoming timer alarm: about to stop.~%")))
+ (let ((count (min 5 (if (exact? remaining-occurrences)
+ remaining-occurrences
+ 100))))
+ (format #t (highlight (l10n "Upcoming timer alarm:~%"
+ "Upcoming timer alarms:~%"
+ count)))
+ (display-timer-events event count)))))))
(_ #t))))
(define (display-event-log services)
diff --git a/modules/shepherd/service/timer.scm
b/modules/shepherd/service/timer.scm
index 2b48e8a..1c3ad85 100644
--- a/modules/shepherd/service/timer.scm
+++ b/modules/shepherd/service/timer.scm
@@ -559,6 +559,7 @@ list, to be executed as @var{user} and @var{group}, with
the given
((? command? command) (command->sexp command))
(_ 'procedure)))
(processes ,(timer-processes timer))
+ (remaining-occurrences ,(timer-remaining-occurrences timer))
(past-runs ,(ring-buffer->list (timer-past-runs timer)))))
(define (timer-request message)
@@ -581,6 +582,11 @@ list, to be executed as @var{user} and @var{group}, with
the given
;; respectively, as integers (seconds since the Epoch).
(timer-request 'past-runs))
+(define timer-remaining-occurrences
+ ;; Return the number of remaining occurrences for this timer, possibly
+ ;; +inf.0 (infinity).
+ (timer-request 'remaining-occurrences))
+
(define sleep (@ (fibers) sleep))
(define %past-run-log-size
@@ -588,15 +594,18 @@ list, to be executed as @var{user} and @var{group}, with
the given
50)
(define* (make-timer-constructor event action
- #:key log-file
+ #:key
+ (occurrences +inf.0)
+ log-file
max-duration
(termination-signal SIGTERM)
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.
+procedure will perform @var{action} for @var{occurrences} iterations 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{log-file} is true, log the output of @var{action} to that file
rather than in the global shepherd log.
@@ -610,15 +619,28 @@ When @var{max-duration} is true, it is the maximum
duration in seconds that a
run may last, provided @var{action} is a command. Past @var{max-duration}
seconds, the timer's process is forcefully terminated with signal
@var{termination-signal}."
+ (define (stop-self)
+ ;; When the last occurrence has completed, the only way to let the service
+ ;; controller know that we're done is by asking it to stop the service.
+ (spawn-fiber
+ (lambda ()
+ (let ((self (current-service)))
+ (local-output (l10n "Finished last occurrence of timer '~a'.")
+ (service-canonical-name self))
+ (stop-service self)))))
+
(define (run-timer)
(let ((channel (make-channel))
(name (service-canonical-name (current-service))))
(spawn-fiber
(lambda ()
- (let-loop loop ((processes '()) ;PID/start time
+ (let-loop loop ((processes '()) ;PID/start time
(past-runs (ring-buffer %past-run-log-size))
+ (occurrences occurrences)
(termination #f))
+
(match (if (or termination
+ (zero? occurrences)
(and (pair? processes) wait-for-termination?))
(get-message channel)
(get-message* channel (seconds-to-wait event)
@@ -651,17 +673,23 @@ after ~a seconds.")
(- end-time start-time))
(if (and termination (null? remaining))
(put-message termination #t) ;done
- (loop (processes remaining)
- (past-runs
- (ring-buffer-insert
- (list status end-time start-time)
- past-runs))))))
+ (begin
+ (when (zero? occurrences)
+ (stop-self))
+ (loop (processes remaining)
+ (past-runs
+ (ring-buffer-insert
+ (list status end-time start-time)
+ past-runs)))))))
(('processes reply)
(put-message reply processes)
(loop))
(('past-runs reply)
(put-message reply past-runs)
(loop))
+ (('remaining-occurrences reply)
+ (put-message reply occurrences)
+ (loop))
('timeout
;; Time to perform ACTION.
(if (command? action)
@@ -695,7 +723,8 @@ process ~a of timer '~a' after maximum duration of ~a
seconds.")
(local-output (l10n "Timer '~a' spawned process ~a.")
name pid)
- (loop (processes
+ (loop (occurrences (- occurrences 1))
+ (processes
(alist-cons pid ((@ (guile) current-time))
processes))))
(let ((start-time ((@ (guile) current-time))))
@@ -711,7 +740,10 @@ timer '~a': ~s")
name (cons key args))
`(exception ,key ,@args))))
- (loop (past-runs
+ (when (= 1 occurrences)
+ (stop-self))
+ (loop (occurrences (- occurrences 1))
+ (past-runs
(ring-buffer-insert
(list result ((@ (guile) current-time)) start-time)
past-runs))))))
@@ -729,6 +761,11 @@ from sleep state?).")
(timer channel event action)))
(lambda ()
+ (assert (or (eqv? occurrences +inf.0)
+ (and (integer? occurrences)
+ (exact? occurrences)
+ (positive? occurrences))))
+
;; First check that EVENT has matching events and return #f otherwise.
(let ((now (time-utc->date (current-time time-utc))))
(if (false-if-exception (next-calendar-event event now))
diff --git a/tests/services/timer.sh b/tests/services/timer.sh
index 7bcc022..ca1e7fb 100644
--- a/tests/services/timer.sh
+++ b/tests/services/timer.sh
@@ -72,6 +72,12 @@ cat > "$conf" <<EOF
#:max-duration 1)
#:stop (make-timer-destructor)
#:actions (list timer-trigger-action))
+ (service '(timer-with-two-occurrences)
+ #:start (make-timer-constructor
+ (calendar-event #:seconds (iota 60))
+ (lambda () (display "limited number of
occurrences\n"))
+ #:occurrences 2)
+ #:stop (make-timer-destructor))
(service '(timer-without-matching-events)
#:start (make-timer-constructor
(calendar-event #:seconds '()) ;broken event!
@@ -138,6 +144,10 @@ $herd status timer-that-takes-too-long | \
grep "terminated with signal 15" # recent runs
grep "Terminating.*after maximum duration" "$log"
+$herd start timer-with-two-occurrences
+until $herd status timer-with-two-occurrences | grep stopped; do sleep 0.3;
done
+test $(grep "limited number of occurrences" "$log" | wc -l) -eq 2
+
$herd start timer-without-matching-events && false
$herd status timer-without-matching-events | grep "stopped.*failing"
