Commit | Line | Data |
---|---|---|
240b57f0 | 1 | ;;; GNU Guix --- Functional package management for GNU |
bb64b2e7 | 2 | ;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> |
8f5a0a97 | 3 | ;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com> |
240b57f0 LC |
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) | |
240b57f0 | 21 | #:use-module (srfi srfi-1) |
183605c8 | 22 | #:use-module (srfi srfi-9) |
240b57f0 | 23 | #:use-module (srfi srfi-11) |
8bf92e39 LC |
24 | #:use-module (srfi srfi-34) |
25 | #:use-module (srfi srfi-35) | |
240b57f0 | 26 | #:use-module (ice-9 match) |
5e03b122 | 27 | #:export (%shepherd-socket-file |
6aeae5b9 | 28 | shepherd-message-port |
5e03b122 MO |
29 | |
30 | shepherd-error? | |
8bf92e39 LC |
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 | ||
5c793753 | 44 | live-service |
183605c8 LC |
45 | live-service? |
46 | live-service-provision | |
47 | live-service-requirement | |
48 | live-service-running | |
5c793753 | 49 | live-service-canonical-name |
183605c8 | 50 | |
147c5aa5 | 51 | with-shepherd-action |
8bf92e39 | 52 | current-services |
240b57f0 LC |
53 | unload-services |
54 | unload-service | |
55 | load-services | |
4245ddcb | 56 | load-services/safe |
0642838b | 57 | start-service |
8f5a0a97 MO |
58 | stop-service |
59 | restart-service)) | |
240b57f0 LC |
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 | |
5e03b122 | 71 | (make-parameter "/var/run/shepherd/socket")) |
240b57f0 | 72 | |
5e03b122 | 73 | (define* (open-connection #:optional (file (%shepherd-socket-file))) |
240b57f0 LC |
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) | |
bb64b2e7 | 83 | (setvbuf sock 'block 1024) |
240b57f0 | 84 | sock) |
1d6b7d58 LC |
85 | (lambda args |
86 | (close-port sock) | |
87 | (apply throw args)))))) | |
240b57f0 LC |
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))) | |
89a26478 LC |
92 | (dynamic-wind |
93 | (const #t) | |
94 | (lambda () | |
95 | body ...) | |
96 | (lambda () | |
97 | (close-port connection))))) | |
240b57f0 | 98 | |
8bf92e39 LC |
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." | |
240b57f0 LC |
126 | (match error |
127 | (('error ('version 0 x ...) 'service-not-found service) | |
8bf92e39 LC |
128 | (raise (condition (&service-not-found-error |
129 | (service service))))) | |
240b57f0 | 130 | (('error ('version 0 x ...) 'action-not-found action service) |
8bf92e39 LC |
131 | (raise (condition (&action-not-found-error |
132 | (service service) | |
133 | (action action))))) | |
240b57f0 LC |
134 | (('error ('version 0 x ...) 'action-exception action service |
135 | key (args ...)) | |
8bf92e39 LC |
136 | (raise (condition (&action-exception-error |
137 | (service service) | |
138 | (action action) | |
139 | (key key) (args args))))) | |
240b57f0 | 140 | (('error . _) |
8bf92e39 | 141 | (raise (condition (&unknown-shepherd-error (sexp error))))) |
240b57f0 LC |
142 | (#f ;not an error |
143 | #t))) | |
144 | ||
6aeae5b9 LC |
145 | (define shepherd-message-port |
146 | ;; Port where messages coming from shepherd are printed. | |
147 | (make-parameter (current-error-port))) | |
148 | ||
240b57f0 | 149 | (define (display-message message) |
6aeae5b9 | 150 | (format (shepherd-message-port) "shepherd: ~a~%" message)) |
240b57f0 LC |
151 | |
152 | (define* (invoke-action service action arguments cont) | |
153 | "Invoke ACTION on SERVICE with ARGUMENTS. On success, call CONT with the | |
7d14082d LC |
154 | list of results (one result per instance with the name SERVICE). Otherwise |
155 | return #f." | |
240b57f0 LC |
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) | |
dc7b3e56 | 166 | (('reply ('version 0 _ ...) ('result result) ('error #f) |
240b57f0 LC |
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) | |
8bf92e39 | 173 | (raise-shepherd-error error) |
240b57f0 LC |
174 | #f) |
175 | (x | |
8bf92e39 | 176 | ;; invalid reply |
240b57f0 LC |
177 | #f)))) |
178 | ||
179 | (define-syntax-rule (with-shepherd-action service (action args ...) | |
180 | result body ...) | |
147c5aa5 LC |
181 | "Invoke ACTION on SERVICE with the given ARGS, and evaluate BODY with RESULT |
182 | bound to the action's result." | |
240b57f0 LC |
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 | ||
183605c8 LC |
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 | ||
5c793753 JK |
203 | (define (live-service-canonical-name service) |
204 | "Return the 'canonical name' of SERVICE." | |
205 | (first (live-service-provision service))) | |
206 | ||
240b57f0 | 207 | (define (current-services) |
183605c8 LC |
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." | |
7d14082d LC |
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)))))) | |
240b57f0 LC |
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 | |
7d14082d | 228 | (first result))) |
240b57f0 LC |
229 | |
230 | (define (%load-file file) | |
231 | "Load FILE in the Shepherd." | |
232 | (with-shepherd-action 'root ('load file) result | |
7d14082d | 233 | (first result))) |
240b57f0 LC |
234 | |
235 | (define (eval-there exp) | |
236 | "Eval EXP in the Shepherd." | |
237 | (with-shepherd-action 'root ('eval (object->string exp)) result | |
7d14082d | 238 | (first result))) |
240b57f0 LC |
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 | ||
4245ddcb CZ |
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 | ||
ca0c43ec MO |
267 | (define* (start-service name #:optional (arguments '())) |
268 | (invoke-action name 'start arguments | |
269 | (lambda (result) | |
270 | result))) | |
240b57f0 | 271 | |
0642838b CB |
272 | (define (stop-service name) |
273 | (with-shepherd-action name ('stop) result | |
274 | result)) | |
275 | ||
8f5a0a97 MO |
276 | (define (restart-service name) |
277 | (with-shepherd-action name ('restart) result | |
278 | result)) | |
279 | ||
240b57f0 LC |
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 |