;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org>
+;;; Copyright © 2018 Carlo Zancanaro <carlo@zancanaro.id.au>
+;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
#:use-module (guix sets)
#:use-module (guix gexp)
#:use-module (guix store)
- #:use-module (guix monads)
#:use-module (guix records)
#:use-module (guix derivations) ;imported-modules, etc.
+ #:use-module (guix utils)
#:use-module (gnu services)
+ #:use-module (gnu services herd)
#:use-module (gnu packages admin)
#:use-module (ice-9 match)
#:use-module (ice-9 vlist)
shepherd-service-provision
shepherd-service-canonical-name
shepherd-service-requirement
+ shepherd-service-one-shot?
shepherd-service-respawn?
shepherd-service-start
shepherd-service-stop
shepherd-service-auto-start?
shepherd-service-modules
- shepherd-service-imported-modules
- %default-imported-modules
+ shepherd-action
+ shepherd-action?
+ shepherd-action-name
+ shepherd-action-documentation
+ shepherd-action-procedure
+
%default-modules
shepherd-service-file
- shepherd-service-back-edges))
+ shepherd-service-lookup-procedure
+ shepherd-service-back-edges
+ shepherd-service-upgrade
+
+ user-processes-service-type))
;;; Commentary:
;;;
(define (shepherd-boot-gexp services)
- (mlet %store-monad ((shepherd-conf (shepherd-configuration-file services)))
- (return #~(begin
- ;; Keep track of the booted system.
- (false-if-exception (delete-file "/run/booted-system"))
- (symlink (readlink "/run/current-system")
- "/run/booted-system")
-
- ;; Close any remaining open file descriptors to be on the safe
- ;; side. This must be the very last thing we do, because
- ;; Guile has internal FDs such as 'sleep_pipe' that need to be
- ;; alive.
- (let loop ((fd 3))
- (when (< fd 1024)
- (false-if-exception (close-fdes fd))
- (loop (+ 1 fd))))
-
- ;; Start shepherd.
- (execl (string-append #$shepherd "/bin/shepherd")
- "shepherd" "--config" #$shepherd-conf)))))
+ #~(begin
+ ;; Keep track of the booted system.
+ (false-if-exception (delete-file "/run/booted-system"))
+ (symlink (readlink "/run/current-system")
+ "/run/booted-system")
+
+ ;; Close any remaining open file descriptors to be on the safe
+ ;; side. This must be the very last thing we do, because
+ ;; Guile has internal FDs such as 'sleep_pipe' that need to be
+ ;; alive.
+ (let loop ((fd 3))
+ (when (< fd 1024)
+ (false-if-exception (close-fdes fd))
+ (loop (+ 1 fd))))
+
+ ;; Start shepherd.
+ (execl #$(file-append shepherd "/bin/shepherd")
+ "shepherd" "--config"
+ #$(shepherd-configuration-file services))))
(define shepherd-root-service-type
(service-type
(extensions (list (service-extension boot-service-type
shepherd-boot-gexp)
(service-extension profile-service-type
- (const (list shepherd)))))))
+ (const (list shepherd)))))
+ (description
+ "Run the GNU Shepherd as PID 1---i.e., the operating system's first
+process. The Shepherd takes care of managing services such as daemons by
+ensuring they are started and stopped in the right order.")))
(define %shepherd-root-service
;; The root shepherd service, aka. PID 1. Its parameter is a list of
;; <shepherd-service> objects.
(service shepherd-root-service-type '()))
-(define-syntax-rule (shepherd-service-type service-name proc)
- "Return a <service-type> denoting a simple shepherd service--i.e., the type
-for a service that extends SHEPHERD-ROOT-SERVICE-TYPE and nothing else."
- (service-type
- (name service-name)
- (extensions
- (list (service-extension shepherd-root-service-type
- (compose list proc))))))
+(define-syntax shepherd-service-type
+ (syntax-rules ()
+ "Return a <service-type> denoting a simple shepherd service--i.e., the type
+for a service that extends SHEPHERD-ROOT-SERVICE-TYPE and nothing else. When
+DEFAULT is given, use it as the service's default value."
+ ((_ service-name proc default)
+ (service-type
+ (name service-name)
+ (extensions
+ (list (service-extension shepherd-root-service-type
+ (compose list proc))))
+ (default-value default)))
+ ((_ service-name proc)
+ (service-type
+ (name service-name)
+ (extensions
+ (list (service-extension shepherd-root-service-type
+ (compose list proc))))))))
(define %default-imported-modules
;; Default set of modules imported for a service's consumption.
;; Default set of modules visible in a service's file.
`((shepherd service)
(oop goops)
- (guix build utils)
+ ((guix build utils) #:hide (delete))
(guix build syscalls)))
(define-record-type* <shepherd-service>
(provision shepherd-service-provision) ;list of symbols
(requirement shepherd-service-requirement ;list of symbols
(default '()))
+ (one-shot? shepherd-service-one-shot? ;Boolean
+ (default #f))
(respawn? shepherd-service-respawn? ;Boolean
(default #t))
(start shepherd-service-start) ;g-expression (procedure)
(stop shepherd-service-stop ;g-expression (procedure)
(default #~(const #f)))
+ (actions shepherd-service-actions ;list of <shepherd-action>
+ (default '()))
(auto-start? shepherd-service-auto-start? ;Boolean
(default #t))
(modules shepherd-service-modules ;list of module names
- (default %default-modules))
- (imported-modules shepherd-service-imported-modules ;list of module names
- (default %default-imported-modules)))
+ (default %default-modules)))
+
+(define-record-type* <shepherd-action>
+ shepherd-action make-shepherd-action
+ shepherd-action?
+ (name shepherd-action-name) ;symbol
+ (procedure shepherd-action-procedure) ;gexp
+ (documentation shepherd-action-documentation)) ;string
(define (shepherd-service-canonical-name service)
"Return the 'canonical name' of SERVICE."
(raise (condition
(&message
(message
- (format #f (_ "service '~a' provided more than once")
+ (format #f (G_ "service '~a' provided more than once")
symbol)))))))
(for-each assert-unique (shepherd-service-provision service))
(raise (condition
(&message
(message
- (format #f (_ "service '~a' requires '~a', \
-which is undefined")
+ (format #f (G_ "service '~a' requires '~a', \
+which is not provided by any service")
(match (shepherd-service-provision service)
((head . _) head)
(_ service))
(string-append "shepherd-"
(string-map (match-lambda
(#\/ #\-)
+ (#\ #\-)
(chr chr))
provisions)
".scm")))
(define (shepherd-service-file service)
"Return a file defining SERVICE."
- (gexp->file (shepherd-service-file-name service)
- #~(begin
- (use-modules #$@(shepherd-service-modules service))
-
- (make <service>
- #:docstring '#$(shepherd-service-documentation service)
- #:provides '#$(shepherd-service-provision service)
- #:requires '#$(shepherd-service-requirement service)
- #:respawn? '#$(shepherd-service-respawn? service)
- #:start #$(shepherd-service-start service)
- #:stop #$(shepherd-service-stop service)))))
+ (scheme-file (shepherd-service-file-name service)
+ (with-imported-modules %default-imported-modules
+ #~(begin
+ (use-modules #$@(shepherd-service-modules service))
+
+ (make <service>
+ #:docstring '#$(shepherd-service-documentation service)
+ #:provides '#$(shepherd-service-provision service)
+ #:requires '#$(shepherd-service-requirement service)
+
+ ;; The 'one-shot?' slot is new in Shepherd 0.6.0.
+ ;; Older versions ignore it.
+ #:one-shot? '#$(shepherd-service-one-shot? service)
+
+ #:respawn? '#$(shepherd-service-respawn? service)
+ #:start #$(shepherd-service-start service)
+ #:stop #$(shepherd-service-stop service)
+ #:actions
+ (make-actions
+ #$@(map (match-lambda
+ (($ <shepherd-action> name proc doc)
+ #~(#$name #$doc #$proc)))
+ (shepherd-service-actions service))))))))
+
+(define (scm->go file)
+ "Compile FILE, which contains code to be loaded by shepherd's config file,
+and return the resulting '.go' file."
+ (let-system (system target)
+ (with-extensions (list shepherd)
+ (computed-file (string-append (basename (scheme-file-name file) ".scm")
+ ".go")
+ #~(begin
+ (use-modules (system base compile)
+ (system base target))
+
+ ;; Do the same as the Shepherd's 'load-in-user-module'.
+ (let ((env (make-fresh-user-module)))
+ (module-use! env (resolve-interface '(oop goops)))
+ (module-use! env (resolve-interface '(shepherd service)))
+ (with-target #$(or target #~%host-type)
+ (lambda _
+ (compile-file #$file #:output-file #$output
+ #:env env)))))
+
+ ;; It's faster to build locally than to download.
+ #:options '(#:local-build? #t
+ #:substitutable? #f)))))
(define (shepherd-configuration-file services)
"Return the shepherd configuration file for SERVICES."
- (define modules
- (delete-duplicates
- (append-map shepherd-service-imported-modules services)))
-
(assert-valid-graph services)
- (mlet %store-monad ((modules (imported-modules modules))
- (compiled (compiled-modules modules))
- (files (mapm %store-monad
- shepherd-service-file
- services)))
+ (let ((files (map shepherd-service-file services)))
(define config
#~(begin
- (eval-when (expand load eval)
- (set! %load-path (cons #$modules %load-path))
- (set! %load-compiled-path
- (cons #$compiled %load-compiled-path)))
-
(use-modules (srfi srfi-34)
(system repl error-handling))
- ;; Arrange to spawn a REPL if loading one of FILES fails. This is
- ;; better than a kernel panic.
+ ;; Specify the default environment visible to all the services.
+ ;; Without this statement, all the environment variables of PID 1
+ ;; are inherited by child services.
+ (default-environment-variables
+ '("PATH=/run/current-system/profile/bin"))
+
+ ;; Booting off a DVD, especially on a slow machine, can make
+ ;; everything slow. Thus, increase the timeout compared to the
+ ;; default 5s in the Shepherd 0.7.0. See
+ ;; <https://bugs.gnu.org/40572>.
+ (default-pid-file-timeout 30)
+
+ ;; Arrange to spawn a REPL if something goes wrong. This is better
+ ;; than a kernel panic.
(call-with-error-handling
(lambda ()
- (apply register-services (map primitive-load '#$files))))
-
- ;; guix-daemon 0.6 aborts if 'PATH' is undefined, so work around it.
- (setenv "PATH" "/run/current-system/profile/bin")
+ (apply register-services
+ (parameterize ((current-warning-port
+ (%make-void-port "w")))
+ (map load-compiled '#$(map scm->go files))))))
(format #t "starting services...~%")
(for-each (lambda (service)
(start service)))
'#$(append-map shepherd-service-provision
(filter shepherd-service-auto-start?
- services)))))
-
- (gexp->file "shepherd.conf" config)))
-
-(define (shepherd-service-back-edges services)
+ services)))
+
+ ;; Hang up stdin. At this point, we assume that 'start' methods
+ ;; that required user interaction on the console (e.g.,
+ ;; 'cryptsetup open' invocations, post-fsck emergency REPL) have
+ ;; completed. User interaction becomes impossible after this
+ ;; call; this avoids situations where services wrongfully lead
+ ;; PID 1 to read from stdin (the console), which users may not
+ ;; have access to (see <https://bugs.gnu.org/23697>).
+ (redirect-port (open-input-file "/dev/null")
+ (current-input-port))))
+
+ (scheme-file "shepherd.conf" config)))
+
+(define* (shepherd-service-lookup-procedure services
+ #:optional
+ (provision
+ shepherd-service-provision))
+ "Return a procedure that, when passed a symbol, return the item among
+SERVICES that provides this symbol. PROVISION must be a one-argument
+procedure that takes a service and returns the list of symbols it provides."
+ (let ((services (fold (lambda (service result)
+ (fold (cut vhash-consq <> service <>)
+ result
+ (provision service)))
+ vlist-null
+ services)))
+ (lambda (name)
+ (match (vhash-assq name services)
+ ((_ . service) service)
+ (#f #f)))))
+
+(define* (shepherd-service-back-edges services
+ #:key
+ (provision shepherd-service-provision)
+ (requirement shepherd-service-requirement))
"Return a procedure that, when given a <shepherd-service> from SERVICES,
-returns the list of <shepherd-service> that depend on it."
+returns the list of <shepherd-service> that depend on it.
+
+Use PROVISION and REQUIREMENT as one-argument procedures that return the
+symbols provided/required by a service."
(define provision->service
- (let ((services (fold (lambda (service result)
- (fold (cut vhash-consq <> service <>)
- result
- (shepherd-service-provision service)))
- vlist-null
- services)))
- (lambda (name)
- (match (vhash-assq name services)
- ((_ . service) service)
- (#f #f)))))
+ (shepherd-service-lookup-procedure services provision))
(define edges
(fold (lambda (service edges)
(vhash-consq (provision->service requirement) service
edges))
edges
- (shepherd-service-requirement service)))
+ (requirement service)))
vlist-null
services))
(lambda (service)
(vhash-foldq* cons '() service edges)))
+(define (shepherd-service-upgrade live target)
+ "Return two values: the subset of LIVE (a list of <live-service>) that needs
+to be unloaded, and the subset of TARGET (a list of <shepherd-service>) that
+need to be restarted to complete their upgrade."
+ (define (essential? service)
+ (memq (first (live-service-provision service))
+ '(root shepherd)))
+
+ (define lookup-target
+ (shepherd-service-lookup-procedure target
+ shepherd-service-provision))
+
+ (define lookup-live
+ (shepherd-service-lookup-procedure live
+ live-service-provision))
+
+ (define (running? service)
+ (and=> (lookup-live (shepherd-service-canonical-name service))
+ live-service-running))
+
+ (define live-service-dependents
+ (shepherd-service-back-edges live
+ #:provision live-service-provision
+ #:requirement live-service-requirement))
+
+ (define (obsolete? service)
+ (match (lookup-target (first (live-service-provision service)))
+ (#f (every obsolete? (live-service-dependents service)))
+ (_ #f)))
+
+ (define to-restart
+ ;; Restart services that are currently running.
+ (filter running? target))
+
+ (define to-unload
+ ;; Unload services that are no longer required.
+ (remove essential? (filter obsolete? live)))
+
+ (values to-unload to-restart))
+
+\f
+;;;
+;;; User processes.
+;;;
+
+(define %do-not-kill-file
+ ;; Name of the file listing PIDs of processes that must survive when halting
+ ;; the system. Typical example is user-space file systems.
+ "/etc/shepherd/do-not-kill")
+
+(define (user-processes-shepherd-service requirements)
+ "Return the 'user-processes' Shepherd service with dependencies on
+REQUIREMENTS (a list of service names).
+
+This is a synchronization point used to make sure user processes and daemons
+get started only after crucial initial services have been started---file
+system mounts, etc. This is similar to the 'sysvinit' target in systemd."
+ (define grace-delay
+ ;; Delay after sending SIGTERM and before sending SIGKILL.
+ 4)
+
+ (list (shepherd-service
+ (documentation "When stopped, terminate all user processes.")
+ (provision '(user-processes))
+ (requirement requirements)
+ (start #~(const #t))
+ (stop #~(lambda _
+ (define (kill-except omit signal)
+ ;; Kill all the processes with SIGNAL except those listed
+ ;; in OMIT and the current process.
+ (let ((omit (cons (getpid) omit)))
+ (for-each (lambda (pid)
+ (unless (memv pid omit)
+ (false-if-exception
+ (kill pid signal))))
+ (processes))))
+
+ (define omitted-pids
+ ;; List of PIDs that must not be killed.
+ (if (file-exists? #$%do-not-kill-file)
+ (map string->number
+ (call-with-input-file #$%do-not-kill-file
+ (compose string-tokenize
+ (@ (ice-9 rdelim) read-string))))
+ '()))
+
+ (define (now)
+ (car (gettimeofday)))
+
+ (define (sleep* n)
+ ;; Really sleep N seconds.
+ ;; Work around <http://bugs.gnu.org/19581>.
+ (define start (now))
+ (let loop ((elapsed 0))
+ (when (> n elapsed)
+ (sleep (- n elapsed))
+ (loop (- (now) start)))))
+
+ (define lset= (@ (srfi srfi-1) lset=))
+
+ (display "sending all processes the TERM signal\n")
+
+ (if (null? omitted-pids)
+ (begin
+ ;; Easy: terminate all of them.
+ (kill -1 SIGTERM)
+ (sleep* #$grace-delay)
+ (kill -1 SIGKILL))
+ (begin
+ ;; Kill them all except OMITTED-PIDS. XXX: We would
+ ;; like to (kill -1 SIGSTOP) to get a fixed list of
+ ;; processes, like 'killall5' does, but that seems
+ ;; unreliable.
+ (kill-except omitted-pids SIGTERM)
+ (sleep* #$grace-delay)
+ (kill-except omitted-pids SIGKILL)
+ (delete-file #$%do-not-kill-file)))
+
+ (let wait ()
+ ;; Reap children, if any, so that we don't end up with
+ ;; zombies and enter an infinite loop.
+ (let reap-children ()
+ (define result
+ (false-if-exception
+ (waitpid WAIT_ANY (if (null? omitted-pids)
+ 0
+ WNOHANG))))
+
+ (when (and (pair? result)
+ (not (zero? (car result))))
+ (reap-children)))
+
+ (let ((pids (processes)))
+ (unless (lset= = pids (cons 1 omitted-pids))
+ (format #t "waiting for process termination\
+ (processes left: ~s)~%"
+ pids)
+ (sleep* 2)
+ (wait))))
+
+ (display "all processes have been terminated\n")
+ #f))
+ (respawn? #f))))
+
+(define user-processes-service-type
+ (service-type
+ (name 'user-processes)
+ (extensions (list (service-extension shepherd-root-service-type
+ user-processes-shepherd-service)))
+ (compose concatenate)
+ (extend append)
+
+ ;; The value is the list of Shepherd services 'user-processes' depends on.
+ ;; Extensions can add new services to this list.
+ (default-value '())
+
+ (description "The @code{user-processes} service is responsible for
+terminating all the processes so that the root file system can be re-mounted
+read-only, just before rebooting/halting. Processes still running after a few
+seconds after @code{SIGTERM} has been sent are terminated with
+@code{SIGKILL}.")))
+
;;; shepherd.scm ends here