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 2016-06-22 22:36:40 +02:00
parent 159daace2f
commit c311089b0b
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
4 changed files with 299 additions and 1 deletions

View File

@ -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

View File

@ -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
View 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

View File

@ -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))))