gnu/services/shepherd.scm

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