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>
5 ;;; This file is part of GNU Guix.
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.
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.
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/>.
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
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
46 live-service-provision
47 live-service-requirement
49 live-service-canonical-name
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
70 (define %shepherd-socket-file
71 (make-parameter "/var/run/shepherd/socket"))
73 (define* (open-connection #:optional (file (%shepherd-socket-file)))
74 "Open a connection to the daemon, using the Unix-domain socket at FILE, and
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)))
82 (connect sock address)
83 (setvbuf sock 'block 1024)
87 (apply throw args))))))
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)))
97 (close-port connection)))))
99 (define-condition-type &shepherd-error &error
102 (define-condition-type &service-not-found-error &shepherd-error
103 service-not-found-error?
104 (service service-not-found-error-service))
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))
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))
118 (define-condition-type &unknown-shepherd-error &shepherd-error
119 unknown-shepherd-error?
120 (sexp unknown-shepherd-error-sexp))
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."
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
134 (('error ('version 0 x ...) 'action-exception action service
136 (raise (condition (&action-exception-error
139 (key key) (args args)))))
141 (raise (condition (&unknown-shepherd-error (sexp error)))))
145 (define shepherd-message-port
146 ;; Port where messages coming from shepherd are printed.
147 (make-parameter (current-error-port)))
149 (define (display-message message)
150 (format (shepherd-message-port) "shepherd: ~a~%" message))
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
157 (write `(shepherd-command (version 0)
160 (arguments ,arguments)
161 (directory ,(getcwd)))
166 (('reply ('version 0 _ ...) ('result result) ('error #f)
167 ('messages messages))
168 (for-each display-message messages)
170 (('reply ('version 0 x ...) ('result y) ('error error)
171 ('messages messages))
172 (for-each display-message messages)
173 (raise-shepherd-error error)
179 (define-syntax-rule (with-shepherd-action service (action args ...)
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 ...)))
186 (define-syntax alist-let*
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
191 ((_ alist (key ...) exp ...)
192 (let ((key (and=> (assoc-ref alist 'key) car)) ...)
195 ;; Information about live Shepherd services.
196 (define-record-type <live-service>
197 (live-service provision requirement running)
199 (provision live-service-provision) ;list of symbols
200 (requirement live-service-requirement) ;list of symbols
201 (running live-service-running)) ;#f | object
203 (define (live-service-canonical-name service)
204 "Return the 'canonical name' of SERVICE."
205 (first (live-service-provision service)))
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
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.
217 ((('service ('version 0 _ ...) _ ...) ...)
218 (map (lambda (service)
219 (alist-let* service (provides requires running)
220 (live-service provides requires running)))
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
230 (define (%load-file file)
231 "Load FILE in the Shepherd."
232 (with-shepherd-action 'root ('load file) result
235 (define (eval-there exp)
236 "Eval EXP in the Shepherd."
237 (with-shepherd-action 'root ('eval (object->string exp)) result
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))
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.
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)))))
262 (apply register-services
265 (remove registered? services))))))
267 (define* (start-service name #:optional (arguments '()))
268 (invoke-action name 'start arguments
272 (define (stop-service name)
273 (with-shepherd-action name ('stop) result
276 (define (restart-service name)
277 (with-shepherd-action name ('restart) result
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)
286 ;;; herd.scm ends here