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.
2024-12-24 05:18:07 -05:00 · 2016-06-22 22:36:40 +02:00 · 2016-06-22 22:36:40 +02:00 · c311089b0b
commit c311089b0b
parent 159daace2f
4 changed files with 299 additions and 1 deletions
--- a/doc/guix.texi
+++ b/doc/guix.texi
@ -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

--- 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				\
--- a/gnu/services/mcron.scm
+++ 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
--- a/gnu/tests/base.scm
+++ b/gnu/tests/base.scm
@ -24,6 +24,7 @@ (define-module (gnu tests base)
  #: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 @@ (define-module (gnu tests base)
  #: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 @@ (define %test-basic-os
      ;; '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))))