1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2013, 2014, 2015, 2016, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org>
4 ;;; Copyright © 2018 Carlo Zancanaro <carlo@zancanaro.id.au>
6 ;;; This file is part of GNU Guix.
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.
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.
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/>.
21 (define-module (gnu services shepherd)
22 #:use-module (guix ui)
23 #:use-module (guix sets)
24 #:use-module (guix gexp)
25 #:use-module (guix store)
26 #:use-module (guix records)
27 #:use-module (guix derivations) ;imported-modules, etc.
28 #:use-module (gnu services)
29 #:use-module (gnu services herd)
30 #:use-module (gnu packages admin)
31 #:use-module (ice-9 match)
32 #:use-module (ice-9 vlist)
33 #:use-module (srfi srfi-1)
34 #:use-module (srfi srfi-26)
35 #:use-module (srfi srfi-34)
36 #:use-module (srfi srfi-35)
37 #:export (shepherd-root-service-type
38 %shepherd-root-service
43 shepherd-service-documentation
44 shepherd-service-provision
45 shepherd-service-canonical-name
46 shepherd-service-requirement
47 shepherd-service-one-shot?
48 shepherd-service-respawn?
49 shepherd-service-start
51 shepherd-service-auto-start?
52 shepherd-service-modules
57 shepherd-action-documentation
58 shepherd-action-procedure
64 shepherd-service-lookup-procedure
65 shepherd-service-back-edges
66 shepherd-service-upgrade
68 user-processes-service-type))
72 ;;; Instantiating system services as a shepherd configuration file.
77 (define (shepherd-boot-gexp services)
79 ;; Keep track of the booted system.
80 (false-if-exception (delete-file "/run/booted-system"))
81 (symlink (readlink "/run/current-system")
84 ;; Close any remaining open file descriptors to be on the safe
85 ;; side. This must be the very last thing we do, because
86 ;; Guile has internal FDs such as 'sleep_pipe' that need to be
90 (false-if-exception (close-fdes fd))
94 (execl #$(file-append shepherd "/bin/shepherd")
96 #$(shepherd-configuration-file services))))
98 (define shepherd-root-service-type
100 (name 'shepherd-root)
101 ;; Extending the root shepherd service (aka. PID 1) happens by
102 ;; concatenating the list of services provided by the extensions.
103 (compose concatenate)
105 (extensions (list (service-extension boot-service-type
107 (service-extension profile-service-type
108 (const (list shepherd)))))))
110 (define %shepherd-root-service
111 ;; The root shepherd service, aka. PID 1. Its parameter is a list of
112 ;; <shepherd-service> objects.
113 (service shepherd-root-service-type '()))
115 (define-syntax shepherd-service-type
117 "Return a <service-type> denoting a simple shepherd service--i.e., the type
118 for a service that extends SHEPHERD-ROOT-SERVICE-TYPE and nothing else. When
119 DEFAULT is given, use it as the service's default value."
120 ((_ service-name proc default)
124 (list (service-extension shepherd-root-service-type
125 (compose list proc))))
126 (default-value default)))
127 ((_ service-name proc)
131 (list (service-extension shepherd-root-service-type
132 (compose list proc))))))))
134 (define %default-imported-modules
135 ;; Default set of modules imported for a service's consumption.
137 (guix build syscalls)))
139 (define %default-modules
140 ;; Default set of modules visible in a service's file.
144 (guix build syscalls)))
146 (define-record-type* <shepherd-service>
147 shepherd-service make-shepherd-service
149 (documentation shepherd-service-documentation ;string
150 (default "[No documentation.]"))
151 (provision shepherd-service-provision) ;list of symbols
152 (requirement shepherd-service-requirement ;list of symbols
154 (one-shot? shepherd-service-one-shot? ;Boolean
156 (respawn? shepherd-service-respawn? ;Boolean
158 (start shepherd-service-start) ;g-expression (procedure)
159 (stop shepherd-service-stop ;g-expression (procedure)
160 (default #~(const #f)))
161 (actions shepherd-service-actions ;list of <shepherd-action>
163 (auto-start? shepherd-service-auto-start? ;Boolean
165 (modules shepherd-service-modules ;list of module names
166 (default %default-modules)))
168 (define-record-type* <shepherd-action>
169 shepherd-action make-shepherd-action
171 (name shepherd-action-name) ;symbol
172 (procedure shepherd-action-procedure) ;gexp
173 (documentation shepherd-action-documentation)) ;string
175 (define (shepherd-service-canonical-name service)
176 "Return the 'canonical name' of SERVICE."
177 (first (shepherd-service-provision service)))
179 (define (assert-valid-graph services)
180 "Raise an error if SERVICES does not define a valid shepherd service graph,
181 for instance if a service requires a nonexistent service, or if more than one
182 service uses a given name.
184 These are constraints that shepherd's 'register-service' verifies but we'd
185 better verify them here statically than wait until PID 1 halts with an
188 ;; The set of provisions (symbols). Bail out if a symbol is given more
190 (fold (lambda (service set)
191 (define (assert-unique symbol)
192 (when (set-contains? set symbol)
196 (format #f (G_ "service '~a' provided more than once")
199 (for-each assert-unique (shepherd-service-provision service))
200 (fold set-insert set (shepherd-service-provision service)))
204 (define (assert-satisfied-requirements service)
205 ;; Bail out if the requirements of SERVICE aren't satisfied.
206 (for-each (lambda (requirement)
207 (unless (set-contains? provisions requirement)
211 (format #f (G_ "service '~a' requires '~a', \
212 which is not provided by any service")
213 (match (shepherd-service-provision service)
217 (shepherd-service-requirement service)))
219 (for-each assert-satisfied-requirements services))
221 (define (shepherd-service-file-name service)
222 "Return the file name where the initialization code for SERVICE is to be
224 (let ((provisions (string-join (map symbol->string
225 (shepherd-service-provision service)))))
226 (string-append "shepherd-"
227 (string-map (match-lambda
234 (define (shepherd-service-file service)
235 "Return a file defining SERVICE."
236 (scheme-file (shepherd-service-file-name service)
237 (with-imported-modules %default-imported-modules
239 (use-modules #$@(shepherd-service-modules service))
242 #:docstring '#$(shepherd-service-documentation service)
243 #:provides '#$(shepherd-service-provision service)
244 #:requires '#$(shepherd-service-requirement service)
246 ;; The 'one-shot?' slot is new in Shepherd 0.6.0.
247 ;; Older versions ignore it.
248 #:one-shot? '#$(shepherd-service-one-shot? service)
250 #:respawn? '#$(shepherd-service-respawn? service)
251 #:start #$(shepherd-service-start service)
252 #:stop #$(shepherd-service-stop service)
255 #$@(map (match-lambda
256 (($ <shepherd-action> name proc doc)
257 #~(#$name #$doc #$proc)))
258 (shepherd-service-actions service))))))))
260 (define (scm->go file)
261 "Compile FILE, which contains code to be loaded by shepherd's config file,
262 and return the resulting '.go' file."
263 (with-extensions (list shepherd)
264 (computed-file (string-append (basename (scheme-file-name file) ".scm")
267 (use-modules (system base compile))
269 ;; Do the same as the Shepherd's 'load-in-user-module'.
270 (let ((env (make-fresh-user-module)))
271 (module-use! env (resolve-interface '(oop goops)))
272 (module-use! env (resolve-interface '(shepherd service)))
273 (compile-file #$file #:output-file #$output
276 ;; It's faster to build locally than to download.
277 #:options '(#:local-build? #t
278 #:substitutable? #f))))
280 (define (shepherd-configuration-file services)
281 "Return the shepherd configuration file for SERVICES."
282 (assert-valid-graph services)
284 (let ((files (map shepherd-service-file services)))
287 (use-modules (srfi srfi-34)
288 (system repl error-handling))
290 ;; Specify the default environment visible to all the services.
291 ;; Without this statement, all the environment variables of PID 1
292 ;; are inherited by child services.
293 (default-environment-variables
294 '("PATH=/run/current-system/profile/bin"))
296 ;; Booting off a DVD, especially on a slow machine, can make
297 ;; everything slow. Thus, increase the timeout compared to the
298 ;; default 5s in the Shepherd 0.7.0. See
299 ;; <https://bugs.gnu.org/40572>.
300 ;; XXX: Use something better when the next Shepherd is out.
301 (set! (@@ (shepherd service) %pid-file-timeout) 30)
303 ;; Arrange to spawn a REPL if something goes wrong. This is better
304 ;; than a kernel panic.
305 (call-with-error-handling
307 (apply register-services
308 (map load-compiled '#$(map scm->go files)))))
310 (format #t "starting services...~%")
311 (for-each (lambda (service)
312 ;; In the Shepherd 0.3 the 'start' method can raise
313 ;; '&action-runtime-error' if it fails, so protect
314 ;; against it. (XXX: 'action-runtime-error?' is not
315 ;; exported is 0.3, hence 'service-error?'.)
316 (guard (c ((service-error? c)
317 (format (current-error-port)
318 "failed to start service '~a'~%"
321 '#$(append-map shepherd-service-provision
322 (filter shepherd-service-auto-start?
325 ;; Hang up stdin. At this point, we assume that 'start' methods
326 ;; that required user interaction on the console (e.g.,
327 ;; 'cryptsetup open' invocations, post-fsck emergency REPL) have
328 ;; completed. User interaction becomes impossible after this
329 ;; call; this avoids situations where services wrongfully lead
330 ;; PID 1 to read from stdin (the console), which users may not
331 ;; have access to (see <https://bugs.gnu.org/23697>).
332 (redirect-port (open-input-file "/dev/null")
333 (current-input-port))))
335 (scheme-file "shepherd.conf" config)))
337 (define* (shepherd-service-lookup-procedure services
340 shepherd-service-provision))
341 "Return a procedure that, when passed a symbol, return the item among
342 SERVICES that provides this symbol. PROVISION must be a one-argument
343 procedure that takes a service and returns the list of symbols it provides."
344 (let ((services (fold (lambda (service result)
345 (fold (cut vhash-consq <> service <>)
347 (provision service)))
351 (match (vhash-assq name services)
352 ((_ . service) service)
355 (define* (shepherd-service-back-edges services
357 (provision shepherd-service-provision)
358 (requirement shepherd-service-requirement))
359 "Return a procedure that, when given a <shepherd-service> from SERVICES,
360 returns the list of <shepherd-service> that depend on it.
362 Use PROVISION and REQUIREMENT as one-argument procedures that return the
363 symbols provided/required by a service."
364 (define provision->service
365 (shepherd-service-lookup-procedure services provision))
368 (fold (lambda (service edges)
369 (fold (lambda (requirement edges)
370 (vhash-consq (provision->service requirement) service
373 (requirement service)))
378 (vhash-foldq* cons '() service edges)))
380 (define (shepherd-service-upgrade live target)
381 "Return two values: the subset of LIVE (a list of <live-service>) that needs
382 to be unloaded, and the subset of TARGET (a list of <shepherd-service>) that
383 need to be restarted to complete their upgrade."
384 (define (essential? service)
385 (memq (first (live-service-provision service))
388 (define lookup-target
389 (shepherd-service-lookup-procedure target
390 shepherd-service-provision))
393 (shepherd-service-lookup-procedure live
394 live-service-provision))
396 (define (running? service)
397 (and=> (lookup-live (shepherd-service-canonical-name service))
398 live-service-running))
400 (define live-service-dependents
401 (shepherd-service-back-edges live
402 #:provision live-service-provision
403 #:requirement live-service-requirement))
405 (define (obsolete? service)
406 (match (lookup-target (first (live-service-provision service)))
407 (#f (every obsolete? (live-service-dependents service)))
411 ;; Restart services that are currently running.
412 (filter running? target))
415 ;; Unload services that are no longer required.
416 (remove essential? (filter obsolete? live)))
418 (values to-unload to-restart))
425 (define %do-not-kill-file
426 ;; Name of the file listing PIDs of processes that must survive when halting
427 ;; the system. Typical example is user-space file systems.
428 "/etc/shepherd/do-not-kill")
430 (define (user-processes-shepherd-service requirements)
431 "Return the 'user-processes' Shepherd service with dependencies on
432 REQUIREMENTS (a list of service names).
434 This is a synchronization point used to make sure user processes and daemons
435 get started only after crucial initial services have been started---file
436 system mounts, etc. This is similar to the 'sysvinit' target in systemd."
438 ;; Delay after sending SIGTERM and before sending SIGKILL.
441 (list (shepherd-service
442 (documentation "When stopped, terminate all user processes.")
443 (provision '(user-processes))
444 (requirement requirements)
447 (define (kill-except omit signal)
448 ;; Kill all the processes with SIGNAL except those listed
449 ;; in OMIT and the current process.
450 (let ((omit (cons (getpid) omit)))
451 (for-each (lambda (pid)
452 (unless (memv pid omit)
458 ;; List of PIDs that must not be killed.
459 (if (file-exists? #$%do-not-kill-file)
461 (call-with-input-file #$%do-not-kill-file
462 (compose string-tokenize
463 (@ (ice-9 rdelim) read-string))))
467 (car (gettimeofday)))
470 ;; Really sleep N seconds.
471 ;; Work around <http://bugs.gnu.org/19581>.
473 (let loop ((elapsed 0))
475 (sleep (- n elapsed))
476 (loop (- (now) start)))))
478 (define lset= (@ (srfi srfi-1) lset=))
480 (display "sending all processes the TERM signal\n")
482 (if (null? omitted-pids)
484 ;; Easy: terminate all of them.
486 (sleep* #$grace-delay)
489 ;; Kill them all except OMITTED-PIDS. XXX: We would
490 ;; like to (kill -1 SIGSTOP) to get a fixed list of
491 ;; processes, like 'killall5' does, but that seems
493 (kill-except omitted-pids SIGTERM)
494 (sleep* #$grace-delay)
495 (kill-except omitted-pids SIGKILL)
496 (delete-file #$%do-not-kill-file)))
499 ;; Reap children, if any, so that we don't end up with
500 ;; zombies and enter an infinite loop.
501 (let reap-children ()
504 (waitpid WAIT_ANY (if (null? omitted-pids)
508 (when (and (pair? result)
509 (not (zero? (car result))))
512 (let ((pids (processes)))
513 (unless (lset= = pids (cons 1 omitted-pids))
514 (format #t "waiting for process termination\
515 (processes left: ~s)~%"
520 (display "all processes have been terminated\n")
524 (define user-processes-service-type
526 (name 'user-processes)
527 (extensions (list (service-extension shepherd-root-service-type
528 user-processes-shepherd-service)))
529 (compose concatenate)
532 ;; The value is the list of Shepherd services 'user-processes' depends on.
533 ;; Extensions can add new services to this list.
536 (description "The @code{user-processes} service is responsible for
537 terminating all the processes so that the root file system can be re-mounted
538 read-only, just before rebooting/halting. Processes still running after a few
539 seconds after @code{SIGTERM} has been sent are terminated with
542 ;;; shepherd.scm ends here