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 packages admin)
  29   #:use-module (ice-9 match)
  30   #:use-module (ice-9 vlist)
  31   #:use-module (srfi srfi-1)
  32   #:use-module (srfi srfi-26)
  33   #:use-module (srfi srfi-34)
  34   #:use-module (srfi srfi-35)
  35   #:export (shepherd-root-service-type
  36             %shepherd-root-service
  37             shepherd-service-type
  38
  39             shepherd-service
  40             shepherd-service?
  41             shepherd-service-documentation
  42             shepherd-service-provision
  43             shepherd-service-requirement
  44             shepherd-service-respawn?
  45             shepherd-service-start
  46             shepherd-service-stop
  47             shepherd-service-auto-start?
  48             shepherd-service-modules
  49             shepherd-service-imported-modules
  50
  51             %default-imported-modules
  52             %default-modules
  53
  54             shepherd-service-back-edges))
  55
  56 ;;; Commentary:
  57 ;;;
  58 ;;; Instantiating system services as a shepherd configuration file.
  59 ;;;
  60 ;;; Code:
  61
  62
  63 (define (shepherd-boot-gexp services)
  64   (mlet %store-monad ((shepherd-conf (shepherd-configuration-file services)))
  65     (return #~(begin
  66                 ;; Keep track of the booted system.
  67                 (false-if-exception (delete-file "/run/booted-system"))
  68                 (symlink (readlink "/run/current-system")
  69                          "/run/booted-system")
  70
  71                 ;; Close any remaining open file descriptors to be on the safe
  72                 ;; side.  This must be the very last thing we do, because
  73                 ;; Guile has internal FDs such as 'sleep_pipe' that need to be
  74                 ;; alive.
  75                 (let loop ((fd 3))
  76                   (when (< fd 1024)
  77                     (false-if-exception (close-fdes fd))
  78                     (loop (+ 1 fd))))
  79
  80                 ;; Start shepherd.
  81                 (execl (string-append #$shepherd "/bin/shepherd")
  82                        "shepherd" "--config" #$shepherd-conf)))))
  83
  84 (define shepherd-root-service-type
  85   (service-type
  86    (name 'shepherd-root)
  87    ;; Extending the root shepherd service (aka. PID 1) happens by
  88    ;; concatenating the list of services provided by the extensions.
  89    (compose concatenate)
  90    (extend append)
  91    (extensions (list (service-extension boot-service-type
  92                                         shepherd-boot-gexp)
  93                      (service-extension profile-service-type
  94                                         (const (list shepherd)))))))
  95
  96 (define %shepherd-root-service
  97   ;; The root shepherd service, aka. PID 1.  Its parameter is a list of
  98   ;; <shepherd-service> objects.
  99   (service shepherd-root-service-type '()))
 100
 101 (define-syntax-rule (shepherd-service-type service-name proc)
 102   "Return a <service-type> denoting a simple shepherd service--i.e., the type
 103 for a service that extends SHEPHERD-ROOT-SERVICE-TYPE and nothing else."
 104   (service-type
 105    (name service-name)
 106    (extensions
 107     (list (service-extension shepherd-root-service-type
 108                              (compose list proc))))))
 109
 110 (define %default-imported-modules
 111   ;; Default set of modules imported for a service's consumption.
 112   '((guix build utils)
 113     (guix build syscalls)))
 114
 115 (define %default-modules
 116   ;; Default set of modules visible in a service's file.
 117   `((shepherd service)
 118     (oop goops)
 119     (guix build utils)
 120     (guix build syscalls)))
 121
 122 (define-record-type* <shepherd-service>
 123   shepherd-service make-shepherd-service
 124   shepherd-service?
 125   (documentation shepherd-service-documentation        ;string
 126                  (default "[No documentation.]"))
 127   (provision     shepherd-service-provision)           ;list of symbols
 128   (requirement   shepherd-service-requirement          ;list of symbols
 129                  (default '()))
 130   (respawn?      shepherd-service-respawn?             ;Boolean
 131                  (default #t))
 132   (start         shepherd-service-start)               ;g-expression (procedure)
 133   (stop          shepherd-service-stop                 ;g-expression (procedure)
 134                  (default #~(const #f)))
 135   (auto-start?   shepherd-service-auto-start?          ;Boolean
 136                  (default #t))
 137   (modules       shepherd-service-modules              ;list of module names
 138                  (default %default-modules))
 139   (imported-modules shepherd-service-imported-modules  ;list of module names
 140                     (default %default-imported-modules)))
 141
 142
 143 (define (assert-valid-graph services)
 144   "Raise an error if SERVICES does not define a valid shepherd service graph,
 145 for instance if a service requires a nonexistent service, or if more than one
 146 service uses a given name.
 147
 148 These are constraints that shepherd's 'register-service' verifies but we'd
 149 better verify them here statically than wait until PID 1 halts with an
 150 assertion failure."
 151   (define provisions
 152     ;; The set of provisions (symbols).  Bail out if a symbol is given more
 153     ;; than once.
 154     (fold (lambda (service set)
 155             (define (assert-unique symbol)
 156               (when (set-contains? set symbol)
 157                 (raise (condition
 158                         (&message
 159                          (message
 160                           (format #f (_ "service '~a' provided more than once")
 161                                   symbol)))))))
 162
 163             (for-each assert-unique (shepherd-service-provision service))
 164             (fold set-insert set (shepherd-service-provision service)))
 165           (setq 'shepherd)
 166           services))
 167
 168   (define (assert-satisfied-requirements service)
 169     ;; Bail out if the requirements of SERVICE aren't satisfied.
 170     (for-each (lambda (requirement)
 171                 (unless (set-contains? provisions requirement)
 172                   (raise (condition
 173                           (&message
 174                            (message
 175                             (format #f (_ "service '~a' requires '~a', \
 176 which is undefined")
 177                                     (match (shepherd-service-provision service)
 178                                       ((head . _) head)
 179                                       (_          service))
 180                                     requirement)))))))
 181               (shepherd-service-requirement service)))
 182
 183   (for-each assert-satisfied-requirements services))
 184
 185 (define (shepherd-service-file-name service)
 186   "Return the file name where the initialization code for SERVICE is to be
 187 stored."
 188   (let ((provisions (string-join (map symbol->string
 189                                       (shepherd-service-provision service)))))
 190     (string-append "shepherd-"
 191                    (string-map (match-lambda
 192                                  (#\/ #\-)
 193                                  (chr chr))
 194                                provisions)
 195                    ".scm")))
 196
 197 (define (shepherd-service-file service)
 198   "Return a file defining SERVICE."
 199   (gexp->file (shepherd-service-file-name service)
 200               #~(begin
 201                   (use-modules #$@(shepherd-service-modules service))
 202
 203                   (make <service>
 204                     #:docstring '#$(shepherd-service-documentation service)
 205                     #:provides '#$(shepherd-service-provision service)
 206                     #:requires '#$(shepherd-service-requirement service)
 207                     #:respawn? '#$(shepherd-service-respawn? service)
 208                     #:start #$(shepherd-service-start service)
 209                     #:stop #$(shepherd-service-stop service)))))
 210
 211 (define (shepherd-configuration-file services)
 212   "Return the shepherd configuration file for SERVICES."
 213   (define modules
 214     (delete-duplicates
 215      (append-map shepherd-service-imported-modules services)))
 216
 217   (assert-valid-graph services)
 218
 219   (mlet %store-monad ((modules  (imported-modules modules))
 220                       (compiled (compiled-modules modules))
 221                       (files    (mapm %store-monad
 222                                       shepherd-service-file
 223                                       services)))
 224     (define config
 225       #~(begin
 226           (eval-when (expand load eval)
 227             (set! %load-path (cons #$modules %load-path))
 228             (set! %load-compiled-path
 229               (cons #$compiled %load-compiled-path)))
 230
 231           (use-modules (system repl error-handling))
 232
 233           ;; Arrange to spawn a REPL if loading one of FILES fails.  This is
 234           ;; better than a kernel panic.
 235           (call-with-error-handling
 236             (lambda ()
 237               (apply register-services (map primitive-load '#$files))))
 238
 239           ;; guix-daemon 0.6 aborts if 'PATH' is undefined, so work around it.
 240           (setenv "PATH" "/run/current-system/profile/bin")
 241
 242           (format #t "starting services...~%")
 243           (for-each start
 244                     '#$(append-map shepherd-service-provision
 245                                    (filter shepherd-service-auto-start?
 246                                            services)))))
 247
 248     (gexp->file "shepherd.conf" config)))
 249
 250 (define (shepherd-service-back-edges services)
 251   "Return a procedure that, when given a <shepherd-service> from SERVICES,
 252 returns the list of <shepherd-service> that depend on it."
 253   (define provision->service
 254     (let ((services (fold (lambda (service result)
 255                             (fold (cut vhash-consq <> service <>)
 256                                   result
 257                                   (shepherd-service-provision service)))
 258                           vlist-null
 259                           services)))
 260       (lambda (name)
 261         (match (vhash-assq name services)
 262           ((_ . service) service)
 263           (#f            #f)))))
 264
 265   (define edges
 266     (fold (lambda (service edges)
 267             (fold (lambda (requirement edges)
 268                     (vhash-consq (provision->service requirement) service
 269                                  edges))
 270                   edges
 271                   (shepherd-service-requirement service)))
 272           vlist-null
 273           services))
 274
 275   (lambda (service)
 276     (vhash-foldq* cons '() service edges)))
 277
 278 ;;; shepherd.scm ends here