gnu/services/shepherd.scm

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