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