summaryrefslogtreecommitdiff
path: root/gnu
diff options
context:
space:
mode:
Diffstat (limited to 'gnu')
-rw-r--r--gnu/services/herd.scm3
-rw-r--r--gnu/services/mcron.scm76
-rw-r--r--gnu/tests/base.scm7
3 files changed, 69 insertions, 17 deletions
diff --git a/gnu/services/herd.scm b/gnu/services/herd.scm
index d882c232cf..8c96b70731 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 5bee02a587..5757bf8cf6 100644
--- a/gnu/services/mcron.scm
+++ b/gnu/services/mcron.scm
@@ -60,29 +60,71 @@
(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?)
+ (catch 'system-error
+ (lambda ()
+ (zero? (close-pipe pipe)))
+ (lambda args
+ ;; There's with race between the SIGCHLD handler, which
+ ;; could call 'waitpid' before 'close-pipe' above does. If
+ ;; we get ECHILD, that means we lost the race, but that's
+ ;; fine.
+ (or (= ECHILD (system-error-errno args))
+ (apply throw args)))))
+ (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 0efb4a6e55..f27064af85 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)))))