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