projects/guix·blob master · refs

361 lines · 13.4 KiB

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