gnu/services/herd.scm

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