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