1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
4 ;;; This file is part of GNU Guix.
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.
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.
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/>.
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
31 mcron-configuration-mcron
32 mcron-configuration-jobs
38 ;;; This module implements a service that to run instances of GNU mcron, a
39 ;;; periodic job execution daemon. Example of a service:
41 ;; (service mcron-service-type
42 ;; (mcron-configuration
43 ;; (jobs (list #~(job next-second-from
45 ;; (call-with-output-file "/dev/console"
47 ;; (display "hello!\n" port)))))))))
51 (define-record-type* <mcron-configuration> mcron-configuration
52 make-mcron-configuration
54 (mcron mcron-configuration-mcron ;file-like
56 (jobs mcron-configuration-jobs ;list of <mcron-job>
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))
67 (use-modules (guix build utils))
69 (call-with-output-file "prologue"
71 ;; This prologue allows 'mcron --schedule' to
72 ;; proceed no matter what #:user option is passed
75 (const (getpwuid (getuid))))
78 (call-with-output-file "job"
82 (invoke #+(file-append mcron "/bin/mcron")
83 "--schedule=20" "prologue" "job")
84 (copy-file "job" #$output)))
85 #:options '(#:env-vars (("COLUMNS" . "150")))))
87 (map validated-file jobs))
89 (define (shepherd-schedule-action mcron files)
90 "Return a Shepherd action that runs MCRON with '--schedule' for the given
95 "Display jobs that are going to be scheduled.")
97 #~(lambda* (_ #:optional (n "5"))
98 ;; XXX: This is a global side effect.
99 (setenv "GUILE_AUTO_COMPILE" "0")
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
104 (let ((pipe (open-pipe* OPEN_READ
105 #$(file-append mcron "/bin/mcron")
106 (string-append "--schedule=" n)
109 (match (read-line pipe 'concat)
113 (zero? (close-pipe pipe)))
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
119 (or (= ECHILD (system-error-errno args))
120 (apply throw args)))))
125 (define mcron-shepherd-services
127 (($ <mcron-configuration> mcron ()) ;nothing to do!
129 (($ <mcron-configuration> mcron jobs)
130 (let ((files (job-files mcron jobs)))
131 (list (shepherd-service
133 (requirement '(user-processes))
134 (modules `((srfi srfi-1)
136 (ice-9 popen) ;for the 'schedule' action
140 (start #~(make-forkexec-constructor
141 (list (string-append #$mcron "/bin/mcron") #$@files)
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=" <>)
151 #:log-file "/var/log/mcron.log"))
152 (stop #~(make-kill-destructor))
155 (list (shepherd-schedule-action mcron files)))))))))
157 (define mcron-service-type
158 (service-type (name 'mcron)
160 "Run the mcron job scheduling daemon.")
162 (list (service-extension shepherd-root-service-type
163 mcron-shepherd-services)
164 (service-extension profile-service-type
166 mcron-configuration-mcron))))
167 (compose concatenate)
168 (extend (lambda (config jobs)
171 (jobs (append (mcron-configuration-jobs config)
173 (default-value (mcron-configuration)))) ;empty job list
175 ;;; mcron.scm ends here