Commit | Line | Data |
---|---|---|
db4fdc04 | 1 | ;;; GNU Guix --- Functional package management for GNU |
0d22fc8d | 2 | ;;; Copyright © 2013, 2014, 2015, 2016, 2018, 2019, 2020, 2021 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> |
d2fc7646 | 5 | ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> |
95f72dcd | 6 | ;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> |
db4fdc04 LC |
7 | ;;; |
8 | ;;; This file is part of GNU Guix. | |
9 | ;;; | |
10 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
11 | ;;; under the terms of the GNU General Public License as published by | |
12 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
13 | ;;; your option) any later version. | |
14 | ;;; | |
15 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
16 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
18 | ;;; GNU General Public License for more details. | |
19 | ;;; | |
20 | ;;; You should have received a copy of the GNU General Public License | |
21 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
22 | ||
0190c1c0 | 23 | (define-module (gnu services shepherd) |
116244df LC |
24 | #:use-module (guix ui) |
25 | #:use-module (guix sets) | |
b5f4e686 | 26 | #:use-module (guix gexp) |
e87f0591 | 27 | #:use-module (guix store) |
0adfe95a | 28 | #:use-module (guix records) |
e87f0591 | 29 | #:use-module (guix derivations) ;imported-modules, etc. |
d2fc7646 | 30 | #:use-module (guix utils) |
db4fdc04 | 31 | #:use-module (gnu services) |
7b44cae5 | 32 | #:use-module (gnu services herd) |
0adfe95a | 33 | #:use-module (gnu packages admin) |
db4fdc04 | 34 | #:use-module (ice-9 match) |
80a67734 | 35 | #:use-module (ice-9 vlist) |
db4fdc04 | 36 | #:use-module (srfi srfi-1) |
80a67734 | 37 | #:use-module (srfi srfi-26) |
116244df LC |
38 | #:use-module (srfi srfi-34) |
39 | #:use-module (srfi srfi-35) | |
95f72dcd MD |
40 | #:export (shepherd-configuration |
41 | shepherd-configuration? | |
42 | shepherd-configuration-shepherd | |
43 | shepherd-configuration-services | |
44 | ||
45 | shepherd-root-service-type | |
d4053c71 AK |
46 | %shepherd-root-service |
47 | shepherd-service-type | |
48 | ||
49 | shepherd-service | |
50 | shepherd-service? | |
51 | shepherd-service-documentation | |
52 | shepherd-service-provision | |
240b57f0 | 53 | shepherd-service-canonical-name |
d4053c71 | 54 | shepherd-service-requirement |
95ef8b85 | 55 | shepherd-service-one-shot? |
d4053c71 AK |
56 | shepherd-service-respawn? |
57 | shepherd-service-start | |
58 | shepherd-service-stop | |
59 | shepherd-service-auto-start? | |
60 | shepherd-service-modules | |
fae685b9 | 61 | |
70138308 LC |
62 | shepherd-action |
63 | shepherd-action? | |
64 | shepherd-action-name | |
65 | shepherd-action-documentation | |
66 | shepherd-action-procedure | |
67 | ||
fae685b9 | 68 | %default-modules |
80a67734 | 69 | |
240b57f0 LC |
70 | shepherd-service-file |
71 | ||
a5d78eb6 | 72 | shepherd-service-lookup-procedure |
7b44cae5 | 73 | shepherd-service-back-edges |
10c41368 LC |
74 | shepherd-service-upgrade |
75 | ||
76 | user-processes-service-type)) | |
db4fdc04 LC |
77 | |
78 | ;;; Commentary: | |
79 | ;;; | |
fe1ad5f5 | 80 | ;;; Instantiating system services as a shepherd configuration file. |
db4fdc04 LC |
81 | ;;; |
82 | ;;; Code: | |
83 | ||
0adfe95a | 84 | |
95f72dcd MD |
85 | (define-record-type* <shepherd-configuration> |
86 | shepherd-configuration make-shepherd-configuration | |
87 | shepherd-configuration? | |
88 | (shepherd shepherd-configuration-shepherd | |
89 | (default shepherd)) ; package | |
90 | (services shepherd-configuration-services | |
91 | (default '()))) ; list of <shepherd-service> | |
92 | ||
93 | (define (shepherd-boot-gexp config) | |
94 | "Return a gexp starting the shepherd service." | |
95 | (let ((shepherd (shepherd-configuration-shepherd config)) | |
96 | (services (shepherd-configuration-services config))) | |
378daa8c LC |
97 | #~(begin |
98 | ;; Keep track of the booted system. | |
99 | (false-if-exception (delete-file "/run/booted-system")) | |
100 | (symlink (readlink "/run/current-system") | |
101 | "/run/booted-system") | |
0adfe95a | 102 | |
378daa8c LC |
103 | ;; Close any remaining open file descriptors to be on the safe |
104 | ;; side. This must be the very last thing we do, because | |
105 | ;; Guile has internal FDs such as 'sleep_pipe' that need to be | |
106 | ;; alive. | |
107 | (let loop ((fd 3)) | |
108 | (when (< fd 1024) | |
109 | (false-if-exception (close-fdes fd)) | |
110 | (loop (+ 1 fd)))) | |
0adfe95a | 111 | |
378daa8c LC |
112 | ;; Start shepherd. |
113 | (execl #$(file-append shepherd "/bin/shepherd") | |
114 | "shepherd" "--config" | |
95f72dcd MD |
115 | #$(shepherd-configuration-file services shepherd))))) |
116 | ||
117 | (define shepherd-packages | |
118 | (compose list shepherd-configuration-shepherd)) | |
0adfe95a | 119 | |
d4053c71 | 120 | (define shepherd-root-service-type |
0adfe95a | 121 | (service-type |
d4053c71 AK |
122 | (name 'shepherd-root) |
123 | ;; Extending the root shepherd service (aka. PID 1) happens by | |
124 | ;; concatenating the list of services provided by the extensions. | |
0adfe95a | 125 | (compose concatenate) |
95f72dcd MD |
126 | (extend (lambda (config extra-services) |
127 | (shepherd-configuration | |
128 | (inherit config) | |
129 | (services (append (shepherd-configuration-services config) | |
130 | extra-services))))) | |
d4053c71 AK |
131 | (extensions (list (service-extension boot-service-type |
132 | shepherd-boot-gexp) | |
c273d81b | 133 | (service-extension profile-service-type |
95f72dcd MD |
134 | shepherd-packages))) |
135 | (default-value (shepherd-configuration)) | |
dd0804c6 LC |
136 | (description |
137 | "Run the GNU Shepherd as PID 1---i.e., the operating system's first | |
138 | process. The Shepherd takes care of managing services such as daemons by | |
139 | ensuring they are started and stopped in the right order."))) | |
0adfe95a | 140 | |
d4053c71 | 141 | (define %shepherd-root-service |
95f72dcd MD |
142 | ;; The root shepherd service, aka. PID 1. Its parameter is a |
143 | ;; <shepherd-configuration>. | |
144 | (service shepherd-root-service-type)) | |
0adfe95a | 145 | |
88cd7bbd | 146 | (define-syntax shepherd-service-type |
0d22fc8d | 147 | (syntax-rules (description) |
88cd7bbd LC |
148 | "Return a <service-type> denoting a simple shepherd service--i.e., the type |
149 | for a service that extends SHEPHERD-ROOT-SERVICE-TYPE and nothing else. When | |
150 | DEFAULT is given, use it as the service's default value." | |
0d22fc8d | 151 | ((_ service-name proc default (description text)) |
88cd7bbd LC |
152 | (service-type |
153 | (name service-name) | |
154 | (extensions | |
155 | (list (service-extension shepherd-root-service-type | |
156 | (compose list proc)))) | |
0d22fc8d LC |
157 | (default-value default) |
158 | (description text))) | |
159 | ((_ service-name proc (description text)) | |
88cd7bbd LC |
160 | (service-type |
161 | (name service-name) | |
162 | (extensions | |
163 | (list (service-extension shepherd-root-service-type | |
0d22fc8d LC |
164 | (compose list proc)))) |
165 | (description text))))) | |
0adfe95a | 166 | |
fae685b9 LC |
167 | (define %default-imported-modules |
168 | ;; Default set of modules imported for a service's consumption. | |
169 | '((guix build utils) | |
479b417b | 170 | (guix build syscalls))) |
fae685b9 LC |
171 | |
172 | (define %default-modules | |
173 | ;; Default set of modules visible in a service's file. | |
34044d55 | 174 | `((shepherd service) |
fae685b9 | 175 | (oop goops) |
408ae72c | 176 | ((guix build utils) #:hide (delete)) |
479b417b | 177 | (guix build syscalls))) |
fae685b9 | 178 | |
d4053c71 AK |
179 | (define-record-type* <shepherd-service> |
180 | shepherd-service make-shepherd-service | |
181 | shepherd-service? | |
182 | (documentation shepherd-service-documentation ;string | |
0adfe95a | 183 | (default "[No documentation.]")) |
d4053c71 AK |
184 | (provision shepherd-service-provision) ;list of symbols |
185 | (requirement shepherd-service-requirement ;list of symbols | |
0adfe95a | 186 | (default '())) |
95ef8b85 LC |
187 | (one-shot? shepherd-service-one-shot? ;Boolean |
188 | (default #f)) | |
d4053c71 | 189 | (respawn? shepherd-service-respawn? ;Boolean |
0adfe95a | 190 | (default #t)) |
d4053c71 AK |
191 | (start shepherd-service-start) ;g-expression (procedure) |
192 | (stop shepherd-service-stop ;g-expression (procedure) | |
0adfe95a | 193 | (default #~(const #f))) |
70138308 LC |
194 | (actions shepherd-service-actions ;list of <shepherd-action> |
195 | (default '())) | |
d4053c71 | 196 | (auto-start? shepherd-service-auto-start? ;Boolean |
fae685b9 | 197 | (default #t)) |
d4053c71 | 198 | (modules shepherd-service-modules ;list of module names |
a91c3fc7 | 199 | (default %default-modules))) |
0adfe95a | 200 | |
70138308 LC |
201 | (define-record-type* <shepherd-action> |
202 | shepherd-action make-shepherd-action | |
203 | shepherd-action? | |
204 | (name shepherd-action-name) ;symbol | |
205 | (procedure shepherd-action-procedure) ;gexp | |
206 | (documentation shepherd-action-documentation)) ;string | |
207 | ||
240b57f0 LC |
208 | (define (shepherd-service-canonical-name service) |
209 | "Return the 'canonical name' of SERVICE." | |
210 | (first (shepherd-service-provision service))) | |
0adfe95a | 211 | |
2d2651e7 | 212 | (define (assert-valid-graph services) |
d4053c71 AK |
213 | "Raise an error if SERVICES does not define a valid shepherd service graph, |
214 | for instance if a service requires a nonexistent service, or if more than one | |
2d2651e7 | 215 | service uses a given name. |
116244df | 216 | |
d4053c71 AK |
217 | These are constraints that shepherd's 'register-service' verifies but we'd |
218 | better verify them here statically than wait until PID 1 halts with an | |
219 | assertion failure." | |
2d2651e7 LC |
220 | (define provisions |
221 | ;; The set of provisions (symbols). Bail out if a symbol is given more | |
222 | ;; than once. | |
223 | (fold (lambda (service set) | |
224 | (define (assert-unique symbol) | |
225 | (when (set-contains? set symbol) | |
226 | (raise (condition | |
227 | (&message | |
228 | (message | |
69daee23 | 229 | (format #f (G_ "service '~a' provided more than once") |
2d2651e7 LC |
230 | symbol))))))) |
231 | ||
d4053c71 AK |
232 | (for-each assert-unique (shepherd-service-provision service)) |
233 | (fold set-insert set (shepherd-service-provision service))) | |
234 | (setq 'shepherd) | |
2d2651e7 LC |
235 | services)) |
236 | ||
237 | (define (assert-satisfied-requirements service) | |
238 | ;; Bail out if the requirements of SERVICE aren't satisfied. | |
239 | (for-each (lambda (requirement) | |
240 | (unless (set-contains? provisions requirement) | |
241 | (raise (condition | |
242 | (&message | |
243 | (message | |
69daee23 | 244 | (format #f (G_ "service '~a' requires '~a', \ |
2c2ec261 | 245 | which is not provided by any service") |
d4053c71 | 246 | (match (shepherd-service-provision service) |
2d2651e7 LC |
247 | ((head . _) head) |
248 | (_ service)) | |
249 | requirement))))))) | |
d4053c71 | 250 | (shepherd-service-requirement service))) |
2d2651e7 LC |
251 | |
252 | (for-each assert-satisfied-requirements services)) | |
116244df | 253 | |
37b98e8c LC |
254 | (define %store-characters |
255 | ;; Valid store characters; see 'checkStoreName' in the daemon. | |
256 | (string->char-set | |
257 | "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz+-._?=")) | |
258 | ||
d4053c71 | 259 | (define (shepherd-service-file-name service) |
fae685b9 LC |
260 | "Return the file name where the initialization code for SERVICE is to be |
261 | stored." | |
262 | (let ((provisions (string-join (map symbol->string | |
d4053c71 AK |
263 | (shepherd-service-provision service))))) |
264 | (string-append "shepherd-" | |
37b98e8c LC |
265 | (string-map (lambda (chr) |
266 | (if (char-set-contains? %store-characters chr) | |
267 | chr | |
268 | #\-)) | |
fae685b9 LC |
269 | provisions) |
270 | ".scm"))) | |
271 | ||
d4053c71 | 272 | (define (shepherd-service-file service) |
fae685b9 | 273 | "Return a file defining SERVICE." |
33033a62 LC |
274 | (scheme-file (shepherd-service-file-name service) |
275 | (with-imported-modules %default-imported-modules | |
276 | #~(begin | |
277 | (use-modules #$@(shepherd-service-modules service)) | |
278 | ||
279 | (make <service> | |
280 | #:docstring '#$(shepherd-service-documentation service) | |
281 | #:provides '#$(shepherd-service-provision service) | |
282 | #:requires '#$(shepherd-service-requirement service) | |
95ef8b85 LC |
283 | |
284 | ;; The 'one-shot?' slot is new in Shepherd 0.6.0. | |
285 | ;; Older versions ignore it. | |
286 | #:one-shot? '#$(shepherd-service-one-shot? service) | |
287 | ||
33033a62 LC |
288 | #:respawn? '#$(shepherd-service-respawn? service) |
289 | #:start #$(shepherd-service-start service) | |
70138308 LC |
290 | #:stop #$(shepherd-service-stop service) |
291 | #:actions | |
292 | (make-actions | |
293 | #$@(map (match-lambda | |
294 | (($ <shepherd-action> name proc doc) | |
295 | #~(#$name #$doc #$proc))) | |
296 | (shepherd-service-actions service)))))))) | |
fae685b9 | 297 | |
95f72dcd | 298 | (define (scm->go file shepherd) |
63b0ce39 | 299 | "Compile FILE, which contains code to be loaded by shepherd's config file, |
95f72dcd | 300 | and return the resulting '.go' file. SHEPHERD is used as shepherd package." |
5e9cf933 | 301 | (let-system (system target) |
d2fc7646 JN |
302 | (with-extensions (list shepherd) |
303 | (computed-file (string-append (basename (scheme-file-name file) ".scm") | |
304 | ".go") | |
305 | #~(begin | |
306 | (use-modules (system base compile) | |
307 | (system base target)) | |
308 | ||
309 | ;; Do the same as the Shepherd's 'load-in-user-module'. | |
310 | (let ((env (make-fresh-user-module))) | |
311 | (module-use! env (resolve-interface '(oop goops))) | |
312 | (module-use! env (resolve-interface '(shepherd service))) | |
313 | (with-target #$(or target #~%host-type) | |
314 | (lambda _ | |
315 | (compile-file #$file #:output-file #$output | |
316 | #:env env))))) | |
317 | ||
318 | ;; It's faster to build locally than to download. | |
319 | #:options '(#:local-build? #t | |
320 | #:substitutable? #f))))) | |
63b0ce39 | 321 | |
95f72dcd MD |
322 | (define (shepherd-configuration-file services shepherd) |
323 | "Return the shepherd configuration file for SERVICES. SHEPHERD is used | |
324 | as shepherd package." | |
2d2651e7 | 325 | (assert-valid-graph services) |
116244df | 326 | |
95f72dcd MD |
327 | (let ((files (map shepherd-service-file services)) |
328 | (scm->go (cute scm->go <> shepherd))) | |
23ed63a1 LC |
329 | (define config |
330 | #~(begin | |
081bd3bd LC |
331 | (use-modules (srfi srfi-34) |
332 | (system repl error-handling)) | |
b9c7ed71 | 333 | |
8b9cad01 LC |
334 | ;; Specify the default environment visible to all the services. |
335 | ;; Without this statement, all the environment variables of PID 1 | |
336 | ;; are inherited by child services. | |
337 | (default-environment-variables | |
338 | '("PATH=/run/current-system/profile/bin")) | |
339 | ||
8aa752ba LC |
340 | ;; Booting off a DVD, especially on a slow machine, can make |
341 | ;; everything slow. Thus, increase the timeout compared to the | |
342 | ;; default 5s in the Shepherd 0.7.0. See | |
343 | ;; <https://bugs.gnu.org/40572>. | |
e3358a83 | 344 | (default-pid-file-timeout 30) |
8aa752ba | 345 | |
234ea8a7 LC |
346 | ;; Arrange to spawn a REPL if something goes wrong. This is better |
347 | ;; than a kernel panic. | |
b9c7ed71 LC |
348 | (call-with-error-handling |
349 | (lambda () | |
63b0ce39 | 350 | (apply register-services |
408ae72c LC |
351 | (parameterize ((current-warning-port |
352 | (%make-void-port "w"))) | |
353 | (map load-compiled '#$(map scm->go files)))))) | |
63b0ce39 | 354 | |
63b0ce39 LC |
355 | (format #t "starting services...~%") |
356 | (for-each (lambda (service) | |
357 | ;; In the Shepherd 0.3 the 'start' method can raise | |
358 | ;; '&action-runtime-error' if it fails, so protect | |
359 | ;; against it. (XXX: 'action-runtime-error?' is not | |
360 | ;; exported is 0.3, hence 'service-error?'.) | |
361 | (guard (c ((service-error? c) | |
362 | (format (current-error-port) | |
363 | "failed to start service '~a'~%" | |
364 | service))) | |
365 | (start service))) | |
366 | '#$(append-map shepherd-service-provision | |
367 | (filter shepherd-service-auto-start? | |
368 | services))) | |
369 | ||
370 | ;; Hang up stdin. At this point, we assume that 'start' methods | |
371 | ;; that required user interaction on the console (e.g., | |
372 | ;; 'cryptsetup open' invocations, post-fsck emergency REPL) have | |
373 | ;; completed. User interaction becomes impossible after this | |
374 | ;; call; this avoids situations where services wrongfully lead | |
375 | ;; PID 1 to read from stdin (the console), which users may not | |
376 | ;; have access to (see <https://bugs.gnu.org/23697>). | |
377 | (redirect-port (open-input-file "/dev/null") | |
378 | (current-input-port)))) | |
23ed63a1 | 379 | |
33033a62 | 380 | (scheme-file "shepherd.conf" config))) |
db4fdc04 | 381 | |
a5d78eb6 LC |
382 | (define* (shepherd-service-lookup-procedure services |
383 | #:optional | |
384 | (provision | |
385 | shepherd-service-provision)) | |
386 | "Return a procedure that, when passed a symbol, return the item among | |
387 | SERVICES that provides this symbol. PROVISION must be a one-argument | |
388 | procedure that takes a service and returns the list of symbols it provides." | |
389 | (let ((services (fold (lambda (service result) | |
390 | (fold (cut vhash-consq <> service <>) | |
391 | result | |
392 | (provision service))) | |
393 | vlist-null | |
394 | services))) | |
395 | (lambda (name) | |
396 | (match (vhash-assq name services) | |
397 | ((_ . service) service) | |
398 | (#f #f))))) | |
399 | ||
6673bddc LC |
400 | (define* (shepherd-service-back-edges services |
401 | #:key | |
402 | (provision shepherd-service-provision) | |
403 | (requirement shepherd-service-requirement)) | |
d4053c71 | 404 | "Return a procedure that, when given a <shepherd-service> from SERVICES, |
6673bddc LC |
405 | returns the list of <shepherd-service> that depend on it. |
406 | ||
407 | Use PROVISION and REQUIREMENT as one-argument procedures that return the | |
408 | symbols provided/required by a service." | |
80a67734 | 409 | (define provision->service |
6673bddc | 410 | (shepherd-service-lookup-procedure services provision)) |
80a67734 LC |
411 | |
412 | (define edges | |
413 | (fold (lambda (service edges) | |
414 | (fold (lambda (requirement edges) | |
415 | (vhash-consq (provision->service requirement) service | |
416 | edges)) | |
417 | edges | |
6673bddc | 418 | (requirement service))) |
80a67734 LC |
419 | vlist-null |
420 | services)) | |
421 | ||
422 | (lambda (service) | |
423 | (vhash-foldq* cons '() service edges))) | |
424 | ||
7b44cae5 LC |
425 | (define (shepherd-service-upgrade live target) |
426 | "Return two values: the subset of LIVE (a list of <live-service>) that needs | |
427 | to be unloaded, and the subset of TARGET (a list of <shepherd-service>) that | |
4245ddcb | 428 | need to be restarted to complete their upgrade." |
7b44cae5 LC |
429 | (define (essential? service) |
430 | (memq (first (live-service-provision service)) | |
431 | '(root shepherd))) | |
432 | ||
433 | (define lookup-target | |
434 | (shepherd-service-lookup-procedure target | |
435 | shepherd-service-provision)) | |
436 | ||
437 | (define lookup-live | |
438 | (shepherd-service-lookup-procedure live | |
439 | live-service-provision)) | |
440 | ||
441 | (define (running? service) | |
442 | (and=> (lookup-live (shepherd-service-canonical-name service)) | |
443 | live-service-running)) | |
444 | ||
7b44cae5 LC |
445 | (define live-service-dependents |
446 | (shepherd-service-back-edges live | |
447 | #:provision live-service-provision | |
448 | #:requirement live-service-requirement)) | |
449 | ||
450 | (define (obsolete? service) | |
451 | (match (lookup-target (first (live-service-provision service))) | |
452 | (#f (every obsolete? (live-service-dependents service))) | |
453 | (_ #f))) | |
454 | ||
4245ddcb CZ |
455 | (define to-restart |
456 | ;; Restart services that are currently running. | |
457 | (filter running? target)) | |
7b44cae5 LC |
458 | |
459 | (define to-unload | |
4245ddcb CZ |
460 | ;; Unload services that are no longer required. |
461 | (remove essential? (filter obsolete? live))) | |
7b44cae5 | 462 | |
4245ddcb | 463 | (values to-unload to-restart)) |
7b44cae5 | 464 | |
10c41368 LC |
465 | \f |
466 | ;;; | |
467 | ;;; User processes. | |
468 | ;;; | |
469 | ||
470 | (define %do-not-kill-file | |
471 | ;; Name of the file listing PIDs of processes that must survive when halting | |
472 | ;; the system. Typical example is user-space file systems. | |
473 | "/etc/shepherd/do-not-kill") | |
474 | ||
475 | (define (user-processes-shepherd-service requirements) | |
476 | "Return the 'user-processes' Shepherd service with dependencies on | |
477 | REQUIREMENTS (a list of service names). | |
478 | ||
479 | This is a synchronization point used to make sure user processes and daemons | |
480 | get started only after crucial initial services have been started---file | |
481 | system mounts, etc. This is similar to the 'sysvinit' target in systemd." | |
482 | (define grace-delay | |
483 | ;; Delay after sending SIGTERM and before sending SIGKILL. | |
484 | 4) | |
485 | ||
486 | (list (shepherd-service | |
487 | (documentation "When stopped, terminate all user processes.") | |
488 | (provision '(user-processes)) | |
489 | (requirement requirements) | |
490 | (start #~(const #t)) | |
491 | (stop #~(lambda _ | |
492 | (define (kill-except omit signal) | |
493 | ;; Kill all the processes with SIGNAL except those listed | |
494 | ;; in OMIT and the current process. | |
495 | (let ((omit (cons (getpid) omit))) | |
496 | (for-each (lambda (pid) | |
497 | (unless (memv pid omit) | |
498 | (false-if-exception | |
499 | (kill pid signal)))) | |
500 | (processes)))) | |
501 | ||
502 | (define omitted-pids | |
503 | ;; List of PIDs that must not be killed. | |
504 | (if (file-exists? #$%do-not-kill-file) | |
505 | (map string->number | |
506 | (call-with-input-file #$%do-not-kill-file | |
507 | (compose string-tokenize | |
508 | (@ (ice-9 rdelim) read-string)))) | |
509 | '())) | |
510 | ||
511 | (define (now) | |
512 | (car (gettimeofday))) | |
513 | ||
514 | (define (sleep* n) | |
515 | ;; Really sleep N seconds. | |
516 | ;; Work around <http://bugs.gnu.org/19581>. | |
517 | (define start (now)) | |
518 | (let loop ((elapsed 0)) | |
519 | (when (> n elapsed) | |
520 | (sleep (- n elapsed)) | |
521 | (loop (- (now) start))))) | |
522 | ||
523 | (define lset= (@ (srfi srfi-1) lset=)) | |
524 | ||
525 | (display "sending all processes the TERM signal\n") | |
526 | ||
527 | (if (null? omitted-pids) | |
528 | (begin | |
529 | ;; Easy: terminate all of them. | |
530 | (kill -1 SIGTERM) | |
531 | (sleep* #$grace-delay) | |
532 | (kill -1 SIGKILL)) | |
533 | (begin | |
534 | ;; Kill them all except OMITTED-PIDS. XXX: We would | |
535 | ;; like to (kill -1 SIGSTOP) to get a fixed list of | |
536 | ;; processes, like 'killall5' does, but that seems | |
537 | ;; unreliable. | |
538 | (kill-except omitted-pids SIGTERM) | |
539 | (sleep* #$grace-delay) | |
540 | (kill-except omitted-pids SIGKILL) | |
541 | (delete-file #$%do-not-kill-file))) | |
542 | ||
543 | (let wait () | |
544 | ;; Reap children, if any, so that we don't end up with | |
545 | ;; zombies and enter an infinite loop. | |
546 | (let reap-children () | |
547 | (define result | |
548 | (false-if-exception | |
549 | (waitpid WAIT_ANY (if (null? omitted-pids) | |
550 | 0 | |
551 | WNOHANG)))) | |
552 | ||
553 | (when (and (pair? result) | |
554 | (not (zero? (car result)))) | |
555 | (reap-children))) | |
556 | ||
557 | (let ((pids (processes))) | |
558 | (unless (lset= = pids (cons 1 omitted-pids)) | |
559 | (format #t "waiting for process termination\ | |
560 | (processes left: ~s)~%" | |
561 | pids) | |
562 | (sleep* 2) | |
563 | (wait)))) | |
564 | ||
565 | (display "all processes have been terminated\n") | |
566 | #f)) | |
567 | (respawn? #f)))) | |
568 | ||
569 | (define user-processes-service-type | |
570 | (service-type | |
571 | (name 'user-processes) | |
572 | (extensions (list (service-extension shepherd-root-service-type | |
573 | user-processes-shepherd-service))) | |
574 | (compose concatenate) | |
575 | (extend append) | |
576 | ||
577 | ;; The value is the list of Shepherd services 'user-processes' depends on. | |
578 | ;; Extensions can add new services to this list. | |
579 | (default-value '()) | |
580 | ||
581 | (description "The @code{user-processes} service is responsible for | |
582 | terminating all the processes so that the root file system can be re-mounted | |
583 | read-only, just before rebooting/halting. Processes still running after a few | |
584 | seconds after @code{SIGTERM} has been sent are terminated with | |
585 | @code{SIGKILL}."))) | |
586 | ||
0190c1c0 | 587 | ;;; shepherd.scm ends here |