gnu/services/herd.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
   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 herd)
  21   #:use-module (srfi srfi-1)
  22   #:use-module (srfi srfi-9)
  23   #:use-module (srfi srfi-11)
  24   #:use-module (srfi srfi-34)
  25   #:use-module (srfi srfi-35)
  26   #:use-module (ice-9 match)
  27   #:export (%shepherd-socket-file
  28
  29             shepherd-error?
  30             service-not-found-error?
  31             service-not-found-error-service
  32             action-not-found-error?
  33             action-not-found-error-service
  34             action-not-found-error-action
  35             action-exception-error?
  36             action-exception-error-service
  37             action-exception-error-action
  38             action-exception-error-key
  39             action-exception-error-arguments
  40             unknown-shepherd-error?
  41             unknown-shepherd-error-sexp
  42
  43             live-service?
  44             live-service-provision
  45             live-service-requirement
  46             live-service-running
  47
  48             with-shepherd-action
  49             current-services
  50             unload-services
  51             unload-service
  52             load-services
  53             load-services/safe
  54             start-service
  55             stop-service))
  56
  57 ;;; Commentary:
  58 ;;;
  59 ;;; This module provides an interface to the GNU Shepherd, similar to the
  60 ;;; 'herd' command.  Essentially it implements a subset of the (shepherd comm)
  61 ;;; module, but focusing only on the parts relevant to 'guix system
  62 ;;; reconfigure'.
  63 ;;;
  64 ;;; Code:
  65
  66 (define %shepherd-socket-file
  67   (make-parameter "/var/run/shepherd/socket"))
  68
  69 (define* (open-connection #:optional (file (%shepherd-socket-file)))
  70   "Open a connection to the daemon, using the Unix-domain socket at FILE, and
  71 return the socket."
  72   ;; The protocol is sexp-based and UTF-8-encoded.
  73   (with-fluids ((%default-port-encoding "UTF-8"))
  74     (let ((sock    (socket PF_UNIX SOCK_STREAM 0))
  75           (address (make-socket-address PF_UNIX file)))
  76       (catch 'system-error
  77         (lambda ()
  78           (connect sock address)
  79           (setvbuf sock 'block 1024)
  80           sock)
  81         (lambda args
  82           (close-port sock)
  83           (apply throw args))))))
  84
  85 (define-syntax-rule (with-shepherd connection body ...)
  86   "Evaluate BODY... with CONNECTION bound to an open socket to PID 1."
  87   (let ((connection (open-connection)))
  88     (dynamic-wind
  89       (const #t)
  90       (lambda ()
  91         body ...)
  92       (lambda ()
  93         (close-port connection)))))
  94
  95 (define-condition-type &shepherd-error &error
  96   shepherd-error?)
  97
  98 (define-condition-type &service-not-found-error &shepherd-error
  99   service-not-found-error?
 100   (service service-not-found-error-service))
 101
 102 (define-condition-type &action-not-found-error &shepherd-error
 103   action-not-found-error?
 104   (service action-not-found-error-service)
 105   (action  action-not-found-error-action))
 106
 107 (define-condition-type &action-exception-error &shepherd-error
 108   action-exception-error?
 109   (service action-exception-error-service)
 110   (action  action-exception-error-action)
 111   (key     action-exception-error-key)
 112   (args    action-exception-error-arguments))
 113
 114 (define-condition-type &unknown-shepherd-error &shepherd-error
 115   unknown-shepherd-error?
 116   (sexp   unknown-shepherd-error-sexp))
 117
 118 (define (raise-shepherd-error error)
 119   "Raise an error condition corresponding to ERROR, an sexp received by a
 120 shepherd client in reply to COMMAND, a command object.  Return #t if ERROR
 121 does not denote an error."
 122   (match error
 123     (('error ('version 0 x ...) 'service-not-found service)
 124      (raise (condition (&service-not-found-error
 125                         (service service)))))
 126     (('error ('version 0 x ...) 'action-not-found action service)
 127      (raise (condition (&action-not-found-error
 128                         (service service)
 129                         (action action)))))
 130     (('error ('version 0 x ...) 'action-exception action service
 131              key (args ...))
 132      (raise (condition (&action-exception-error
 133                         (service service)
 134                         (action action)
 135                         (key key) (args args)))))
 136     (('error . _)
 137      (raise (condition (&unknown-shepherd-error (sexp error)))))
 138     (#f                                           ;not an error
 139      #t)))
 140
 141 (define (display-message message)
 142   (format (current-error-port) "shepherd: ~a~%" message))
 143
 144 (define* (invoke-action service action arguments cont)
 145   "Invoke ACTION on SERVICE with ARGUMENTS.  On success, call CONT with the
 146 list of results (one result per instance with the name SERVICE).  Otherwise
 147 return #f."
 148   (with-shepherd sock
 149     (write `(shepherd-command (version 0)
 150                               (action ,action)
 151                               (service ,service)
 152                               (arguments ,arguments)
 153                               (directory ,(getcwd)))
 154            sock)
 155     (force-output sock)
 156
 157     (match (read sock)
 158       (('reply ('version 0 _ ...) ('result result) ('error #f)
 159                ('messages messages))
 160        (for-each display-message messages)
 161        (cont result))
 162       (('reply ('version 0 x ...) ('result y) ('error error)
 163                ('messages messages))
 164        (for-each display-message messages)
 165        (raise-shepherd-error error)
 166        #f)
 167       (x
 168        ;; invalid reply
 169        #f))))
 170
 171 (define-syntax-rule (with-shepherd-action service (action args ...)
 172                       result body ...)
 173   "Invoke ACTION on SERVICE with the given ARGS, and evaluate BODY with RESULT
 174 bound to the action's result."
 175   (invoke-action service action (list args ...)
 176                  (lambda (result) body ...)))
 177
 178 (define-syntax alist-let*
 179   (syntax-rules ()
 180     "Bind the given KEYs in EXP to the corresponding items in ALIST.  ALIST
 181 is assumed to be a list of two-element tuples rather than a traditional list
 182 of pairs."
 183     ((_ alist (key ...) exp ...)
 184      (let ((key (and=> (assoc-ref alist 'key) car)) ...)
 185        exp ...))))
 186
 187 ;; Information about live Shepherd services.
 188 (define-record-type <live-service>
 189   (live-service provision requirement running)
 190   live-service?
 191   (provision    live-service-provision)           ;list of symbols
 192   (requirement  live-service-requirement)         ;list of symbols
 193   (running      live-service-running))            ;#f | object
 194
 195 (define (current-services)
 196   "Return the list of currently defined Shepherd services, represented as
 197 <live-service> objects.  Return #f if the list of services could not be
 198 obtained."
 199   (with-shepherd-action 'root ('status) results
 200     ;; We get a list of results, one for each service with the name 'root'.
 201     ;; In practice there's only one such service though.
 202     (match results
 203       ((services _ ...)
 204        (match services
 205          ((('service ('version 0 _ ...) _ ...) ...)
 206           (map (lambda (service)
 207                  (alist-let* service (provides requires running)
 208                    (live-service provides requires running)))
 209                services))
 210          (x
 211           #f))))))
 212
 213 (define (unload-service service)
 214   "Unload SERVICE, a symbol name; return #t on success."
 215   (with-shepherd-action 'root ('unload (symbol->string service)) result
 216     (first result)))
 217
 218 (define (%load-file file)
 219   "Load FILE in the Shepherd."
 220   (with-shepherd-action 'root ('load file) result
 221     (first result)))
 222
 223 (define (eval-there exp)
 224   "Eval EXP in the Shepherd."
 225   (with-shepherd-action 'root ('eval (object->string exp)) result
 226     (first result)))
 227
 228 (define (load-services files)
 229   "Load and register the services from FILES, where FILES contain code that
 230 returns a shepherd <service> object."
 231   (eval-there `(register-services
 232                 ,@(map (lambda (file)
 233                          `(primitive-load ,file))
 234                        files))))
 235
 236 (define (load-services/safe files)
 237   "This is like 'load-services', but make sure only the subset of FILES that
 238 can be safely reloaded is actually reloaded.
 239
 240 This is done to accommodate the Shepherd < 0.15.0 where services lacked the
 241 'replacement' slot, and where 'register-services' would throw an exception
 242 when passed a service with an already-registered name."
 243   (eval-there `(let* ((services     (map primitive-load ',files))
 244                       (slots        (map slot-definition-name
 245                                          (class-slots <service>)))
 246                       (can-replace? (memq 'replacement slots)))
 247                  (define (registered? service)
 248                    (not (null? (lookup-services (canonical-name service)))))
 249
 250                  (apply register-services
 251                         (if can-replace?
 252                             services
 253                             (remove registered? services))))))
 254
 255 (define* (start-service name #:optional (arguments '()))
 256   (invoke-action name 'start arguments
 257                  (lambda (result)
 258                    result)))
 259
 260 (define (stop-service name)
 261   (with-shepherd-action name ('stop) result
 262     result))
 263
 264 ;; Local Variables:
 265 ;; eval: (put 'alist-let* 'scheme-indent-function 2)
 266 ;; eval: (put 'with-shepherd 'scheme-indent-function 1)
 267 ;; eval: (put 'with-shepherd-action 'scheme-indent-function 3)
 268 ;; End:
 269
 270 ;;; herd.scm ends here