gnu/services/mcron.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (gnu services mcron)
  20   #:use-module (gnu services)
  21   #:use-module (gnu services base)
  22   #:use-module (gnu services shepherd)
  23   #:autoload   (gnu packages guile-xyz) (mcron)
  24   #:use-module (guix deprecation)
  25   #:use-module (guix records)
  26   #:use-module (guix gexp)
  27   #:use-module (srfi srfi-1)
  28   #:use-module (ice-9 match)
  29   #:use-module (ice-9 vlist)
  30   #:export (mcron-configuration
  31             mcron-configuration?
  32             mcron-configuration-mcron
  33             mcron-configuration-jobs
  34
  35             mcron-service-type
  36             mcron-service))
  37
  38 ;;; Commentary:
  39 ;;;
  40 ;;; This module implements a service that to run instances of GNU mcron, a
  41 ;;; periodic job execution daemon.  Example of a service:
  42 ;;
  43 ;;  (service mcron-service-type
  44 ;;           (mcron-configuration
  45 ;;            (jobs (list #~(job next-second-from
  46 ;;                               (lambda ()
  47 ;;                                 (call-with-output-file "/dev/console"
  48 ;;                                   (lambda (port)
  49 ;;                                     (display "hello!\n" port)))))))))
  50 ;;;
  51 ;;; Code:
  52
  53 (define-record-type* <mcron-configuration> mcron-configuration
  54   make-mcron-configuration
  55   mcron-configuration?
  56   (mcron             mcron-configuration-mcron    ;package
  57                      (default mcron))
  58   (jobs              mcron-configuration-jobs     ;list of <mcron-job>
  59                      (default '())))
  60
  61 (define (job-file job)
  62   (scheme-file "mcron-job" job))
  63
  64 (define (shepherd-schedule-action mcron files)
  65   "Return a Shepherd action that runs MCRON with '--schedule' for the given
  66 files."
  67   (shepherd-action
  68    (name 'schedule)
  69    (documentation
  70     "Display jobs that are going to be scheduled.")
  71    (procedure
  72     #~(lambda* (_ #:optional (n "5"))
  73         ;; XXX: This is a global side effect.
  74         (setenv "GUILE_AUTO_COMPILE" "0")
  75
  76         ;; Run 'mcron' in a pipe so we can explicitly redirect its output to
  77         ;; 'current-output-port', which at this stage is bound to the client
  78         ;; connection.
  79         (let ((pipe (open-pipe* OPEN_READ
  80                                 #$(file-append mcron "/bin/mcron")
  81                                 (string-append "--schedule=" n)
  82                                 #$@files)))
  83           (let loop ()
  84             (match (read-line pipe 'concat)
  85               ((? eof-object?)
  86                (catch 'system-error
  87                  (lambda ()
  88                    (zero? (close-pipe pipe)))
  89                  (lambda args
  90                    ;; There's a race with the SIGCHLD handler, which
  91                    ;; could call 'waitpid' before 'close-pipe' above does.  If
  92                    ;; we get ECHILD, that means we lost the race, but that's
  93                    ;; fine.
  94                    (or (= ECHILD (system-error-errno args))
  95                        (apply throw args)))))
  96               (line
  97                (display line)
  98                (loop)))))))))
  99
 100 (define mcron-shepherd-services
 101   (match-lambda
 102     (($ <mcron-configuration> mcron ())           ;nothing to do!
 103      '())
 104     (($ <mcron-configuration> mcron jobs)
 105      (let ((files (map job-file jobs)))
 106        (list (shepherd-service
 107               (provision '(mcron))
 108               (requirement '(user-processes))
 109               (modules `((srfi srfi-1)
 110                          (srfi srfi-26)
 111                          (ice-9 popen)            ;for the 'schedule' action
 112                          (ice-9 rdelim)
 113                          (ice-9 match)
 114                          ,@%default-modules))
 115               (start #~(make-forkexec-constructor
 116                         (list (string-append #$mcron "/bin/mcron") #$@files)
 117
 118                         ;; Disable auto-compilation of the job files and set a
 119                         ;; sane value for 'PATH'.
 120                         #:environment-variables
 121                         (cons* "GUILE_AUTO_COMPILE=0"
 122                                "PATH=/run/current-system/profile/bin"
 123                                (remove (cut string-prefix? "PATH=" <>)
 124                                        (environ)))))
 125               (stop #~(make-kill-destructor))
 126
 127               (actions
 128                (list (shepherd-schedule-action mcron files)))))))))
 129
 130 (define mcron-service-type
 131   (service-type (name 'mcron)
 132                 (extensions
 133                  (list (service-extension shepherd-root-service-type
 134                                           mcron-shepherd-services)
 135                        (service-extension profile-service-type
 136                                           (compose list
 137                                                    mcron-configuration-mcron))))
 138                 (compose concatenate)
 139                 (extend (lambda (config jobs)
 140                           (mcron-configuration
 141                            (inherit config)
 142                            (jobs (append (mcron-configuration-jobs config)
 143                                          jobs)))))
 144                 (default-value (mcron-configuration)))) ;empty job list
 145
 146 (define-deprecated (mcron-service jobs #:optional (mcron mcron))
 147   mcron-service-type
 148   "Return an mcron service running @var{mcron} that schedules @var{jobs}, a
 149 list of gexps denoting mcron job specifications.
 150
 151 This is a shorthand for:
 152 @example
 153   (service mcron-service-type
 154            (mcron-configuration (mcron mcron) (jobs jobs)))
 155 @end example
 156 "
 157   (service mcron-service-type
 158            (mcron-configuration (mcron mcron) (jobs jobs))))
 159
 160 ;;; mcron.scm ends here