mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 21:38:07 -05:00
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'.
This commit is contained in:
parent
701383081a
commit
147c5aa5d4
4 changed files with 84 additions and 17 deletions
|
@ -10850,6 +10850,21 @@ gexps to introduce job definitions that are passed to mcron
|
||||||
for more information on mcron job specifications. Below is the
|
for more information on mcron job specifications. Below is the
|
||||||
reference of the mcron service.
|
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}]
|
@deffn {Scheme Procedure} mcron-service @var{jobs} [#:mcron @var{mcron}]
|
||||||
Return an mcron service running @var{mcron} that schedules @var{jobs}, a
|
Return an mcron service running @var{mcron} that schedules @var{jobs}, a
|
||||||
list of gexps denoting mcron job specifications.
|
list of gexps denoting mcron job specifications.
|
||||||
|
|
|
@ -45,6 +45,7 @@ (define-module (gnu services herd)
|
||||||
live-service-requirement
|
live-service-requirement
|
||||||
live-service-running
|
live-service-running
|
||||||
|
|
||||||
|
with-shepherd-action
|
||||||
current-services
|
current-services
|
||||||
unload-services
|
unload-services
|
||||||
unload-service
|
unload-service
|
||||||
|
@ -168,6 +169,8 @@ (define* (invoke-action service action arguments cont)
|
||||||
|
|
||||||
(define-syntax-rule (with-shepherd-action service (action args ...)
|
(define-syntax-rule (with-shepherd-action service (action args ...)
|
||||||
result body ...)
|
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 ...)
|
(invoke-action service action (list args ...)
|
||||||
(lambda (result) body ...)))
|
(lambda (result) body ...)))
|
||||||
|
|
||||||
|
|
|
@ -60,29 +60,71 @@ (define-record-type* <mcron-configuration> mcron-configuration
|
||||||
(define (job-file job)
|
(define (job-file job)
|
||||||
(scheme-file "mcron-job" 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
|
(define mcron-shepherd-services
|
||||||
(match-lambda
|
(match-lambda
|
||||||
(($ <mcron-configuration> mcron ()) ;nothing to do!
|
(($ <mcron-configuration> mcron ()) ;nothing to do!
|
||||||
'())
|
'())
|
||||||
(($ <mcron-configuration> mcron jobs)
|
(($ <mcron-configuration> mcron jobs)
|
||||||
(list (shepherd-service
|
(let ((files (map job-file jobs)))
|
||||||
(provision '(mcron))
|
(list (shepherd-service
|
||||||
(requirement '(user-processes))
|
(provision '(mcron))
|
||||||
(modules `((srfi srfi-1)
|
(requirement '(user-processes))
|
||||||
(srfi srfi-26)
|
(modules `((srfi srfi-1)
|
||||||
,@%default-modules))
|
(srfi srfi-26)
|
||||||
(start #~(make-forkexec-constructor
|
(ice-9 popen) ;for the 'schedule' action
|
||||||
(list (string-append #$mcron "/bin/mcron")
|
(ice-9 rdelim)
|
||||||
#$@(map job-file jobs))
|
(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
|
;; Disable auto-compilation of the job files and set a
|
||||||
;; sane value for 'PATH'.
|
;; sane value for 'PATH'.
|
||||||
#:environment-variables
|
#:environment-variables
|
||||||
(cons* "GUILE_AUTO_COMPILE=0"
|
(cons* "GUILE_AUTO_COMPILE=0"
|
||||||
"PATH=/run/current-system/profile/bin"
|
"PATH=/run/current-system/profile/bin"
|
||||||
(remove (cut string-prefix? "PATH=" <>)
|
(remove (cut string-prefix? "PATH=" <>)
|
||||||
(environ)))))
|
(environ)))))
|
||||||
(stop #~(make-kill-destructor)))))))
|
(stop #~(make-kill-destructor))
|
||||||
|
|
||||||
|
(actions
|
||||||
|
(list (shepherd-schedule-action mcron files)))))))))
|
||||||
|
|
||||||
(define mcron-service-type
|
(define mcron-service-type
|
||||||
(service-type (name 'mcron)
|
(service-type (name 'mcron)
|
||||||
|
|
|
@ -632,6 +632,13 @@ (define marionette
|
||||||
(wait-for-file "/root/witness-touch" marionette
|
(wait-for-file "/root/witness-touch" marionette
|
||||||
#:read '(@ (ice-9 rdelim) read-string)))
|
#: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)
|
(test-end)
|
||||||
(exit (= (test-runner-fail-count (test-runner-current)) 0)))))
|
(exit (= (test-runner-fail-count (test-runner-current)) 0)))))
|
||||||
|
|
||||||
|
|
Loading…
Reference in a new issue