gnu/services/herd.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016-2019, 2022 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-9 gnu)
  24   #:use-module (srfi srfi-11)
  25   #:use-module (srfi srfi-34)
  26   #:use-module (srfi srfi-35)
  27   #:use-module (ice-9 match)
  28   #:export (%shepherd-socket-file
  29             shepherd-message-port
  30
  31             shepherd-error?
  32             service-not-found-error?
  33             service-not-found-error-service
  34             action-not-found-error?
  35             action-not-found-error-service
  36             action-not-found-error-action
  37             action-exception-error?
  38             action-exception-error-service
  39             action-exception-error-action
  40             action-exception-error-key
  41             action-exception-error-arguments
  42             unknown-shepherd-error?
  43             unknown-shepherd-error-sexp
  44
  45             live-service
  46             live-service?
  47             live-service-provision
  48             live-service-requirement
  49             live-service-running
  50             live-service-transient?
  51             live-service-canonical-name
  52
  53             with-shepherd-action
  54             current-services
  55             unload-services
  56             unload-service
  57             load-services
  58             load-services/safe
  59             start-service
  60             stop-service
  61             restart-service
  62             wait-for-service))
  63
  64 ;;; Commentary:
  65 ;;;
  66 ;;; This module provides an interface to the GNU Shepherd, similar to the
  67 ;;; 'herd' command.  Essentially it implements a subset of the (shepherd comm)
  68 ;;; module, but focusing only on the parts relevant to 'guix system
  69 ;;; reconfigure'.
  70 ;;;
  71 ;;; Code:
  72
  73 (define %shepherd-socket-file
  74   (make-parameter "/var/run/shepherd/socket"))
  75
  76 (define* (open-connection #:optional (file (%shepherd-socket-file)))
  77   "Open a connection to the daemon, using the Unix-domain socket at FILE, and
  78 return the socket."
  79   ;; The protocol is sexp-based and UTF-8-encoded.
  80   (with-fluids ((%default-port-encoding "UTF-8"))
  81     (let ((sock    (socket PF_UNIX SOCK_STREAM 0))
  82           (address (make-socket-address PF_UNIX file)))
  83       (catch 'system-error
  84         (lambda ()
  85           (connect sock address)
  86           (setvbuf sock 'block 1024)
  87           sock)
  88         (lambda args
  89           (close-port sock)
  90           (apply throw args))))))
  91
  92 (define-syntax-rule (with-shepherd connection body ...)
  93   "Evaluate BODY... with CONNECTION bound to an open socket to PID 1."
  94   (let ((connection (open-connection)))
  95     (dynamic-wind
  96       (const #t)
  97       (lambda ()
  98         body ...)
  99       (lambda ()
 100         (close-port connection)))))
 101
 102 (define-condition-type &shepherd-error &error
 103   shepherd-error?)
 104
 105 (define-condition-type &service-not-found-error &shepherd-error
 106   service-not-found-error?
 107   (service service-not-found-error-service))
 108
 109 (define-condition-type &action-not-found-error &shepherd-error
 110   action-not-found-error?
 111   (service action-not-found-error-service)
 112   (action  action-not-found-error-action))
 113
 114 (define-condition-type &action-exception-error &shepherd-error
 115   action-exception-error?
 116   (service action-exception-error-service)
 117   (action  action-exception-error-action)
 118   (key     action-exception-error-key)
 119   (args    action-exception-error-arguments))
 120
 121 (define-condition-type &unknown-shepherd-error &shepherd-error
 122   unknown-shepherd-error?
 123   (sexp   unknown-shepherd-error-sexp))
 124
 125 (define (raise-shepherd-error error)
 126   "Raise an error condition corresponding to ERROR, an sexp received by a
 127 shepherd client in reply to COMMAND, a command object.  Return #t if ERROR
 128 does not denote an error."
 129   (match error
 130     (('error ('version 0 x ...) 'service-not-found service)
 131      (raise (condition (&service-not-found-error
 132                         (service service)))))
 133     (('error ('version 0 x ...) 'action-not-found action service)
 134      (raise (condition (&action-not-found-error
 135                         (service service)
 136                         (action action)))))
 137     (('error ('version 0 x ...) 'action-exception action service
 138              key (args ...))
 139      (raise (condition (&action-exception-error
 140                         (service service)
 141                         (action action)
 142                         (key key) (args args)))))
 143     (('error . _)
 144      (raise (condition (&unknown-shepherd-error (sexp error)))))
 145     (#f                                           ;not an error
 146      #t)))
 147
 148 (define shepherd-message-port
 149   ;; Port where messages coming from shepherd are printed.
 150   (make-parameter (current-error-port)))
 151
 152 (define (display-message message)
 153   (format (shepherd-message-port) "shepherd: ~a~%" message))
 154
 155 (define* (invoke-action service action arguments cont)
 156   "Invoke ACTION on SERVICE with ARGUMENTS.  On success, call CONT with the
 157 list of results (one result per instance with the name SERVICE).  Otherwise
 158 return #f."
 159   (with-shepherd sock
 160     (write `(shepherd-command (version 0)
 161                               (action ,action)
 162                               (service ,service)
 163                               (arguments ,arguments)
 164                               (directory ,(getcwd)))
 165            sock)
 166     (force-output sock)
 167
 168     (match (read sock)
 169       (('reply ('version 0 _ ...) ('result result) ('error #f)
 170                ('messages messages))
 171        (for-each display-message messages)
 172        (cont result))
 173       (('reply ('version 0 x ...) ('result y) ('error error)
 174                ('messages messages))
 175        (for-each display-message messages)
 176        (raise-shepherd-error error)
 177        #f)
 178       (x
 179        ;; invalid reply
 180        #f))))
 181
 182 (define-syntax-rule (with-shepherd-action service (action args ...)
 183                       result body ...)
 184   "Invoke ACTION on SERVICE with the given ARGS, and evaluate BODY with RESULT
 185 bound to the action's result."
 186   (invoke-action service action (list args ...)
 187                  (lambda (result) body ...)))
 188
 189 (define-syntax alist-let*
 190   (syntax-rules ()
 191     "Bind the given KEYs in EXP to the corresponding items in ALIST.  ALIST
 192 is assumed to be a list of two-element tuples rather than a traditional list
 193 of pairs."
 194     ((_ alist (key ...) exp ...)
 195      (let ((key (and=> (assoc-ref alist 'key) car)) ...)
 196        exp ...))))
 197
 198 ;; Information about live Shepherd services.
 199 (define-record-type <live-service>
 200   (live-service provision requirement transient? running)
 201   live-service?
 202   (provision    live-service-provision)           ;list of symbols
 203   (requirement  live-service-requirement)         ;list of symbols
 204   (transient?   live-service-transient?)          ;Boolean
 205   (running      live-service-running))            ;#f | object
 206
 207 (define (live-service-canonical-name service)
 208   "Return the 'canonical name' of SERVICE."
 209   (first (live-service-provision service)))
 210
 211 (define (current-services)
 212   "Return the list of currently defined Shepherd services, represented as
 213 <live-service> objects.  Return #f if the list of services could not be
 214 obtained."
 215   (with-shepherd-action 'root ('status) results
 216     ;; We get a list of results, one for each service with the name 'root'.
 217     ;; In practice there's only one such service though.
 218     (match results
 219       ((services _ ...)
 220        (match services
 221          ((('service ('version 0 _ ...) _ ...) ...)
 222           (resolve-transients
 223            (map (lambda (service)
 224                   (alist-let* service (provides requires running transient?)
 225                     ;; The Shepherd 0.9.0 would not provide 'transient?' in its
 226                     ;; status sexp.  Thus, when it's missing, query it via an
 227                     ;; "eval" request.
 228                     (live-service provides requires
 229                                   (if (sloppy-assq 'transient? service)
 230                                       transient?
 231                                       (and running *unspecified*))
 232                                   running)))
 233                 services)))
 234          (x
 235           #f))))))
 236
 237 (define (resolve-transients services)
 238   "Resolve the subset of SERVICES whose 'transient?' field is undefined.  This
 239 is necessary to deal with Shepherd 0.9.0, which did not communicate whether a
 240 service is transient."
 241   ;; All the fuss here is to make sure we make a single "eval root" request
 242   ;; for all of SERVICES.
 243   (let* ((unresolved (filter (compose unspecified? live-service-transient?)
 244                              services))
 245          (values     (or (eval-there
 246                           `(and (defined? 'transient?) ;shepherd >= 0.9.0
 247                                 (map (compose transient? lookup-running)
 248                                      ',(map (compose first
 249                                                      live-service-provision)
 250                                             unresolved))))
 251                          (make-list (length unresolved) #f)))
 252          (resolved   (map (lambda (unresolved transient?)
 253                             (cons unresolved
 254                                   (set-field unresolved
 255                                              (live-service-transient?)
 256                                              transient?)))
 257                           unresolved values)))
 258     (map (lambda (service)
 259            (or (assq-ref resolved service) service))
 260          services)))
 261
 262 (define (unload-service service)
 263   "Unload SERVICE, a symbol name; return #t on success."
 264   (with-shepherd-action 'root ('unload (symbol->string service)) result
 265     (first result)))
 266
 267 (define (%load-file file)
 268   "Load FILE in the Shepherd."
 269   (with-shepherd-action 'root ('load file) result
 270     (first result)))
 271
 272 (define (eval-there exp)
 273   "Eval EXP in the Shepherd."
 274   (with-shepherd-action 'root ('eval (object->string exp)) result
 275     (first result)))
 276
 277 (define (load-services files)
 278   "Load and register the services from FILES, where FILES contain code that
 279 returns a shepherd <service> object."
 280   (eval-there `(register-services
 281                 ,@(map (lambda (file)
 282                          `(primitive-load ,file))
 283                        files))))
 284
 285 (define (load-services/safe files)
 286   "This is like 'load-services', but make sure only the subset of FILES that
 287 can be safely reloaded is actually reloaded.
 288
 289 This is done to accommodate the Shepherd < 0.15.0 where services lacked the
 290 'replacement' slot, and where 'register-services' would throw an exception
 291 when passed a service with an already-registered name."
 292   (eval-there `(let* ((services     (map primitive-load ',files))
 293                       (slots        (map slot-definition-name
 294                                          (class-slots <service>)))
 295                       (can-replace? (memq 'replacement slots)))
 296                  (define (registered? service)
 297                    (not (null? (lookup-services (canonical-name service)))))
 298
 299                  (apply register-services
 300                         (if can-replace?
 301                             services
 302                             (remove registered? services))))))
 303
 304 (define* (start-service name #:optional (arguments '()))
 305   (invoke-action name 'start arguments
 306                  (lambda (result)
 307                    result)))
 308
 309 (define (stop-service name)
 310   (with-shepherd-action name ('stop) result
 311     result))
 312
 313 (define (restart-service name)
 314   (with-shepherd-action name ('restart) result
 315     result))
 316
 317 (define* (wait-for-service name #:key (timeout 20))
 318   "Wait for the service providing NAME, a symbol, to be up and running, and
 319 return its \"running value\".  Give up after TIMEOUT seconds and raise a
 320 '&shepherd-error' exception.  Raise a '&service-not-found-error' exception
 321 when NAME is not found."
 322   (define (relevant-service? service)
 323     (memq name (live-service-provision service)))
 324
 325   (define start
 326     (car (gettimeofday)))
 327
 328   ;; Note: As of Shepherd 0.9.1, we cannot just call the 'start' method and
 329   ;; wait for it: it would spawn an additional elogind process.  Thus, poll.
 330   (let loop ((attempts 0))
 331     (define services
 332       (current-services))
 333
 334     (define now
 335       (car (gettimeofday)))
 336
 337     (when (>= (- now start) timeout)
 338       (raise (condition (&shepherd-error))))      ;XXX: better exception?
 339
 340     (match (find relevant-service? services)
 341       (#f
 342        (raise (condition (&service-not-found-error
 343                           (service name)))))
 344       (service
 345        (or (live-service-running service)
 346            (begin
 347              (sleep 1)
 348              (loop (+ attempts 1))))))))
 349
 350 ;; Local Variables:
 351 ;; eval: (put 'alist-let* 'scheme-indent-function 2)
 352 ;; eval: (put 'with-shepherd 'scheme-indent-function 1)
 353 ;; eval: (put 'with-shepherd-action 'scheme-indent-function 3)
 354 ;; End:
 355
 356 ;;; herd.scm ends here