gnu/services/shepherd.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2016, 2018 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (gnu services shepherd)
  21   #:use-module (guix ui)
  22   #:use-module (guix sets)
  23   #:use-module (guix gexp)
  24   #:use-module (guix store)
  25   #:use-module (guix records)
  26   #:use-module (guix derivations)                 ;imported-modules, etc.
  27   #:use-module (gnu services)
  28   #:use-module (gnu services herd)
  29   #:use-module (gnu packages admin)
  30   #:use-module (ice-9 match)
  31   #:use-module (ice-9 vlist)
  32   #:use-module (srfi srfi-1)
  33   #:use-module (srfi srfi-26)
  34   #:use-module (srfi srfi-34)
  35   #:use-module (srfi srfi-35)
  36   #:export (shepherd-root-service-type
  37             %shepherd-root-service
  38             shepherd-service-type
  39
  40             shepherd-service
  41             shepherd-service?
  42             shepherd-service-documentation
  43             shepherd-service-provision
  44             shepherd-service-canonical-name
  45             shepherd-service-requirement
  46             shepherd-service-respawn?
  47             shepherd-service-start
  48             shepherd-service-stop
  49             shepherd-service-auto-start?
  50             shepherd-service-modules
  51
  52             shepherd-action
  53             shepherd-action?
  54             shepherd-action-name
  55             shepherd-action-documentation
  56             shepherd-action-procedure
  57
  58             %default-modules
  59
  60             shepherd-service-file
  61
  62             shepherd-service-lookup-procedure
  63             shepherd-service-back-edges
  64             shepherd-service-upgrade))
  65
  66 ;;; Commentary:
  67 ;;;
  68 ;;; Instantiating system services as a shepherd configuration file.
  69 ;;;
  70 ;;; Code:
  71
  72
  73 (define (shepherd-boot-gexp services)
  74   #~(begin
  75       ;; Keep track of the booted system.
  76       (false-if-exception (delete-file "/run/booted-system"))
  77       (symlink (readlink "/run/current-system")
  78                "/run/booted-system")
  79
  80       ;; Close any remaining open file descriptors to be on the safe
  81       ;; side.  This must be the very last thing we do, because
  82       ;; Guile has internal FDs such as 'sleep_pipe' that need to be
  83       ;; alive.
  84       (let loop ((fd 3))
  85         (when (< fd 1024)
  86           (false-if-exception (close-fdes fd))
  87           (loop (+ 1 fd))))
  88
  89       ;; Start shepherd.
  90       (execl #$(file-append shepherd "/bin/shepherd")
  91              "shepherd" "--config"
  92              #$(shepherd-configuration-file services))))
  93
  94 (define shepherd-root-service-type
  95   (service-type
  96    (name 'shepherd-root)
  97    ;; Extending the root shepherd service (aka. PID 1) happens by
  98    ;; concatenating the list of services provided by the extensions.
  99    (compose concatenate)
 100    (extend append)
 101    (extensions (list (service-extension boot-service-type
 102                                         shepherd-boot-gexp)
 103                      (service-extension profile-service-type
 104                                         (const (list shepherd)))))))
 105
 106 (define %shepherd-root-service
 107   ;; The root shepherd service, aka. PID 1.  Its parameter is a list of
 108   ;; <shepherd-service> objects.
 109   (service shepherd-root-service-type '()))
 110
 111 (define-syntax shepherd-service-type
 112   (syntax-rules ()
 113     "Return a <service-type> denoting a simple shepherd service--i.e., the type
 114 for a service that extends SHEPHERD-ROOT-SERVICE-TYPE and nothing else.  When
 115 DEFAULT is given, use it as the service's default value."
 116     ((_ service-name proc default)
 117      (service-type
 118       (name service-name)
 119       (extensions
 120        (list (service-extension shepherd-root-service-type
 121                                 (compose list proc))))
 122       (default-value default)))
 123     ((_ service-name proc)
 124      (service-type
 125       (name service-name)
 126       (extensions
 127        (list (service-extension shepherd-root-service-type
 128                                 (compose list proc))))))))
 129
 130 (define %default-imported-modules
 131   ;; Default set of modules imported for a service's consumption.
 132   '((guix build utils)
 133     (guix build syscalls)))
 134
 135 (define %default-modules
 136   ;; Default set of modules visible in a service's file.
 137   `((shepherd service)
 138     (oop goops)
 139     (guix build utils)
 140     (guix build syscalls)))
 141
 142 (define-record-type* <shepherd-service>
 143   shepherd-service make-shepherd-service
 144   shepherd-service?
 145   (documentation shepherd-service-documentation        ;string
 146                  (default "[No documentation.]"))
 147   (provision     shepherd-service-provision)           ;list of symbols
 148   (requirement   shepherd-service-requirement          ;list of symbols
 149                  (default '()))
 150   (respawn?      shepherd-service-respawn?             ;Boolean
 151                  (default #t))
 152   (start         shepherd-service-start)               ;g-expression (procedure)
 153   (stop          shepherd-service-stop                 ;g-expression (procedure)
 154                  (default #~(const #f)))
 155   (actions       shepherd-service-actions              ;list of <shepherd-action>
 156                  (default '()))
 157   (auto-start?   shepherd-service-auto-start?          ;Boolean
 158                  (default #t))
 159   (modules       shepherd-service-modules              ;list of module names
 160                  (default %default-modules)))
 161
 162 (define-record-type* <shepherd-action>
 163   shepherd-action make-shepherd-action
 164   shepherd-action?
 165   (name          shepherd-action-name)            ;symbol
 166   (procedure     shepherd-action-procedure)       ;gexp
 167   (documentation shepherd-action-documentation))  ;string
 168
 169 (define (shepherd-service-canonical-name service)
 170   "Return the 'canonical name' of SERVICE."
 171   (first (shepherd-service-provision service)))
 172
 173 (define (assert-valid-graph services)
 174   "Raise an error if SERVICES does not define a valid shepherd service graph,
 175 for instance if a service requires a nonexistent service, or if more than one
 176 service uses a given name.
 177
 178 These are constraints that shepherd's 'register-service' verifies but we'd
 179 better verify them here statically than wait until PID 1 halts with an
 180 assertion failure."
 181   (define provisions
 182     ;; The set of provisions (symbols).  Bail out if a symbol is given more
 183     ;; than once.
 184     (fold (lambda (service set)
 185             (define (assert-unique symbol)
 186               (when (set-contains? set symbol)
 187                 (raise (condition
 188                         (&message
 189                          (message
 190                           (format #f (G_ "service '~a' provided more than once")
 191                                   symbol)))))))
 192
 193             (for-each assert-unique (shepherd-service-provision service))
 194             (fold set-insert set (shepherd-service-provision service)))
 195           (setq 'shepherd)
 196           services))
 197
 198   (define (assert-satisfied-requirements service)
 199     ;; Bail out if the requirements of SERVICE aren't satisfied.
 200     (for-each (lambda (requirement)
 201                 (unless (set-contains? provisions requirement)
 202                   (raise (condition
 203                           (&message
 204                            (message
 205                             (format #f (G_ "service '~a' requires '~a', \
 206 which is not provided by any service")
 207                                     (match (shepherd-service-provision service)
 208                                       ((head . _) head)
 209                                       (_          service))
 210                                     requirement)))))))
 211               (shepherd-service-requirement service)))
 212
 213   (for-each assert-satisfied-requirements services))
 214
 215 (define (shepherd-service-file-name service)
 216   "Return the file name where the initialization code for SERVICE is to be
 217 stored."
 218   (let ((provisions (string-join (map symbol->string
 219                                       (shepherd-service-provision service)))))
 220     (string-append "shepherd-"
 221                    (string-map (match-lambda
 222                                  (#\/ #\-)
 223                                  (#\  #\-)
 224                                  (chr chr))
 225                                provisions)
 226                    ".scm")))
 227
 228 (define (shepherd-service-file service)
 229   "Return a file defining SERVICE."
 230   (scheme-file (shepherd-service-file-name service)
 231                (with-imported-modules %default-imported-modules
 232                  #~(begin
 233                      (use-modules #$@(shepherd-service-modules service))
 234
 235                      (make <service>
 236                        #:docstring '#$(shepherd-service-documentation service)
 237                        #:provides '#$(shepherd-service-provision service)
 238                        #:requires '#$(shepherd-service-requirement service)
 239                        #:respawn? '#$(shepherd-service-respawn? service)
 240                        #:start #$(shepherd-service-start service)
 241                        #:stop #$(shepherd-service-stop service)
 242                        #:actions
 243                        (make-actions
 244                         #$@(map (match-lambda
 245                                   (($ <shepherd-action> name proc doc)
 246                                    #~(#$name #$doc #$proc)))
 247                                 (shepherd-service-actions service))))))))
 248
 249 (define (shepherd-configuration-file services)
 250   "Return the shepherd configuration file for SERVICES."
 251   (assert-valid-graph services)
 252
 253   (let ((files (map shepherd-service-file services)))
 254     (define config
 255       #~(begin
 256           (use-modules (srfi srfi-34)
 257                        (system repl error-handling))
 258
 259           ;; Arrange to spawn a REPL if something goes wrong.  This is better
 260           ;; than a kernel panic.
 261           (call-with-error-handling
 262             (lambda ()
 263               (apply register-services (map primitive-load '#$files))
 264
 265               ;; guix-daemon 0.6 aborts if 'PATH' is undefined, so work around
 266               ;; it.
 267               (setenv "PATH" "/run/current-system/profile/bin")
 268
 269               (format #t "starting services...~%")
 270               (for-each (lambda (service)
 271                           ;; In the Shepherd 0.3 the 'start' method can raise
 272                           ;; '&action-runtime-error' if it fails, so protect
 273                           ;; against it.  (XXX: 'action-runtime-error?' is not
 274                           ;; exported is 0.3, hence 'service-error?'.)
 275                           (guard (c ((service-error? c)
 276                                      (format (current-error-port)
 277                                              "failed to start service '~a'~%"
 278                                              service)))
 279                             (start service)))
 280                         '#$(append-map shepherd-service-provision
 281                                        (filter shepherd-service-auto-start?
 282                                                services)))))))
 283
 284     (scheme-file "shepherd.conf" config)))
 285
 286 (define* (shepherd-service-lookup-procedure services
 287                                             #:optional
 288                                             (provision
 289                                              shepherd-service-provision))
 290   "Return a procedure that, when passed a symbol, return the item among
 291 SERVICES that provides this symbol.  PROVISION must be a one-argument
 292 procedure that takes a service and returns the list of symbols it provides."
 293   (let ((services (fold (lambda (service result)
 294                           (fold (cut vhash-consq <> service <>)
 295                                 result
 296                                 (provision service)))
 297                         vlist-null
 298                         services)))
 299     (lambda (name)
 300       (match (vhash-assq name services)
 301         ((_ . service) service)
 302         (#f            #f)))))
 303
 304 (define* (shepherd-service-back-edges services
 305                                       #:key
 306                                       (provision shepherd-service-provision)
 307                                       (requirement shepherd-service-requirement))
 308   "Return a procedure that, when given a <shepherd-service> from SERVICES,
 309 returns the list of <shepherd-service> that depend on it.
 310
 311 Use PROVISION and REQUIREMENT as one-argument procedures that return the
 312 symbols provided/required by a service."
 313   (define provision->service
 314     (shepherd-service-lookup-procedure services provision))
 315
 316   (define edges
 317     (fold (lambda (service edges)
 318             (fold (lambda (requirement edges)
 319                     (vhash-consq (provision->service requirement) service
 320                                  edges))
 321                   edges
 322                   (requirement service)))
 323           vlist-null
 324           services))
 325
 326   (lambda (service)
 327     (vhash-foldq* cons '() service edges)))
 328
 329 (define (shepherd-service-upgrade live target)
 330   "Return two values: the subset of LIVE (a list of <live-service>) that needs
 331 to be unloaded, and the subset of TARGET (a list of <shepherd-service>) that
 332 needs to be loaded."
 333   (define (essential? service)
 334     (memq (first (live-service-provision service))
 335           '(root shepherd)))
 336
 337   (define lookup-target
 338     (shepherd-service-lookup-procedure target
 339                                        shepherd-service-provision))
 340
 341   (define lookup-live
 342     (shepherd-service-lookup-procedure live
 343                                        live-service-provision))
 344
 345   (define (running? service)
 346     (and=> (lookup-live (shepherd-service-canonical-name service))
 347            live-service-running))
 348
 349   (define (stopped service)
 350     (match (lookup-live (shepherd-service-canonical-name service))
 351       (#f #f)
 352       (service (and (not (live-service-running service))
 353                     service))))
 354
 355   (define live-service-dependents
 356     (shepherd-service-back-edges live
 357                                  #:provision live-service-provision
 358                                  #:requirement live-service-requirement))
 359
 360   (define (obsolete? service)
 361     (match (lookup-target (first (live-service-provision service)))
 362       (#f (every obsolete? (live-service-dependents service)))
 363       (_  #f)))
 364
 365   (define to-load
 366     ;; Only load services that are either new or currently stopped.
 367     (remove running? target))
 368
 369   (define to-unload
 370     ;; Unload services that are (1) no longer required, or (2) are in TO-LOAD.
 371     (remove essential?
 372             (append (filter obsolete? live)
 373                     (filter-map stopped to-load))))
 374
 375   (values to-unload to-load))
 376
 377 ;;; shepherd.scm ends here