projects/guix·blob python-team · refs

217 lines · 9.2 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2016-2020, 2023 Ludovic Courtès <[email protected]>
3;;; Copyright © 2022 Maxim Cournoyer <[email protected]>
4;;; Copyright © 2023 Bruno Victal <[email protected]>
5;;;
6;;; This file is part of GNU Guix.
7;;;
8;;; GNU Guix is free software; you can redistribute it and/or modify it
9;;; under the terms of the GNU General Public License as published by
10;;; the Free Software Foundation; either version 3 of the License, or (at
11;;; your option) any later version.
12;;;
13;;; GNU Guix is distributed in the hope that it will be useful, but
14;;; WITHOUT ANY WARRANTY; without even the implied warranty of
15;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16;;; GNU General Public License for more details.
17;;;
18;;; You should have received a copy of the GNU General Public License
19;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
20
21;;; Commentary:
22;;;
23;;; This module implements a service that to run instances of GNU mcron, a
24;;; periodic job execution daemon. Example of a service:
25;;
26;; (service mcron-service-type
27;; (mcron-configuration
28;; (jobs (list #~(job next-second-from
29;; (lambda ()
30;; (call-with-output-file "/dev/console"
31;; (lambda (port)
32;; (display "hello!\n" port)))))))))
33;;;
34;;; Code:
35
36(define-module (gnu services mcron)
37 #:use-module (gnu services)
38 #:use-module (gnu services shepherd)
39 #:use-module (gnu packages guile-xyz)
40 #:use-module (guix records)
41 #:use-module (guix gexp)
42 #:use-module (srfi srfi-1)
43 #:use-module (ice-9 match)
44 #:use-module (ice-9 vlist)
45 #:export (mcron-configuration
46 mcron-configuration?
47 mcron-configuration-mcron
48 mcron-configuration-jobs
49 mcron-configuration-log?
50 mcron-configuration-log-file
51 mcron-configuration-log-format
52 mcron-configuration-date-format
53 mcron-configuration-home-service?
54
55 mcron-service-type))
56
57;; Configuration of mcron.
58;; XXX: 'define-configuration' cannot be used here due to the need for
59;; 'thunked' and 'innate' fields as well as 'this-mcron-configuration'.
60(define-record-type* <mcron-configuration> mcron-configuration
61 make-mcron-configuration
62 mcron-configuration?
63 this-mcron-configuration
64
65 (mcron mcron-configuration-mcron ;file-like
66 (default mcron))
67 (jobs mcron-configuration-jobs ;list of gexps
68 (default '()))
69 (log? mcron-configuration-log? ;Boolean
70 (default #t))
71 (log-file mcron-configuration-log-file ;string | gexp
72 (thunked)
73 (default
74 (if (mcron-configuration-home-service?
75 this-mcron-configuration)
76 #~(string-append %user-log-dir "/mcron.log")
77 "/var/log/mcron.log")))
78 (log-format mcron-configuration-log-format ;string
79 (default "~1@*~a ~a: ~a~%"))
80 (date-format mcron-configuration-date-format ;string | #f
81 (default #f))
82
83 (home-service? mcron-configuration-home-service?
84 (default for-home?) (innate)))
85
86(define (job-files mcron jobs)
87 "Return a list of file-like object for JOBS, a list of gexps."
88 (define (validated-file job)
89 ;; This procedure behaves like 'scheme-file' but it runs 'mcron
90 ;; --schedule' to detect any error in JOB.
91 (computed-file "mcron-job"
92 (with-imported-modules '((guix build utils))
93 #~(begin
94 (use-modules (guix build utils))
95
96 (call-with-output-file "prologue"
97 (lambda (port)
98 ;; This prologue allows 'mcron --schedule' to
99 ;; proceed no matter what #:user option is passed
100 ;; to 'job'.
101 (write '(set! getpw
102 (const (getpwuid (getuid))))
103 port)))
104
105 (call-with-output-file "job"
106 (lambda (port)
107 (write '#$job port)))
108
109 (invoke #+(file-append mcron "/bin/mcron")
110 "--schedule=20" "prologue" "job")
111 (copy-file "job" #$output)))
112 #:options '(#:env-vars (("COLUMNS" . "150")))))
113
114 (map validated-file jobs))
115
116(define (shepherd-schedule-action mcron files)
117 "Return a Shepherd action that runs MCRON with '--schedule' for the given
118files."
119 (shepherd-action
120 (name 'schedule)
121 (documentation
122 "Display jobs that are going to be scheduled.")
123 (procedure
124 #~(lambda* (_ #:optional (n "5"))
125 ;; XXX: This is a global side effect.
126 (setenv "GUILE_AUTO_COMPILE" "0")
127
128 ;; Run 'mcron' in a pipe so we can explicitly redirect its output to
129 ;; 'current-output-port', which at this stage is bound to the client
130 ;; connection.
131 (let ((pipe (open-pipe* OPEN_READ
132 #$(file-append mcron "/bin/mcron")
133 (string-append "--schedule=" n)
134 #$@files)))
135 (let loop ()
136 (match (read-line pipe 'concat)
137 ((? eof-object?)
138 (catch 'system-error
139 (lambda ()
140 (zero? (close-pipe pipe)))
141 (lambda args
142 ;; There's a race with the SIGCHLD handler, which
143 ;; could call 'waitpid' before 'close-pipe' above does. If
144 ;; we get ECHILD, that means we lost the race, but that's
145 ;; fine.
146 (or (= ECHILD (system-error-errno args))
147 (apply throw args)))))
148 (line
149 (display line)
150 (loop)))))))))
151
152(define (mcron-shepherd-services config)
153 (match-record config <mcron-configuration>
154 (mcron jobs log? log-file log-format date-format home-service?)
155 (if (eq? jobs '())
156 '() ;nothing to do
157 (let ((files (job-files mcron jobs)))
158 (list (shepherd-service
159 (provision '(mcron))
160 (requirement (if home-service?
161 '()
162 '(user-processes)))
163 (modules `((srfi srfi-1)
164 (srfi srfi-26)
165 (ice-9 popen) ;for the 'schedule' action
166 (ice-9 rdelim)
167 (ice-9 match)
168 ((shepherd support) #:hide (mkdir-p)) ;for '%user-log-dir'
169 ,@%default-modules))
170 (start #~(make-forkexec-constructor
171 (list #$(file-append mcron "/bin/mcron")
172 #$@(if log?
173 `("--log" "--log-format" ,log-format
174 ,@(if date-format
175 (list "--date-format"
176 date-format)
177 '()))
178 '())
179 #$@files)
180
181 ;; Disable auto-compilation of the job files and
182 ;; set a sane value for 'PATH'.
183 #:environment-variables
184 (cons* "GUILE_AUTO_COMPILE=0"
185 #$(if home-service?
186 '(environ)
187 '(cons*
188 "PATH=/run/current-system/profile/bin"
189 (remove (cut string-prefix? "PATH=" <>)
190 (environ)))))
191
192 #:log-file #$log-file))
193 (stop #~(make-kill-destructor))
194 (actions
195 (list (shepherd-schedule-action mcron files)))))))))
196
197(define mcron-service-type
198 (service-type (name 'mcron)
199 (description
200 "Run the mcron job scheduling daemon.")
201 (extensions
202 (list (service-extension shepherd-root-service-type
203 mcron-shepherd-services)
204 (service-extension profile-service-type
205 (compose list
206 mcron-configuration-mcron))))
207 (compose concatenate)
208 (extend (lambda (config jobs)
209 (mcron-configuration
210 (inherit config)
211 (home-service?
212 (mcron-configuration-home-service? config))
213 (jobs (append (mcron-configuration-jobs config)
214 jobs)))))
215 (default-value (mcron-configuration)))) ;empty job list
216
217;;; mcron.scm ends here