Merge branch 'master' into core-updates

1 files changed, 115 insertions, 0 deletions

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