gnu/services/shepherd.scm

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