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'.master
Ludovic Courtès
parent
701383081a
commit
147c5aa5d4
|
|
@ -10850,6 +10850,21 @@ gexps to introduce job definitions that are passed to mcron
|
|||
for more information on mcron job specifications. Below is the
|
||||
reference of the mcron service.
|
||||
|
||||
On a running system, you can use the @code{schedule} action of the service to
|
||||
visualize the mcron jobs that will be executed next:
|
||||
|
||||
@example
|
||||
# herd schedule mcron
|
||||
@end example
|
||||
|
||||
@noindent
|
||||
The example above lists the next five tasks that will be executed, but you can
|
||||
also specify the number of tasks to display:
|
||||
|
||||
@example
|
||||
# herd schedule mcron 10
|
||||
@end example
|
||||
|
||||
@deffn {Scheme Procedure} mcron-service @var{jobs} [#:mcron @var{mcron}]
|
||||
Return an mcron service running @var{mcron} that schedules @var{jobs}, a
|
||||
list of gexps denoting mcron job specifications.
|
||||
|
|
|
|||
|
|
@ -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 ...)))
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)))))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue