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