gnu/services/herd.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (gnu services herd)
  20   #:use-module (srfi srfi-1)
  21   #:use-module (srfi srfi-9)
  22   #:use-module (srfi srfi-11)
  23   #:use-module (srfi srfi-34)
  24   #:use-module (srfi srfi-35)
  25   #:use-module (ice-9 match)
  26   #:export (shepherd-error?
  27             service-not-found-error?
  28             service-not-found-error-service
  29             action-not-found-error?
  30             action-not-found-error-service
  31             action-not-found-error-action
  32             action-exception-error?
  33             action-exception-error-service
  34             action-exception-error-action
  35             action-exception-error-key
  36             action-exception-error-arguments
  37             unknown-shepherd-error?
  38             unknown-shepherd-error-sexp
  39
  40             live-service?
  41             live-service-provision
  42             live-service-requirement
  43             live-service-running
  44
  45             current-services
  46             unload-services
  47             unload-service
  48             load-services
  49             start-service))
  50
  51 ;;; Commentary:
  52 ;;;
  53 ;;; This module provides an interface to the GNU Shepherd, similar to the
  54 ;;; 'herd' command.  Essentially it implements a subset of the (shepherd comm)
  55 ;;; module, but focusing only on the parts relevant to 'guix system
  56 ;;; reconfigure'.
  57 ;;;
  58 ;;; Code:
  59
  60 (define %shepherd-socket-file
  61   "/var/run/shepherd/socket")
  62
  63 (define* (open-connection #:optional (file %shepherd-socket-file))
  64   "Open a connection to the daemon, using the Unix-domain socket at FILE, and
  65 return the socket."
  66   ;; The protocol is sexp-based and UTF-8-encoded.
  67   (with-fluids ((%default-port-encoding "UTF-8"))
  68     (let ((sock    (socket PF_UNIX SOCK_STREAM 0))
  69           (address (make-socket-address PF_UNIX file)))
  70       (catch 'system-error
  71         (lambda ()
  72           (connect sock address)
  73           (setvbuf sock _IOFBF 1024)
  74           sock)
  75         (lambda args
  76           (close-port sock)
  77           (apply throw args))))))
  78
  79 (define-syntax-rule (with-shepherd connection body ...)
  80   "Evaluate BODY... with CONNECTION bound to an open socket to PID 1."
  81   (let ((connection (open-connection)))
  82     body ...))
  83
  84 (define-condition-type &shepherd-error &error
  85   shepherd-error?)
  86
  87 (define-condition-type &service-not-found-error &shepherd-error
  88   service-not-found-error?
  89   (service service-not-found-error-service))
  90
  91 (define-condition-type &action-not-found-error &shepherd-error
  92   action-not-found-error?
  93   (service action-not-found-error-service)
  94   (action  action-not-found-error-action))
  95
  96 (define-condition-type &action-exception-error &shepherd-error
  97   action-exception-error?
  98   (service action-exception-error-service)
  99   (action  action-exception-error-action)
 100   (key     action-exception-error-key)
 101   (args    action-exception-error-arguments))
 102
 103 (define-condition-type &unknown-shepherd-error &shepherd-error
 104   unknown-shepherd-error?
 105   (sexp   unknown-shepherd-error-sexp))
 106
 107 (define (raise-shepherd-error error)
 108   "Raise an error condition corresponding to ERROR, an sexp received by a
 109 shepherd client in reply to COMMAND, a command object.  Return #t if ERROR
 110 does not denote an error."
 111   (match error
 112     (('error ('version 0 x ...) 'service-not-found service)
 113      (raise (condition (&service-not-found-error
 114                         (service service)))))
 115     (('error ('version 0 x ...) 'action-not-found action service)
 116      (raise (condition (&action-not-found-error
 117                         (service service)
 118                         (action action)))))
 119     (('error ('version 0 x ...) 'action-exception action service
 120              key (args ...))
 121      (raise (condition (&action-exception-error
 122                         (service service)
 123                         (action action)
 124                         (key key) (args args)))))
 125     (('error . _)
 126      (raise (condition (&unknown-shepherd-error (sexp error)))))
 127     (#f                                           ;not an error
 128      #t)))
 129
 130 (define (display-message message)
 131   (format (current-error-port) "shepherd: ~a~%" message))
 132
 133 (define* (invoke-action service action arguments cont)
 134   "Invoke ACTION on SERVICE with ARGUMENTS.  On success, call CONT with the
 135 result.  Otherwise return #f."
 136   (with-shepherd sock
 137     (write `(shepherd-command (version 0)
 138                               (action ,action)
 139                               (service ,service)
 140                               (arguments ,arguments)
 141                               (directory ,(getcwd)))
 142            sock)
 143     (force-output sock)
 144
 145     (match (read sock)
 146       (('reply ('version 0 _ ...) ('result (result)) ('error #f)
 147                ('messages messages))
 148        (for-each display-message messages)
 149        (cont result))
 150       (('reply ('version 0 x ...) ('result y) ('error error)
 151                ('messages messages))
 152        (for-each display-message messages)
 153        (raise-shepherd-error error)
 154        #f)
 155       (x
 156        ;; invalid reply
 157        #f))))
 158
 159 (define-syntax-rule (with-shepherd-action service (action args ...)
 160                       result body ...)
 161   (invoke-action service action (list args ...)
 162                  (lambda (result) body ...)))
 163
 164 (define-syntax alist-let*
 165   (syntax-rules ()
 166     "Bind the given KEYs in EXP to the corresponding items in ALIST.  ALIST
 167 is assumed to be a list of two-element tuples rather than a traditional list
 168 of pairs."
 169     ((_ alist (key ...) exp ...)
 170      (let ((key (and=> (assoc-ref alist 'key) car)) ...)
 171        exp ...))))
 172
 173 ;; Information about live Shepherd services.
 174 (define-record-type <live-service>
 175   (live-service provision requirement running)
 176   live-service?
 177   (provision    live-service-provision)           ;list of symbols
 178   (requirement  live-service-requirement)         ;list of symbols
 179   (running      live-service-running))            ;#f | object
 180
 181 (define (current-services)
 182   "Return the list of currently defined Shepherd services, represented as
 183 <live-service> objects.  Return #f if the list of services could not be
 184 obtained."
 185   (with-shepherd-action 'root ('status) services
 186     (match services
 187       ((('service ('version 0 _ ...) _ ...) ...)
 188        (map (lambda (service)
 189               (alist-let* service (provides requires running)
 190                 (live-service provides requires running)))
 191             services))
 192       (x
 193        #f))))
 194
 195 (define (unload-service service)
 196   "Unload SERVICE, a symbol name; return #t on success."
 197   (with-shepherd-action 'root ('unload (symbol->string service)) result
 198     result))
 199
 200 (define (%load-file file)
 201   "Load FILE in the Shepherd."
 202   (with-shepherd-action 'root ('load file) result
 203     result))
 204
 205 (define (eval-there exp)
 206   "Eval EXP in the Shepherd."
 207   (with-shepherd-action 'root ('eval (object->string exp)) result
 208     result))
 209
 210 (define (load-services files)
 211   "Load and register the services from FILES, where FILES contain code that
 212 returns a shepherd <service> object."
 213   (eval-there `(register-services
 214                 ,@(map (lambda (file)
 215                          `(primitive-load ,file))
 216                        files))))
 217
 218 (define (start-service name)
 219   (with-shepherd-action name ('start) result
 220     result))
 221
 222 ;; Local Variables:
 223 ;; eval: (put 'alist-let* 'scheme-indent-function 2)
 224 ;; eval: (put 'with-shepherd 'scheme-indent-function 1)
 225 ;; eval: (put 'with-shepherd-action 'scheme-indent-function 3)
 226 ;; End:
 227
 228 ;;; herd.scm ends here