gnu/services/shepherd.scm

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