aboutsummaryrefslogtreecommitdiff
path: root/gnu
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2016-06-22 22:36:40 +0200
committerLudovic Courtès <ludo@gnu.org>2016-06-22 22:56:06 +0200
commitc311089b0b19f094e44d3f858c29f77d757332d1 (patch)
treecc96471da3dcaaefebc1e9aba35aa5634461918b /gnu
parent159daace2fc5a35795b82bdf5dbe02d5a6af6acd (diff)
downloadguix-c311089b0b19f094e44d3f858c29f77d757332d1.tar
guix-c311089b0b19f094e44d3f858c29f77d757332d1.tar.gz
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.
Diffstat (limited to 'gnu')
-rw-r--r--gnu/local.mk1
-rw-r--r--gnu/services/mcron.scm115
-rw-r--r--gnu/tests/base.scm106
3 files changed, 221 insertions, 1 deletions
diff --git a/gnu/local.mk b/gnu/local.mk
index ab0cf49b24..3e0082b8fa 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -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 \
diff --git a/gnu/services/mcron.scm b/gnu/services/mcron.scm
new file mode 100644
index 0000000000..313c8364f8
--- /dev/null
+++ b/gnu/services/mcron.scm
@@ -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
diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm
index 3dfa28f7f5..8b1fefe9f8 100644
--- a/gnu/tests/base.scm
+++ b/gnu/tests/base.scm
@@ -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))))