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 %store-characters
 228   ;; Valid store characters; see 'checkStoreName' in the daemon.
 229   (string->char-set
 230    "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz+-._?="))
 231
 232 (define (shepherd-service-file-name service)
 233   "Return the file name where the initialization code for SERVICE is to be
 234 stored."
 235   (let ((provisions (string-join (map symbol->string
 236                                       (shepherd-service-provision service)))))
 237     (string-append "shepherd-"
 238                    (string-map (lambda (chr)
 239                                  (if (char-set-contains? %store-characters chr)
 240                                      chr
 241                                      #\-))
 242                                provisions)
 243                    ".scm")))
 244
 245 (define (shepherd-service-file service)
 246   "Return a file defining SERVICE."
 247   (scheme-file (shepherd-service-file-name service)
 248                (with-imported-modules %default-imported-modules
 249                  #~(begin
 250                      (use-modules #$@(shepherd-service-modules service))
 251
 252                      (make <service>
 253                        #:docstring '#$(shepherd-service-documentation service)
 254                        #:provides '#$(shepherd-service-provision service)
 255                        #:requires '#$(shepherd-service-requirement service)
 256
 257                        ;; The 'one-shot?' slot is new in Shepherd 0.6.0.
 258                        ;; Older versions ignore it.
 259                        #:one-shot? '#$(shepherd-service-one-shot? service)
 260
 261                        #:respawn? '#$(shepherd-service-respawn? service)
 262                        #:start #$(shepherd-service-start service)
 263                        #:stop #$(shepherd-service-stop service)
 264                        #:actions
 265                        (make-actions
 266                         #$@(map (match-lambda
 267                                   (($ <shepherd-action> name proc doc)
 268                                    #~(#$name #$doc #$proc)))
 269                                 (shepherd-service-actions service))))))))
 270
 271 (define (scm->go file)
 272   "Compile FILE, which contains code to be loaded by shepherd's config file,
 273 and return the resulting '.go' file."
 274   (let-system (system target)
 275     (with-extensions (list shepherd)
 276       (computed-file (string-append (basename (scheme-file-name file) ".scm")
 277                                     ".go")
 278                      #~(begin
 279                          (use-modules (system base compile)
 280                                       (system base target))
 281
 282                          ;; Do the same as the Shepherd's 'load-in-user-module'.
 283                          (let ((env (make-fresh-user-module)))
 284                            (module-use! env (resolve-interface '(oop goops)))
 285                            (module-use! env (resolve-interface '(shepherd service)))
 286                            (with-target #$(or target #~%host-type)
 287                              (lambda _
 288                                (compile-file #$file #:output-file #$output
 289                                              #:env env)))))
 290
 291                      ;; It's faster to build locally than to download.
 292                      #:options '(#:local-build? #t
 293                                  #:substitutable? #f)))))
 294
 295 (define (shepherd-configuration-file services)
 296   "Return the shepherd configuration file for SERVICES."
 297   (assert-valid-graph services)
 298
 299   (let ((files (map shepherd-service-file services)))
 300     (define config
 301       #~(begin
 302           (use-modules (srfi srfi-34)
 303                        (system repl error-handling))
 304
 305           ;; Specify the default environment visible to all the services.
 306           ;; Without this statement, all the environment variables of PID 1
 307           ;; are inherited by child services.
 308           (default-environment-variables
 309             '("PATH=/run/current-system/profile/bin"))
 310
 311           ;; Booting off a DVD, especially on a slow machine, can make
 312           ;; everything slow.  Thus, increase the timeout compared to the
 313           ;; default 5s in the Shepherd 0.7.0.  See
 314           ;; <https://bugs.gnu.org/40572>.
 315           (default-pid-file-timeout 30)
 316
 317           ;; Arrange to spawn a REPL if something goes wrong.  This is better
 318           ;; than a kernel panic.
 319           (call-with-error-handling
 320             (lambda ()
 321               (apply register-services
 322                      (parameterize ((current-warning-port
 323                                      (%make-void-port "w")))
 324                        (map load-compiled '#$(map scm->go files))))))
 325
 326           (format #t "starting services...~%")
 327           (for-each (lambda (service)
 328                       ;; In the Shepherd 0.3 the 'start' method can raise
 329                       ;; '&action-runtime-error' if it fails, so protect
 330                       ;; against it.  (XXX: 'action-runtime-error?' is not
 331                       ;; exported is 0.3, hence 'service-error?'.)
 332                       (guard (c ((service-error? c)
 333                                  (format (current-error-port)
 334                                          "failed to start service '~a'~%"
 335                                          service)))
 336                         (start service)))
 337                     '#$(append-map shepherd-service-provision
 338                                    (filter shepherd-service-auto-start?
 339                                            services)))
 340
 341           ;; Hang up stdin.  At this point, we assume that 'start' methods
 342           ;; that required user interaction on the console (e.g.,
 343           ;; 'cryptsetup open' invocations, post-fsck emergency REPL) have
 344           ;; completed.  User interaction becomes impossible after this
 345           ;; call; this avoids situations where services wrongfully lead
 346           ;; PID 1 to read from stdin (the console), which users may not
 347           ;; have access to (see <https://bugs.gnu.org/23697>).
 348           (redirect-port (open-input-file "/dev/null")
 349                          (current-input-port))))
 350
 351     (scheme-file "shepherd.conf" config)))
 352
 353 (define* (shepherd-service-lookup-procedure services
 354                                             #:optional
 355                                             (provision
 356                                              shepherd-service-provision))
 357   "Return a procedure that, when passed a symbol, return the item among
 358 SERVICES that provides this symbol.  PROVISION must be a one-argument
 359 procedure that takes a service and returns the list of symbols it provides."
 360   (let ((services (fold (lambda (service result)
 361                           (fold (cut vhash-consq <> service <>)
 362                                 result
 363                                 (provision service)))
 364                         vlist-null
 365                         services)))
 366     (lambda (name)
 367       (match (vhash-assq name services)
 368         ((_ . service) service)
 369         (#f            #f)))))
 370
 371 (define* (shepherd-service-back-edges services
 372                                       #:key
 373                                       (provision shepherd-service-provision)
 374                                       (requirement shepherd-service-requirement))
 375   "Return a procedure that, when given a <shepherd-service> from SERVICES,
 376 returns the list of <shepherd-service> that depend on it.
 377
 378 Use PROVISION and REQUIREMENT as one-argument procedures that return the
 379 symbols provided/required by a service."
 380   (define provision->service
 381     (shepherd-service-lookup-procedure services provision))
 382
 383   (define edges
 384     (fold (lambda (service edges)
 385             (fold (lambda (requirement edges)
 386                     (vhash-consq (provision->service requirement) service
 387                                  edges))
 388                   edges
 389                   (requirement service)))
 390           vlist-null
 391           services))
 392
 393   (lambda (service)
 394     (vhash-foldq* cons '() service edges)))
 395
 396 (define (shepherd-service-upgrade live target)
 397   "Return two values: the subset of LIVE (a list of <live-service>) that needs
 398 to be unloaded, and the subset of TARGET (a list of <shepherd-service>) that
 399 need to be restarted to complete their upgrade."
 400   (define (essential? service)
 401     (memq (first (live-service-provision service))
 402           '(root shepherd)))
 403
 404   (define lookup-target
 405     (shepherd-service-lookup-procedure target
 406                                        shepherd-service-provision))
 407
 408   (define lookup-live
 409     (shepherd-service-lookup-procedure live
 410                                        live-service-provision))
 411
 412   (define (running? service)
 413     (and=> (lookup-live (shepherd-service-canonical-name service))
 414            live-service-running))
 415
 416   (define live-service-dependents
 417     (shepherd-service-back-edges live
 418                                  #:provision live-service-provision
 419                                  #:requirement live-service-requirement))
 420
 421   (define (obsolete? service)
 422     (match (lookup-target (first (live-service-provision service)))
 423       (#f (every obsolete? (live-service-dependents service)))
 424       (_  #f)))
 425
 426   (define to-restart
 427     ;; Restart services that are currently running.
 428     (filter running? target))
 429
 430   (define to-unload
 431     ;; Unload services that are no longer required.
 432     (remove essential? (filter obsolete? live)))
 433
 434   (values to-unload to-restart))
 435
 436 \f
 437 ;;;
 438 ;;; User processes.
 439 ;;;
 440
 441 (define %do-not-kill-file
 442   ;; Name of the file listing PIDs of processes that must survive when halting
 443   ;; the system.  Typical example is user-space file systems.
 444   "/etc/shepherd/do-not-kill")
 445
 446 (define (user-processes-shepherd-service requirements)
 447   "Return the 'user-processes' Shepherd service with dependencies on
 448 REQUIREMENTS (a list of service names).
 449
 450 This is a synchronization point used to make sure user processes and daemons
 451 get started only after crucial initial services have been started---file
 452 system mounts, etc.  This is similar to the 'sysvinit' target in systemd."
 453   (define grace-delay
 454     ;; Delay after sending SIGTERM and before sending SIGKILL.
 455     4)
 456
 457   (list (shepherd-service
 458          (documentation "When stopped, terminate all user processes.")
 459          (provision '(user-processes))
 460          (requirement requirements)
 461          (start #~(const #t))
 462          (stop #~(lambda _
 463                    (define (kill-except omit signal)
 464                      ;; Kill all the processes with SIGNAL except those listed
 465                      ;; in OMIT and the current process.
 466                      (let ((omit (cons (getpid) omit)))
 467                        (for-each (lambda (pid)
 468                                    (unless (memv pid omit)
 469                                      (false-if-exception
 470                                       (kill pid signal))))
 471                                  (processes))))
 472
 473                    (define omitted-pids
 474                      ;; List of PIDs that must not be killed.
 475                      (if (file-exists? #$%do-not-kill-file)
 476                          (map string->number
 477                               (call-with-input-file #$%do-not-kill-file
 478                                 (compose string-tokenize
 479                                          (@ (ice-9 rdelim) read-string))))
 480                          '()))
 481
 482                    (define (now)
 483                      (car (gettimeofday)))
 484
 485                    (define (sleep* n)
 486                      ;; Really sleep N seconds.
 487                      ;; Work around <http://bugs.gnu.org/19581>.
 488                      (define start (now))
 489                      (let loop ((elapsed 0))
 490                        (when (> n elapsed)
 491                          (sleep (- n elapsed))
 492                          (loop (- (now) start)))))
 493
 494                    (define lset= (@ (srfi srfi-1) lset=))
 495
 496                    (display "sending all processes the TERM signal\n")
 497
 498                    (if (null? omitted-pids)
 499                        (begin
 500                          ;; Easy: terminate all of them.
 501                          (kill -1 SIGTERM)
 502                          (sleep* #$grace-delay)
 503                          (kill -1 SIGKILL))
 504                        (begin
 505                          ;; Kill them all except OMITTED-PIDS.  XXX: We would
 506                          ;; like to (kill -1 SIGSTOP) to get a fixed list of
 507                          ;; processes, like 'killall5' does, but that seems
 508                          ;; unreliable.
 509                          (kill-except omitted-pids SIGTERM)
 510                          (sleep* #$grace-delay)
 511                          (kill-except omitted-pids SIGKILL)
 512                          (delete-file #$%do-not-kill-file)))
 513
 514                    (let wait ()
 515                      ;; Reap children, if any, so that we don't end up with
 516                      ;; zombies and enter an infinite loop.
 517                      (let reap-children ()
 518                        (define result
 519                          (false-if-exception
 520                           (waitpid WAIT_ANY (if (null? omitted-pids)
 521                                                 0
 522                                                 WNOHANG))))
 523
 524                        (when (and (pair? result)
 525                                   (not (zero? (car result))))
 526                          (reap-children)))
 527
 528                      (let ((pids (processes)))
 529                        (unless (lset= = pids (cons 1 omitted-pids))
 530                          (format #t "waiting for process termination\
 531  (processes left: ~s)~%"
 532                                  pids)
 533                          (sleep* 2)
 534                          (wait))))
 535
 536                    (display "all processes have been terminated\n")
 537                    #f))
 538          (respawn? #f))))
 539
 540 (define user-processes-service-type
 541   (service-type
 542    (name 'user-processes)
 543    (extensions (list (service-extension shepherd-root-service-type
 544                                         user-processes-shepherd-service)))
 545    (compose concatenate)
 546    (extend append)
 547
 548    ;; The value is the list of Shepherd services 'user-processes' depends on.
 549    ;; Extensions can add new services to this list.
 550    (default-value '())
 551
 552    (description "The @code{user-processes} service is responsible for
 553 terminating all the processes so that the root file system can be re-mounted
 554 read-only, just before rebooting/halting.  Processes still running after a few
 555 seconds after @code{SIGTERM} has been sent are terminated with
 556 @code{SIGKILL}.")))
 557
 558 ;;; shepherd.scm ends here