summaryrefslogtreecommitdiff
path: root/gnu/services
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2018-07-11 23:40:57 +0200
committerLudovic Courtès <ludo@gnu.org>2018-07-13 00:08:55 +0200
commit147c5aa5d4e3bd21ee4c4cae70dff8da0bcf94b7 (patch)
tree8eaf1324699fdfd0e95f1545710258b77cb7a9d5 /gnu/services
parent701383081a9814d21823d42978ae23ee654e0427 (diff)
services: mcron: Add 'schedule' action.
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'.
Diffstat (limited to 'gnu/services')
-rw-r--r--gnu/services/herd.scm3
-rw-r--r--gnu/services/mcron.scm76
2 files changed, 62 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)