gnu/services/mcron.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016, 2017, 2018, 2019, 2020 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 shepherd)
  22   #:use-module (gnu packages guile-xyz)
  23   #:use-module (guix deprecation)
  24   #:use-module (guix records)
  25   #:use-module (guix gexp)
  26   #:use-module (srfi srfi-1)
  27   #:use-module (ice-9 match)
  28   #:use-module (ice-9 vlist)
  29   #:export (mcron-configuration
  30             mcron-configuration?
  31             mcron-configuration-mcron
  32             mcron-configuration-jobs
  33
  34             mcron-service-type))
  35
  36 ;;; Commentary:
  37 ;;;
  38 ;;; This module implements a service that to run instances of GNU mcron, a
  39 ;;; periodic job execution daemon.  Example of a service:
  40 ;;
  41 ;;  (service mcron-service-type
  42 ;;           (mcron-configuration
  43 ;;            (jobs (list #~(job next-second-from
  44 ;;                               (lambda ()
  45 ;;                                 (call-with-output-file "/dev/console"
  46 ;;                                   (lambda (port)
  47 ;;                                     (display "hello!\n" port)))))))))
  48 ;;;
  49 ;;; Code:
  50
  51 (define-record-type* <mcron-configuration> mcron-configuration
  52   make-mcron-configuration
  53   mcron-configuration?
  54   (mcron             mcron-configuration-mcron    ;file-like
  55                      (default mcron))
  56   (jobs              mcron-configuration-jobs     ;list of <mcron-job>
  57                      (default '())))
  58
  59 (define (job-files mcron jobs)
  60   "Return a list of file-like object for JOBS, a list of gexps."
  61   (define (validated-file job)
  62     ;; This procedure behaves like 'scheme-file' but it runs 'mcron
  63     ;; --schedule' to detect any error in JOB.
  64     (computed-file "mcron-job"
  65                    (with-imported-modules '((guix build utils))
  66                      #~(begin
  67                          (use-modules (guix build utils))
  68
  69                          (call-with-output-file "prologue"
  70                            (lambda (port)
  71                              ;; This prologue allows 'mcron --schedule' to
  72                              ;; proceed no matter what #:user option is passed
  73                              ;; to 'job'.
  74                              (write '(set! getpw
  75                                        (const (getpwuid (getuid))))
  76                                     port)))
  77
  78                          (call-with-output-file "job"
  79                            (lambda (port)
  80                              (write '#$job port)))
  81
  82                          (invoke #+(file-append mcron "/bin/mcron")
  83                                  "--schedule=20" "prologue" "job")
  84                          (copy-file "job" #$output)))
  85                    #:options '(#:env-vars (("COLUMNS" . "150")))))
  86
  87   (map validated-file jobs))
  88
  89 (define (shepherd-schedule-action mcron files)
  90   "Return a Shepherd action that runs MCRON with '--schedule' for the given
  91 files."
  92   (shepherd-action
  93    (name 'schedule)
  94    (documentation
  95     "Display jobs that are going to be scheduled.")
  96    (procedure
  97     #~(lambda* (_ #:optional (n "5"))
  98         ;; XXX: This is a global side effect.
  99         (setenv "GUILE_AUTO_COMPILE" "0")
 100
 101         ;; Run 'mcron' in a pipe so we can explicitly redirect its output to
 102         ;; 'current-output-port', which at this stage is bound to the client
 103         ;; connection.
 104         (let ((pipe (open-pipe* OPEN_READ
 105                                 #$(file-append mcron "/bin/mcron")
 106                                 (string-append "--schedule=" n)
 107                                 #$@files)))
 108           (let loop ()
 109             (match (read-line pipe 'concat)
 110               ((? eof-object?)
 111                (catch 'system-error
 112                  (lambda ()
 113                    (zero? (close-pipe pipe)))
 114                  (lambda args
 115                    ;; There's a race with the SIGCHLD handler, which
 116                    ;; could call 'waitpid' before 'close-pipe' above does.  If
 117                    ;; we get ECHILD, that means we lost the race, but that's
 118                    ;; fine.
 119                    (or (= ECHILD (system-error-errno args))
 120                        (apply throw args)))))
 121               (line
 122                (display line)
 123                (loop)))))))))
 124
 125 (define mcron-shepherd-services
 126   (match-lambda
 127     (($ <mcron-configuration> mcron ())           ;nothing to do!
 128      '())
 129     (($ <mcron-configuration> mcron jobs)
 130      (let ((files (job-files mcron jobs)))
 131        (list (shepherd-service
 132               (provision '(mcron))
 133               (requirement '(user-processes))
 134               (modules `((srfi srfi-1)
 135                          (srfi srfi-26)
 136                          (ice-9 popen)            ;for the 'schedule' action
 137                          (ice-9 rdelim)
 138                          (ice-9 match)
 139                          ,@%default-modules))
 140               (start #~(make-forkexec-constructor
 141                         (list (string-append #$mcron "/bin/mcron") #$@files)
 142
 143                         ;; Disable auto-compilation of the job files and set a
 144                         ;; sane value for 'PATH'.
 145                         #:environment-variables
 146                         (cons* "GUILE_AUTO_COMPILE=0"
 147                                "PATH=/run/current-system/profile/bin"
 148                                (remove (cut string-prefix? "PATH=" <>)
 149                                        (environ)))
 150
 151                         #:log-file "/var/log/mcron.log"))
 152               (stop #~(make-kill-destructor))
 153
 154               (actions
 155                (list (shepherd-schedule-action mcron files)))))))))
 156
 157 (define mcron-service-type
 158   (service-type (name 'mcron)
 159                 (description
 160                  "Run the mcron job scheduling daemon.")
 161                 (extensions
 162                  (list (service-extension shepherd-root-service-type
 163                                           mcron-shepherd-services)
 164                        (service-extension profile-service-type
 165                                           (compose list
 166                                                    mcron-configuration-mcron))))
 167                 (compose concatenate)
 168                 (extend (lambda (config jobs)
 169                           (mcron-configuration
 170                            (inherit config)
 171                            (jobs (append (mcron-configuration-jobs config)
 172                                          jobs)))))
 173                 (default-value (mcron-configuration)))) ;empty job list
 174
 175 ;;; mcron.scm ends here