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