Commit | Line | Data |
---|---|---|
db4fdc04 | 1 | ;;; GNU Guix --- Functional package management for GNU |
33033a62 | 2 | ;;; Copyright © 2013, 2014, 2015, 2016, 2018 Ludovic Courtès <ludo@gnu.org> |
750a4239 | 3 | ;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org> |
4245ddcb | 4 | ;;; Copyright © 2018 Carlo Zancanaro <carlo@zancanaro.id.au> |
db4fdc04 LC |
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 | ||
0190c1c0 | 21 | (define-module (gnu services shepherd) |
116244df LC |
22 | #:use-module (guix ui) |
23 | #:use-module (guix sets) | |
b5f4e686 | 24 | #:use-module (guix gexp) |
e87f0591 | 25 | #:use-module (guix store) |
0adfe95a | 26 | #:use-module (guix records) |
e87f0591 | 27 | #:use-module (guix derivations) ;imported-modules, etc. |
db4fdc04 | 28 | #:use-module (gnu services) |
7b44cae5 | 29 | #:use-module (gnu services herd) |
0adfe95a | 30 | #:use-module (gnu packages admin) |
db4fdc04 | 31 | #:use-module (ice-9 match) |
80a67734 | 32 | #:use-module (ice-9 vlist) |
db4fdc04 | 33 | #:use-module (srfi srfi-1) |
80a67734 | 34 | #:use-module (srfi srfi-26) |
116244df LC |
35 | #:use-module (srfi srfi-34) |
36 | #:use-module (srfi srfi-35) | |
d4053c71 AK |
37 | #:export (shepherd-root-service-type |
38 | %shepherd-root-service | |
39 | shepherd-service-type | |
40 | ||
41 | shepherd-service | |
42 | shepherd-service? | |
43 | shepherd-service-documentation | |
44 | shepherd-service-provision | |
240b57f0 | 45 | shepherd-service-canonical-name |
d4053c71 AK |
46 | shepherd-service-requirement |
47 | shepherd-service-respawn? | |
48 | shepherd-service-start | |
49 | shepherd-service-stop | |
50 | shepherd-service-auto-start? | |
51 | shepherd-service-modules | |
fae685b9 | 52 | |
70138308 LC |
53 | shepherd-action |
54 | shepherd-action? | |
55 | shepherd-action-name | |
56 | shepherd-action-documentation | |
57 | shepherd-action-procedure | |
58 | ||
fae685b9 | 59 | %default-modules |
80a67734 | 60 | |
240b57f0 | 61 | shepherd-service-file |
a56c4eb8 | 62 | %containerized-shepherd-service |
240b57f0 | 63 | |
a5d78eb6 | 64 | shepherd-service-lookup-procedure |
7b44cae5 LC |
65 | shepherd-service-back-edges |
66 | shepherd-service-upgrade)) | |
db4fdc04 LC |
67 | |
68 | ;;; Commentary: | |
69 | ;;; | |
fe1ad5f5 | 70 | ;;; Instantiating system services as a shepherd configuration file. |
db4fdc04 LC |
71 | ;;; |
72 | ;;; Code: | |
73 | ||
0adfe95a | 74 | |
d4053c71 | 75 | (define (shepherd-boot-gexp services) |
378daa8c LC |
76 | #~(begin |
77 | ;; Keep track of the booted system. | |
78 | (false-if-exception (delete-file "/run/booted-system")) | |
79 | (symlink (readlink "/run/current-system") | |
80 | "/run/booted-system") | |
0adfe95a | 81 | |
378daa8c LC |
82 | ;; Close any remaining open file descriptors to be on the safe |
83 | ;; side. This must be the very last thing we do, because | |
84 | ;; Guile has internal FDs such as 'sleep_pipe' that need to be | |
85 | ;; alive. | |
86 | (let loop ((fd 3)) | |
87 | (when (< fd 1024) | |
88 | (false-if-exception (close-fdes fd)) | |
89 | (loop (+ 1 fd)))) | |
0adfe95a | 90 | |
378daa8c LC |
91 | ;; Start shepherd. |
92 | (execl #$(file-append shepherd "/bin/shepherd") | |
93 | "shepherd" "--config" | |
94 | #$(shepherd-configuration-file services)))) | |
0adfe95a | 95 | |
d4053c71 | 96 | (define shepherd-root-service-type |
0adfe95a | 97 | (service-type |
d4053c71 AK |
98 | (name 'shepherd-root) |
99 | ;; Extending the root shepherd service (aka. PID 1) happens by | |
100 | ;; concatenating the list of services provided by the extensions. | |
0adfe95a LC |
101 | (compose concatenate) |
102 | (extend append) | |
d4053c71 AK |
103 | (extensions (list (service-extension boot-service-type |
104 | shepherd-boot-gexp) | |
c273d81b | 105 | (service-extension profile-service-type |
34044d55 | 106 | (const (list shepherd))))))) |
0adfe95a | 107 | |
d4053c71 AK |
108 | (define %shepherd-root-service |
109 | ;; The root shepherd service, aka. PID 1. Its parameter is a list of | |
110 | ;; <shepherd-service> objects. | |
111 | (service shepherd-root-service-type '())) | |
0adfe95a | 112 | |
88cd7bbd LC |
113 | (define-syntax shepherd-service-type |
114 | (syntax-rules () | |
115 | "Return a <service-type> denoting a simple shepherd service--i.e., the type | |
116 | for a service that extends SHEPHERD-ROOT-SERVICE-TYPE and nothing else. When | |
117 | DEFAULT is given, use it as the service's default value." | |
118 | ((_ service-name proc default) | |
119 | (service-type | |
120 | (name service-name) | |
121 | (extensions | |
122 | (list (service-extension shepherd-root-service-type | |
123 | (compose list proc)))) | |
124 | (default-value default))) | |
125 | ((_ service-name proc) | |
126 | (service-type | |
127 | (name service-name) | |
128 | (extensions | |
129 | (list (service-extension shepherd-root-service-type | |
130 | (compose list proc)))))))) | |
0adfe95a | 131 | |
fae685b9 LC |
132 | (define %default-imported-modules |
133 | ;; Default set of modules imported for a service's consumption. | |
134 | '((guix build utils) | |
479b417b | 135 | (guix build syscalls))) |
fae685b9 LC |
136 | |
137 | (define %default-modules | |
138 | ;; Default set of modules visible in a service's file. | |
34044d55 | 139 | `((shepherd service) |
fae685b9 | 140 | (oop goops) |
fae685b9 | 141 | (guix build utils) |
479b417b | 142 | (guix build syscalls))) |
fae685b9 | 143 | |
d4053c71 AK |
144 | (define-record-type* <shepherd-service> |
145 | shepherd-service make-shepherd-service | |
146 | shepherd-service? | |
147 | (documentation shepherd-service-documentation ;string | |
0adfe95a | 148 | (default "[No documentation.]")) |
d4053c71 AK |
149 | (provision shepherd-service-provision) ;list of symbols |
150 | (requirement shepherd-service-requirement ;list of symbols | |
0adfe95a | 151 | (default '())) |
d4053c71 | 152 | (respawn? shepherd-service-respawn? ;Boolean |
0adfe95a | 153 | (default #t)) |
d4053c71 AK |
154 | (start shepherd-service-start) ;g-expression (procedure) |
155 | (stop shepherd-service-stop ;g-expression (procedure) | |
0adfe95a | 156 | (default #~(const #f))) |
70138308 LC |
157 | (actions shepherd-service-actions ;list of <shepherd-action> |
158 | (default '())) | |
d4053c71 | 159 | (auto-start? shepherd-service-auto-start? ;Boolean |
fae685b9 | 160 | (default #t)) |
d4053c71 | 161 | (modules shepherd-service-modules ;list of module names |
a91c3fc7 | 162 | (default %default-modules))) |
0adfe95a | 163 | |
70138308 LC |
164 | (define-record-type* <shepherd-action> |
165 | shepherd-action make-shepherd-action | |
166 | shepherd-action? | |
167 | (name shepherd-action-name) ;symbol | |
168 | (procedure shepherd-action-procedure) ;gexp | |
169 | (documentation shepherd-action-documentation)) ;string | |
170 | ||
240b57f0 LC |
171 | (define (shepherd-service-canonical-name service) |
172 | "Return the 'canonical name' of SERVICE." | |
173 | (first (shepherd-service-provision service))) | |
0adfe95a | 174 | |
2d2651e7 | 175 | (define (assert-valid-graph services) |
d4053c71 AK |
176 | "Raise an error if SERVICES does not define a valid shepherd service graph, |
177 | for instance if a service requires a nonexistent service, or if more than one | |
2d2651e7 | 178 | service uses a given name. |
116244df | 179 | |
d4053c71 AK |
180 | These are constraints that shepherd's 'register-service' verifies but we'd |
181 | better verify them here statically than wait until PID 1 halts with an | |
182 | assertion failure." | |
2d2651e7 LC |
183 | (define provisions |
184 | ;; The set of provisions (symbols). Bail out if a symbol is given more | |
185 | ;; than once. | |
186 | (fold (lambda (service set) | |
187 | (define (assert-unique symbol) | |
188 | (when (set-contains? set symbol) | |
189 | (raise (condition | |
190 | (&message | |
191 | (message | |
69daee23 | 192 | (format #f (G_ "service '~a' provided more than once") |
2d2651e7 LC |
193 | symbol))))))) |
194 | ||
d4053c71 AK |
195 | (for-each assert-unique (shepherd-service-provision service)) |
196 | (fold set-insert set (shepherd-service-provision service))) | |
197 | (setq 'shepherd) | |
2d2651e7 LC |
198 | services)) |
199 | ||
200 | (define (assert-satisfied-requirements service) | |
201 | ;; Bail out if the requirements of SERVICE aren't satisfied. | |
202 | (for-each (lambda (requirement) | |
203 | (unless (set-contains? provisions requirement) | |
204 | (raise (condition | |
205 | (&message | |
206 | (message | |
69daee23 | 207 | (format #f (G_ "service '~a' requires '~a', \ |
2c2ec261 | 208 | which is not provided by any service") |
d4053c71 | 209 | (match (shepherd-service-provision service) |
2d2651e7 LC |
210 | ((head . _) head) |
211 | (_ service)) | |
212 | requirement))))))) | |
d4053c71 | 213 | (shepherd-service-requirement service))) |
2d2651e7 LC |
214 | |
215 | (for-each assert-satisfied-requirements services)) | |
116244df | 216 | |
d4053c71 | 217 | (define (shepherd-service-file-name service) |
fae685b9 LC |
218 | "Return the file name where the initialization code for SERVICE is to be |
219 | stored." | |
220 | (let ((provisions (string-join (map symbol->string | |
d4053c71 AK |
221 | (shepherd-service-provision service))))) |
222 | (string-append "shepherd-" | |
fae685b9 LC |
223 | (string-map (match-lambda |
224 | (#\/ #\-) | |
750a4239 | 225 | (#\ #\-) |
fae685b9 LC |
226 | (chr chr)) |
227 | provisions) | |
228 | ".scm"))) | |
229 | ||
d4053c71 | 230 | (define (shepherd-service-file service) |
fae685b9 | 231 | "Return a file defining SERVICE." |
33033a62 LC |
232 | (scheme-file (shepherd-service-file-name service) |
233 | (with-imported-modules %default-imported-modules | |
234 | #~(begin | |
235 | (use-modules #$@(shepherd-service-modules service)) | |
236 | ||
237 | (make <service> | |
238 | #:docstring '#$(shepherd-service-documentation service) | |
239 | #:provides '#$(shepherd-service-provision service) | |
240 | #:requires '#$(shepherd-service-requirement service) | |
241 | #:respawn? '#$(shepherd-service-respawn? service) | |
242 | #:start #$(shepherd-service-start service) | |
70138308 LC |
243 | #:stop #$(shepherd-service-stop service) |
244 | #:actions | |
245 | (make-actions | |
246 | #$@(map (match-lambda | |
247 | (($ <shepherd-action> name proc doc) | |
248 | #~(#$name #$doc #$proc))) | |
249 | (shepherd-service-actions service)))))))) | |
fae685b9 | 250 | |
fe1ad5f5 AK |
251 | (define (shepherd-configuration-file services) |
252 | "Return the shepherd configuration file for SERVICES." | |
2d2651e7 | 253 | (assert-valid-graph services) |
116244df | 254 | |
33033a62 | 255 | (let ((files (map shepherd-service-file services))) |
23ed63a1 LC |
256 | (define config |
257 | #~(begin | |
081bd3bd LC |
258 | (use-modules (srfi srfi-34) |
259 | (system repl error-handling)) | |
b9c7ed71 | 260 | |
234ea8a7 LC |
261 | ;; Arrange to spawn a REPL if something goes wrong. This is better |
262 | ;; than a kernel panic. | |
b9c7ed71 LC |
263 | (call-with-error-handling |
264 | (lambda () | |
234ea8a7 LC |
265 | (apply register-services (map primitive-load '#$files)) |
266 | ||
267 | ;; guix-daemon 0.6 aborts if 'PATH' is undefined, so work around | |
268 | ;; it. | |
269 | (setenv "PATH" "/run/current-system/profile/bin") | |
270 | ||
271 | (format #t "starting services...~%") | |
272 | (for-each (lambda (service) | |
273 | ;; In the Shepherd 0.3 the 'start' method can raise | |
274 | ;; '&action-runtime-error' if it fails, so protect | |
275 | ;; against it. (XXX: 'action-runtime-error?' is not | |
276 | ;; exported is 0.3, hence 'service-error?'.) | |
277 | (guard (c ((service-error? c) | |
278 | (format (current-error-port) | |
279 | "failed to start service '~a'~%" | |
280 | service))) | |
281 | (start service))) | |
282 | '#$(append-map shepherd-service-provision | |
283 | (filter shepherd-service-auto-start? | |
6ea6e147 LC |
284 | services))) |
285 | ||
286 | ;; Hang up stdin. At this point, we assume that 'start' methods | |
287 | ;; that required user interaction on the console (e.g., | |
288 | ;; 'cryptsetup open' invocations, post-fsck emergency REPL) have | |
289 | ;; completed. User interaction becomes impossible after this | |
290 | ;; call; this avoids situations where services wrongfully lead | |
291 | ;; PID 1 to read from stdin (the console), which users may not | |
292 | ;; have access to (see <https://bugs.gnu.org/23697>). | |
293 | (redirect-port (open-input-file "/dev/null") | |
294 | (current-input-port)))))) | |
23ed63a1 | 295 | |
33033a62 | 296 | (scheme-file "shepherd.conf" config))) |
db4fdc04 | 297 | |
a5d78eb6 LC |
298 | (define* (shepherd-service-lookup-procedure services |
299 | #:optional | |
300 | (provision | |
301 | shepherd-service-provision)) | |
302 | "Return a procedure that, when passed a symbol, return the item among | |
303 | SERVICES that provides this symbol. PROVISION must be a one-argument | |
304 | procedure that takes a service and returns the list of symbols it provides." | |
305 | (let ((services (fold (lambda (service result) | |
306 | (fold (cut vhash-consq <> service <>) | |
307 | result | |
308 | (provision service))) | |
309 | vlist-null | |
310 | services))) | |
311 | (lambda (name) | |
312 | (match (vhash-assq name services) | |
313 | ((_ . service) service) | |
314 | (#f #f))))) | |
315 | ||
6673bddc LC |
316 | (define* (shepherd-service-back-edges services |
317 | #:key | |
318 | (provision shepherd-service-provision) | |
319 | (requirement shepherd-service-requirement)) | |
d4053c71 | 320 | "Return a procedure that, when given a <shepherd-service> from SERVICES, |
6673bddc LC |
321 | returns the list of <shepherd-service> that depend on it. |
322 | ||
323 | Use PROVISION and REQUIREMENT as one-argument procedures that return the | |
324 | symbols provided/required by a service." | |
80a67734 | 325 | (define provision->service |
6673bddc | 326 | (shepherd-service-lookup-procedure services provision)) |
80a67734 LC |
327 | |
328 | (define edges | |
329 | (fold (lambda (service edges) | |
330 | (fold (lambda (requirement edges) | |
331 | (vhash-consq (provision->service requirement) service | |
332 | edges)) | |
333 | edges | |
6673bddc | 334 | (requirement service))) |
80a67734 LC |
335 | vlist-null |
336 | services)) | |
337 | ||
338 | (lambda (service) | |
339 | (vhash-foldq* cons '() service edges))) | |
340 | ||
a56c4eb8 LC |
341 | (define %containerized-shepherd-service |
342 | ;; XXX: This service works around a bug in the Shepherd 0.5.0: shepherd | |
343 | ;; calls reboot(2) (via 'disable-reboot-on-ctrl-alt-del') when it starts, | |
344 | ;; but in a container that fails with EINVAL. This was fixed in Shepherd | |
345 | ;; commit 92e806bac1abaeeaf5d60f0ab50d1ae85ba6a62f. | |
346 | (simple-service 'containerized-shepherd | |
347 | shepherd-root-service-type | |
348 | (list (shepherd-service | |
349 | (provision '(containerized-shepherd)) | |
350 | (start #~(lambda () | |
351 | (set! (@@ (shepherd) | |
352 | disable-reboot-on-ctrl-alt-del) | |
353 | (const #t)) | |
354 | #t)))))) | |
355 | ||
7b44cae5 LC |
356 | (define (shepherd-service-upgrade live target) |
357 | "Return two values: the subset of LIVE (a list of <live-service>) that needs | |
358 | to be unloaded, and the subset of TARGET (a list of <shepherd-service>) that | |
4245ddcb | 359 | need to be restarted to complete their upgrade." |
7b44cae5 LC |
360 | (define (essential? service) |
361 | (memq (first (live-service-provision service)) | |
362 | '(root shepherd))) | |
363 | ||
364 | (define lookup-target | |
365 | (shepherd-service-lookup-procedure target | |
366 | shepherd-service-provision)) | |
367 | ||
368 | (define lookup-live | |
369 | (shepherd-service-lookup-procedure live | |
370 | live-service-provision)) | |
371 | ||
372 | (define (running? service) | |
373 | (and=> (lookup-live (shepherd-service-canonical-name service)) | |
374 | live-service-running)) | |
375 | ||
7b44cae5 LC |
376 | (define live-service-dependents |
377 | (shepherd-service-back-edges live | |
378 | #:provision live-service-provision | |
379 | #:requirement live-service-requirement)) | |
380 | ||
381 | (define (obsolete? service) | |
382 | (match (lookup-target (first (live-service-provision service))) | |
383 | (#f (every obsolete? (live-service-dependents service))) | |
384 | (_ #f))) | |
385 | ||
4245ddcb CZ |
386 | (define to-restart |
387 | ;; Restart services that are currently running. | |
388 | (filter running? target)) | |
7b44cae5 LC |
389 | |
390 | (define to-unload | |
4245ddcb CZ |
391 | ;; Unload services that are no longer required. |
392 | (remove essential? (filter obsolete? live))) | |
7b44cae5 | 393 | |
4245ddcb | 394 | (values to-unload to-restart)) |
7b44cae5 | 395 | |
0190c1c0 | 396 | ;;; shepherd.scm ends here |