From 7afbcbcd0e00d2db26f139363be81ca26a61095f Mon Sep 17 00:00:00 2001
From: Robert Vollmert <rob@vllmrt.net>
Date: Fri, 29 Nov 2019 19:07:22 +0100
Subject: [PATCH] services: Add scron.
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

It's a simple replacement for the mcron service.

If you have a mcron job definition like

(define cron-job
  #~(job "*/15 * * * *" #$(program-file ...)))

you can convert it into the valid scron job

(define cron-job
  (scron-job (schedule "/15 * * * *")
             (program-file ...)))

* gnu/services/scron.scm: New file.
* gnu/local.mk: Add it.
* gnu/tests/base.scm (%scron-os): New variable.
(run-scron-test): New procedure.
(%test-scron): New variable.
* doc/guix.texi: Add documentation for scron-service.

Signed-off-by: Ludovic Courtès <ludo@gnu.org>
---
 doc/guix.texi          |  77 +++++++++++++++++++++++++++++-
 gnu/local.mk           |   1 +
 gnu/services/scron.scm | 103 +++++++++++++++++++++++++++++++++++++++++
 gnu/tests/base.scm     |  86 ++++++++++++++++++++++++++++++++++
 4 files changed, 266 insertions(+), 1 deletion(-)
 create mode 100644 gnu/services/scron.scm

diff --git a/doc/guix.texi b/doc/guix.texi
index 446534c576..0fa8a9bd01 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -282,7 +282,7 @@ System Configuration
 Services
 
 * Base Services::               Essential system services.
-* Scheduled Job Execution::     The mcron service.
+* Scheduled Job Execution::     Cron services.
 * Log Rotation::                The rottlog service.
 * Networking Services::         Network setup, SSH daemon, etc.
 * X Window::                    Graphical display.
@@ -12899,6 +12899,81 @@ specifications,, mcron, GNU@tie{}mcron}).
 @end deftp
 
 
+@cindex scron
+@cindex scheduling jobs
+The @code{(gnu services scron)} module provides an interface to
+scron, a simple daemon to run jobs at scheduled times. scron is
+similar to the traditional Unix @command{cron} daemon;
+the main difference is that it is much simpler.
+
+Jobs are executed as root @i{via} the shell with working direction
+@code{/}.  Use @code{su} or corresponding Guile functions
+(@pxref{Processes,,, guile, GNU Guile Reference Manual}).
+
+The example below defines an operating system that runs the
+@command{updatedb} command (@pxref{Invoking updatedb,,, find, Finding
+Files}) daily:
+
+@lisp
+(use-modules (guix) (gnu) (gnu services scron))
+(use-package-modules base)
+
+(define updatedb-job
+  ;; Run 'updatedb' at 3AM every day.
+  (let* ((exp #~(begin
+                  (execl (string-append #$findutils "/bin/updatedb")
+                         "updatedb"
+                         "--prunepaths=/tmp /var/tmp /gnu/store")))
+         (script (program-file "updatedb-job" exp)))
+    (scron-job
+      (schedule "0 3 * * *")
+      (command  script))))
+
+(operating-system
+  ;; @dots{}
+  (services (cons (service scron-service-type
+                           (scron-configuration
+                            (jobs (list updatedb-job))))
+                  %base-services)))
+@end lisp
+
+@defvr {Scheme Variable} scron-service-type
+
+This is the type of the @code{scron} service, whose value is an
+@code{scron-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 additional
+mcron jobs to run.
+@end defvr
+
+@deftp {Data Type} scron-configuration
+Data type representing the configuration of scron.
+
+@table @asis
+@item @code{scron} (default: @var{scron})
+The scron package to use.
+
+@item @code{jobs}
+This is a list of scron jobs.
+@end table
+@end deftp
+
+@deftp {Data Type} scron-job
+Data type representing an scron job.
+
+@table @asis
+@item @code{schedule}
+The job schedule, in Vixie cron syntax. See the @code{scron(1)}
+man page for more information.
+
+@item @code{command}
+The shell command to run, as a value that lowers to a string.
+@end table
+@end deftp
+
+
 @node Log Rotation
 @subsection Log Rotation
 
diff --git a/gnu/local.mk b/gnu/local.mk
index 80ef0f04d0..4602e464f7 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -554,6 +554,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/services/nix.scm				\
   %D%/services/nfs.scm			\
   %D%/services/pam-mount.scm			\
+  %D%/services/scron.scm			\
   %D%/services/security-token.scm		\
   %D%/services/shepherd.scm			\
   %D%/services/sound.scm			\
diff --git a/gnu/services/scron.scm b/gnu/services/scron.scm
new file mode 100644
index 0000000000..b9b2983e96
--- /dev/null
+++ b/gnu/services/scron.scm
@@ -0,0 +1,103 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Robert Vollmert <rob@vllmrt.net>
+;;;
+;;; 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 scron)
+  #:use-module (gnu services)
+  #:use-module (gnu services shepherd)
+  #:autoload   (gnu packages suckless) (scron)
+  #:use-module (guix gexp)
+  #:use-module (guix records)
+  #:use-module (guix store)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:export (scron-configuration
+            scron-configuration?
+            scron-configuration-scron
+            scron-configuration-jobs
+
+            scron-job
+            scron-job?
+            scron-job-schedule
+            scron-job-command
+
+            scron-service-type
+            scron-service))
+
+;;; Commentary:
+;;;
+;;; This module implements a service to run instances of scron, a
+;;; periodic job execution daemon.  Example of a service:
+;;
+;;  (service scron-service-type
+;;           (scron-configuration
+;;            (jobs (list (scron-job (schedule "*/15 * * * *")
+;;                                   (command  "echo hello!"))))))
+;;;
+;;; Code:
+
+(define-record-type* <scron-configuration> scron-configuration
+  make-scron-configuration
+  scron-configuration?
+  (scron             scron-configuration-scron    ;package
+                     (default scron))
+  (jobs              scron-configuration-jobs     ;list of <scron-job>
+                     (default '())))
+
+(define-record-type* <scron-job> scron-job
+  make-scron-job
+  scron-job?
+  (schedule scron-job-schedule)
+  (command  scron-job-command))
+
+(define (crontab jobs)
+  (apply mixed-text-file "crontab"
+    (concatenate
+      (map
+        (match-lambda
+          (($ <scron-job> schedule command)
+            (list schedule " " command "\n")))
+        jobs))))
+
+(define scron-shepherd-services
+  (match-lambda
+    (($ <scron-configuration> scron jobs)
+     (list
+       (shepherd-service
+        (provision '(scron))
+        (requirement '(user-processes))
+        (start #~(make-forkexec-constructor
+                  (list (string-append #$scron "/bin/crond")
+                        "-n" ; don't fork
+                        "-f" #$(crontab jobs))
+                  #:log-file "/var/log/scron.log"))
+        (stop #~(make-kill-destructor)))))))
+
+(define scron-service-type
+  (service-type (name 'scron)
+                (description
+                 "Run the scron job scheduling daemon.")
+                (extensions
+                 (list (service-extension shepherd-root-service-type
+                                          scron-shepherd-services)))
+                (compose concatenate)
+                (extend (lambda (config jobs)
+                          (scron-configuration
+                           (inherit config)
+                           (jobs (append (scron-configuration-jobs config)
+                                         jobs)))))
+                (default-value (scron-configuration))))
diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm
index a891711844..b80e77be66 100644
--- a/gnu/tests/base.scm
+++ b/gnu/tests/base.scm
@@ -28,6 +28,7 @@
   #:use-module (gnu services dbus)
   #:use-module (gnu services avahi)
   #:use-module (gnu services mcron)
+  #:use-module (gnu services scron)
   #:use-module (gnu services shepherd)
   #:use-module (gnu services networking)
   #:use-module (gnu packages base)
@@ -48,6 +49,7 @@
             %test-halt
             %test-cleanup
             %test-mcron
+            %test-scron
             %test-nss-mdns))
 
 (define %simple-os
@@ -720,6 +722,90 @@ non-ASCII names from /tmp.")
    (description "Make sure the mcron service works as advertised.")
    (value (run-mcron-test name))))
 
+
+;;;
+;;; Scron.
+;;;
+
+(define %scron-os
+  ;; System with an scron service, with one scron job for "root" and one scron
+  ;; job for an unprivileged user.
+  (let ((job1
+         (scron-job
+          (schedule "* * * * *")
+          (command  "(id -u; id -g) > witness")))
+        (job2
+         (scron-job
+          (schedule "* * * * *")
+          (command  "su -c '(id -u; id -g) > ~/witness' alice")))
+        (job3
+         (scron-job
+          (schedule "* * * * *")
+          (command  "touch witness-touch"))))
+    (simple-operating-system
+     (service scron-service-type
+              (scron-configuration (jobs (list job1 job2 job3)))))))
+
+(define (run-scron-test name)
+  (define os
+    (marionette-operating-system
+     %scron-os
+     #:imported-modules '((gnu services herd)
+                          (guix combinators))))
+
+  (define test
+    (with-imported-modules '((gnu build marionette))
+      #~(begin
+          (use-modules (gnu build marionette)
+                       (srfi srfi-64)
+                       (ice-9 match))
+
+          (define marionette
+            (make-marionette (list #$(virtual-machine os))))
+
+          (mkdir #$output)
+          (chdir #$output)
+
+          (test-begin "scron")
+
+          (test-assert "service running"
+            (marionette-eval
+             '(begin
+                (use-modules (gnu services herd))
+                (start-service 'scron))
+             marionette))
+
+          ;; Make sure root's scron job runs, has its cwd set to "/", and
+          ;; runs with the right UID/GID.
+          (test-equal "root's job"
+            '(0 0)
+            (wait-for-file "/witness" marionette))
+
+          ;; 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" marionette)
+              ((1000 gid)
+               (>= gid 100))))
+
+          ;; Last, the job that uses a command; allows us to test whether
+          ;; $PATH is sane.
+          (test-equal "root's job with command"
+            ""
+            (wait-for-file "/witness-touch" marionette
+                           #:read '(@ (ice-9 rdelim) read-string)))
+
+          (test-end)
+          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+
+  (gexp->derivation name test))
+
+(define %test-scron
+  (system-test
+   (name "scron")
+   (description "Make sure the scron service works as advertised.")
+   (value (run-scron-test name))))
+
 
 ;;;
 ;;; Avahi and NSS-mDNS.
-- 
2.24.0

