services: Add 'mcron-service'.
* gnu/services/mcron.scm: New file. * gnu/local.mk (GNU_SYSTEM_MODULES): Add it. * gnu/tests/base.scm (%mcron-os, %test-mcron): New variables. (run-mcron-test): New procedure. * doc/guix.texi (Scheduled Job Execution): New node.
This commit is contained in:
Ludovic Courtès
parent
159daace2f
commit
c311089b0b
4 changed files with 299 additions and 1 deletions
|
|
@ -204,6 +204,7 @@ System Configuration
|
|||
Services
|
||||
|
||||
* Base Services:: Essential system services.
|
||||
* Scheduled Job Execution:: The mcron service.
|
||||
* Networking Services:: Network setup, SSH daemon, etc.
|
||||
* X Window:: Graphical display.
|
||||
* Desktop Services:: D-Bus and desktop services.
|
||||
|
|
@ -7185,6 +7186,7 @@ declaration.
|
|||
|
||||
@menu
|
||||
* Base Services:: Essential system services.
|
||||
* Scheduled Job Execution:: The mcron service.
|
||||
* Networking Services:: Network setup, SSH daemon, etc.
|
||||
* X Window:: Graphical display.
|
||||
* Desktop Services:: D-Bus and desktop services.
|
||||
|
|
@ -7463,6 +7465,82 @@ archive}). If that is not the case, the service will fail to start.
|
|||
@end deffn
|
||||
|
||||
|
||||
@node Scheduled Job Execution
|
||||
@subsubsection Scheduled Job Execution
|
||||
|
||||
@cindex cron
|
||||
@cindex scheduling jobs
|
||||
The @code{(gnu services mcron)} module provides an interface to
|
||||
GNU@tie{}mcron, a daemon to run jobs at scheduled times (@pxref{Top,,,
|
||||
mcron, GNU@tie{}mcron}). GNU@tie{}mcron is similar to the traditional
|
||||
Unix @command{cron} daemon; the main difference is that it is
|
||||
implemented in Guile Scheme, which provides a lot of flexibility when
|
||||
specifying the scheduling of jobs and their actions.
|
||||
|
||||
For example, to define an operating system that runs the
|
||||
@command{updatedb} (@pxref{Invoking updatedb,,, find, Finding Files})
|
||||
and the @command{guix gc} commands (@pxref{Invoking guix gc}) daily:
|
||||
|
||||
@lisp
|
||||
(use-modules (guix) (gnu) (gnu services mcron))
|
||||
|
||||
(define updatedb-job
|
||||
;; Run 'updatedb' at 3 AM every day.
|
||||
#~(job '(next-hour '(3))
|
||||
"updatedb --prunepaths='/tmp /var/tmp /gnu/store'"))
|
||||
|
||||
(define garbage-collector-job
|
||||
;; Collect garbage 5 minutes after midnight every day.
|
||||
#~(job "5 0 * * *" ;Vixie cron syntax
|
||||
"guix gc -F 1G"))
|
||||
|
||||
(operating-system
|
||||
;; @dots{}
|
||||
(services (cons (mcron-service (list garbage-collector-job
|
||||
updatedb-job))
|
||||
%base-services)))
|
||||
@end lisp
|
||||
|
||||
@xref{Guile Syntax, mcron job specifications,, mcron, GNU@tie{}mcron},
|
||||
for more information on mcron job specifications. Below is the
|
||||
reference of the mcron service.
|
||||
|
||||
@deffn {Scheme Procedure} mcron-service @var{jobs} [#:mcron @var{mcron2}]
|
||||
Return an mcron service running @var{mcron} that schedules @var{jobs}, a
|
||||
list of gexps denoting mcron job specifications.
|
||||
|
||||
This is a shorthand for:
|
||||
@example
|
||||
(service mcron-service-type
|
||||
(mcron-configuration (mcron mcron) (jobs jobs)))
|
||||
@end example
|
||||
@end deffn
|
||||
|
||||
@defvr {Scheme Variable} mcron-service-type
|
||||
This is the type of the @code{mcron} service, whose value is an
|
||||
@code{mcron-configuration} object.
|
||||
|
||||
This service type can be the target of a service extension that provides
|
||||
it additional job specifications (@pxref{Service Composition}). In
|
||||
other words, it is possible to define services that provide addition
|
||||
mcron jobs to run.
|
||||
@end defvr
|
||||
|
||||
@deftp {Data Type} mcron-configuration
|
||||
Data type representing the configuration of mcron.
|
||||
|
||||
@table @asis
|
||||
@item @code{mcron} (default: @var{mcron2})
|
||||
The mcron package to use.
|
||||
|
||||
@item @code{jobs}
|
||||
This is a list of gexps (@pxref{G-Expressions}), where each gexp
|
||||
corresponds to an mcron job specification (@pxref{Syntax, mcron job
|
||||
specifications,, mcron, GNU@tie{}mcron}).
|
||||
@end table
|
||||
@end deftp
|
||||
|
||||
|
||||
@node Networking Services
|
||||
@subsubsection Networking Services
|
||||
|
||||
|
|
|
|||
|
|
@ -377,6 +377,7 @@ GNU_SYSTEM_MODULES = \
|
|||
%D%/services/dict.scm \
|
||||
%D%/services/lirc.scm \
|
||||
%D%/services/mail.scm \
|
||||
%D%/services/mcron.scm \
|
||||
%D%/services/networking.scm \
|
||||
%D%/services/shepherd.scm \
|
||||
%D%/services/herd.scm \
|
||||
|
|
|
|||
115
gnu/services/mcron.scm
Normal file
115
gnu/services/mcron.scm
Normal file
|
|
@ -0,0 +1,115 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
||||
;;; under the terms of the GNU General Public License as published by
|
||||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||||
;;; your option) any later version.
|
||||
;;;
|
||||
;;; GNU Guix is distributed in the hope that it will be useful, but
|
||||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;;; GNU General Public License for more details.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU General Public License
|
||||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
(define-module (gnu services mcron)
|
||||
#:use-module (gnu services)
|
||||
#:use-module (gnu services base)
|
||||
#:use-module (gnu services shepherd)
|
||||
#:autoload (gnu packages guile) (mcron2)
|
||||
#:use-module (guix records)
|
||||
#:use-module (guix gexp)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (ice-9 vlist)
|
||||
#:export (mcron-configuration
|
||||
mcron-configuration?
|
||||
mcron-configuration-mcron
|
||||
mcron-configuration-jobs
|
||||
|
||||
mcron-service-type
|
||||
mcron-service))
|
||||
|
||||
;;; Commentary:
|
||||
;;;
|
||||
;;; This module implements a service that to run instances of GNU mcron, a
|
||||
;;; periodic job execution daemon. Example of a service:
|
||||
;;
|
||||
;; (service mcron-service-type
|
||||
;; (mcron-configuration
|
||||
;; (jobs (list #~(job next-second-from
|
||||
;; (lambda ()
|
||||
;; (call-with-output-file "/dev/console"
|
||||
;; (lambda (port)
|
||||
;; (display "hello!\n" port)))))))))
|
||||
;;;
|
||||
;;; Code:
|
||||
|
||||
(define-record-type* <mcron-configuration> mcron-configuration
|
||||
make-mcron-configuration
|
||||
mcron-configuration?
|
||||
(mcron mcron-configuration-mcron ;package
|
||||
(default mcron2))
|
||||
(jobs mcron-configuration-jobs ;list of <mcron-job>
|
||||
(default '())))
|
||||
|
||||
(define (job-file job)
|
||||
(scheme-file "mcron-job" job))
|
||||
|
||||
(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))
|
||||
|
||||
;; 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)))))))
|
||||
|
||||
(define mcron-service-type
|
||||
(service-type (name 'mcron)
|
||||
(extensions
|
||||
(list (service-extension shepherd-root-service-type
|
||||
mcron-shepherd-services)
|
||||
(service-extension profile-service-type
|
||||
(compose list
|
||||
mcron-configuration-mcron))))
|
||||
(compose concatenate)
|
||||
(extend (lambda (config jobs)
|
||||
(mcron-configuration
|
||||
(inherit config)
|
||||
(jobs (append (mcron-configuration-jobs config)
|
||||
jobs)))))))
|
||||
|
||||
(define* (mcron-service jobs #:optional (mcron mcron2))
|
||||
"Return an mcron service running @var{mcron} that schedules @var{jobs}, a
|
||||
list of gexps denoting mcron job specifications.
|
||||
|
||||
This is a shorthand for:
|
||||
@example
|
||||
(service mcron-service-type
|
||||
(mcron-configuration (mcron mcron) (jobs jobs)))
|
||||
@end example
|
||||
"
|
||||
(service mcron-service-type
|
||||
(mcron-configuration (mcron mcron) (jobs jobs))))
|
||||
|
||||
;;; mcron.scm ends here
|
||||
|
|
@ -24,6 +24,7 @@
|
|||
#:use-module (gnu system shadow)
|
||||
#:use-module (gnu system vm)
|
||||
#:use-module (gnu services)
|
||||
#:use-module (gnu services mcron)
|
||||
#:use-module (gnu services shepherd)
|
||||
#:use-module (guix gexp)
|
||||
#:use-module (guix store)
|
||||
|
|
@ -31,7 +32,8 @@
|
|||
#:use-module (guix packages)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:export (run-basic-test
|
||||
%test-basic-os))
|
||||
%test-basic-os
|
||||
%test-mcron))
|
||||
|
||||
(define %simple-os
|
||||
(operating-system
|
||||
|
|
@ -178,3 +180,105 @@ functionality tests.")
|
|||
;; 'system-qemu-image/shared-store-script'.
|
||||
(run-basic-test (virtualized-operating-system os '())
|
||||
#~(list #$run))))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Mcron.
|
||||
;;;
|
||||
|
||||
(define %mcron-os
|
||||
;; System with an mcron service, with one mcron job for "root" and one mcron
|
||||
;; job for an unprivileged user (note: #:user is an 'mcron2' thing.)
|
||||
(let ((job1 #~(job next-second-from
|
||||
(lambda ()
|
||||
(call-with-output-file "witness"
|
||||
(lambda (port)
|
||||
(display (list (getuid) (getgid)) port))))))
|
||||
(job2 #~(job next-second-from
|
||||
(lambda ()
|
||||
(call-with-output-file "witness"
|
||||
(lambda (port)
|
||||
(display (list (getuid) (getgid)) port))))
|
||||
#:user "alice"))
|
||||
(job3 #~(job next-second-from ;to test $PATH
|
||||
"touch witness-touch")))
|
||||
(operating-system
|
||||
(inherit %simple-os)
|
||||
(services (cons (mcron-service (list job1 job2 job3))
|
||||
(operating-system-user-services %simple-os))))))
|
||||
|
||||
(define (run-mcron-test name)
|
||||
(mlet* %store-monad ((os -> (marionette-operating-system
|
||||
%mcron-os
|
||||
#:imported-modules '((gnu services herd)
|
||||
(guix combinators))))
|
||||
(command (system-qemu-image/shared-store-script
|
||||
os #:graphic? #f)))
|
||||
(define test
|
||||
#~(begin
|
||||
(use-modules (gnu build marionette)
|
||||
(srfi srfi-64)
|
||||
(ice-9 match))
|
||||
|
||||
(define marionette
|
||||
(make-marionette (list #$command)))
|
||||
|
||||
(define (wait-for-file file)
|
||||
;; Wait until FILE exists in the guest; 'read' its content and
|
||||
;; return it.
|
||||
(marionette-eval
|
||||
`(let loop ((i 10))
|
||||
(cond ((file-exists? ,file)
|
||||
(call-with-input-file ,file read))
|
||||
((> i 0)
|
||||
(sleep 1)
|
||||
(loop (- i 1)))
|
||||
(else
|
||||
(error "file didn't show up" ,file))))
|
||||
marionette))
|
||||
|
||||
(mkdir #$output)
|
||||
(chdir #$output)
|
||||
|
||||
(test-begin "mcron")
|
||||
|
||||
(test-eq "service running"
|
||||
'running!
|
||||
(marionette-eval
|
||||
'(begin
|
||||
(use-modules (gnu services herd))
|
||||
(start-service 'mcron)
|
||||
'running!)
|
||||
marionette))
|
||||
|
||||
;; Make sure root's mcron job runs, has its cwd set to "/root", and
|
||||
;; runs with the right UID/GID.
|
||||
(test-equal "root's job"
|
||||
'(0 0)
|
||||
(wait-for-file "/root/witness"))
|
||||
|
||||
;; Likewise for Alice's job. We cannot know what its GID is since
|
||||
;; it's chosen by 'groupadd', but it's strictly positive.
|
||||
(test-assert "alice's job"
|
||||
(match (wait-for-file "/home/alice/witness")
|
||||
((1000 gid)
|
||||
(>= gid 100))))
|
||||
|
||||
;; Last, the job that uses a command; allows us to test whether
|
||||
;; $PATH is sane. (Note that 'marionette-eval' stringifies objects
|
||||
;; that don't have a read syntax, hence the string.)
|
||||
(test-equal "root's job with command"
|
||||
"#<eof>"
|
||||
(wait-for-file "/root/witness-touch"))
|
||||
|
||||
(test-end)
|
||||
(exit (= (test-runner-fail-count (test-runner-current)) 0))))
|
||||
|
||||
(gexp->derivation name test
|
||||
#:modules '((gnu build marionette)))))
|
||||
|
||||
(define %test-mcron
|
||||
(system-test
|
||||
(name "mcron")
|
||||
(description "Make sure the mcron service works as advertised.")
|
||||
(value (run-mcron-test name))))
|
||||
|
|
|
|||
Reference in a new issue