Commit | Line | Data |
---|---|---|
d0f3a672 MO |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com> | |
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 installer connman) | |
20 | #:use-module (gnu installer utils) | |
21 | #:use-module (guix records) | |
22 | #:use-module (ice-9 match) | |
23 | #:use-module (ice-9 popen) | |
24 | #:use-module (ice-9 regex) | |
25 | #:use-module (srfi srfi-11) | |
26 | #:use-module (srfi srfi-34) | |
27 | #:use-module (srfi srfi-35) | |
28 | #:export (<technology> | |
29 | technology | |
30 | technology? | |
31 | technology-name | |
32 | technology-type | |
33 | technology-powered? | |
34 | technology-connected? | |
35 | ||
36 | <service> | |
37 | service | |
38 | service? | |
39 | service-name | |
40 | service-type | |
41 | service-path | |
42 | service-strength | |
43 | service-state | |
44 | ||
45 | &connman-error | |
46 | connman-error? | |
47 | connman-error-command | |
48 | connman-error-output | |
49 | connman-error-status | |
50 | ||
51 | &connman-connection-error | |
52 | connman-connection-error? | |
53 | connman-connection-error-service | |
54 | connman-connection-error-output | |
55 | ||
56 | &connman-password-error | |
57 | connman-password-error? | |
58 | ||
59 | &connman-already-connected-error | |
60 | connman-already-connected-error? | |
61 | ||
62 | connman-state | |
63 | connman-technologies | |
64 | connman-enable-technology | |
65 | connman-disable-technology | |
66 | connman-scan-technology | |
67 | connman-services | |
68 | connman-connect | |
69 | connman-disconnect | |
70 | connman-online? | |
71 | connman-connect-with-auth)) | |
72 | ||
73 | ;;; Commentary: | |
74 | ;;; | |
75 | ;;; This module provides procedures for talking with the connman daemon. | |
76 | ;;; The best approach would have been using connman dbus interface. | |
77 | ;;; However, as Guile dbus bindings are not available yet, the console client | |
78 | ;;; "connmanctl" is used to talk with the daemon. | |
79 | ;;; | |
80 | ||
81 | \f | |
82 | ;;; | |
83 | ;;; Technology record. | |
84 | ;;; | |
85 | ||
86 | ;; The <technology> record encapsulates the "Technology" object of connman. | |
87 | ;; Technology type will be typically "ethernet", "wifi" or "bluetooth". | |
88 | ||
89 | (define-record-type* <technology> | |
90 | technology make-technology | |
91 | technology? | |
92 | (name technology-name) ; string | |
93 | (type technology-type) ; string | |
94 | (powered? technology-powered?) ; boolean | |
95 | (connected? technology-connected?)) ; boolean | |
96 | ||
97 | \f | |
98 | ;;; | |
99 | ;;; Service record. | |
100 | ;;; | |
101 | ||
102 | ;; The <service> record encapsulates the "Service" object of connman. | |
103 | ;; Service type is the same as the technology it is associated to, path is a | |
104 | ;; unique identifier given by connman, strength describes the signal quality | |
105 | ;; if applicable. Finally, state is "idle", "failure", "association", | |
106 | ;; "configuration", "ready", "disconnect" or "online". | |
107 | ||
108 | (define-record-type* <service> | |
109 | service make-service | |
110 | service? | |
694cb8dc | 111 | (name service-name) ; string or #f |
d0f3a672 MO |
112 | (type service-type) ; string |
113 | (path service-path) ; string | |
114 | (strength service-strength) ; integer | |
115 | (state service-state)) ; string | |
116 | ||
117 | \f | |
118 | ;;; | |
119 | ;;; Condition types. | |
120 | ;;; | |
121 | ||
122 | (define-condition-type &connman-error &error | |
123 | connman-error? | |
124 | (command connman-error-command) | |
125 | (output connman-error-output) | |
126 | (status connman-error-status)) | |
127 | ||
128 | (define-condition-type &connman-connection-error &error | |
129 | connman-connection-error? | |
130 | (service connman-connection-error-service) | |
131 | (output connman-connection-error-output)) | |
132 | ||
133 | (define-condition-type &connman-password-error &connman-connection-error | |
134 | connman-password-error?) | |
135 | ||
136 | (define-condition-type &connman-already-connected-error | |
137 | &connman-connection-error connman-already-connected-error?) | |
138 | ||
139 | \f | |
140 | ;;; | |
141 | ;;; Procedures. | |
142 | ;;; | |
143 | ||
144 | (define (connman-run command env arguments) | |
145 | "Run the given COMMAND, with the specified ENV and ARGUMENTS. The error | |
146 | output is discarded and &connman-error condition is raised if the command | |
147 | returns a non zero exit code." | |
148 | (let* ((command `("env" ,env ,command ,@arguments "2>" "/dev/null")) | |
149 | (command-string (string-join command " ")) | |
150 | (pipe (open-input-pipe command-string)) | |
151 | (output (read-lines pipe)) | |
152 | (ret (close-pipe pipe))) | |
153 | (case (status:exit-val ret) | |
154 | ((0) output) | |
155 | (else (raise (condition (&connman-error | |
156 | (command command) | |
157 | (output output) | |
158 | (status ret)))))))) | |
159 | ||
160 | (define (connman . arguments) | |
161 | "Run connmanctl with the specified ARGUMENTS. Set the LANG environment | |
162 | variable to C because the command output will be parsed and we don't want it | |
163 | to be translated." | |
164 | (connman-run "connmanctl" "LANG=C" arguments)) | |
165 | ||
166 | (define (parse-keys keys) | |
167 | "Parse the given list of strings KEYS, under the following format: | |
168 | ||
169 | '((\"KEY = VALUE\") (\"KEY2 = VALUE2\") ...) | |
170 | ||
171 | Return the corresponding association list of '((KEY . VALUE) (KEY2 . VALUE2) | |
172 | ...) elements." | |
173 | (let ((key-regex (make-regexp "([^ ]+) = ([^$]+)"))) | |
174 | (map (lambda (key) | |
175 | (let ((match-key (regexp-exec key-regex key))) | |
176 | (cons (match:substring match-key 1) | |
177 | (match:substring match-key 2)))) | |
178 | keys))) | |
179 | ||
180 | (define (connman-state) | |
181 | "Return the state of connman. The nominal states are 'offline, 'idle, | |
182 | 'ready, 'oneline. If an unexpected state is read, 'unknown is | |
183 | returned. Finally, an error is raised if the comman output could not be | |
184 | parsed, usually because the connman daemon is not responding." | |
185 | (let* ((output (connman "state")) | |
186 | (state-keys (parse-keys output))) | |
187 | (let ((state (assoc-ref state-keys "State"))) | |
188 | (if state | |
189 | (cond ((string=? state "offline") 'offline) | |
190 | ((string=? state "idle") 'idle) | |
191 | ((string=? state "ready") 'ready) | |
192 | ((string=? state "online") 'online) | |
193 | (else 'unknown)) | |
194 | (raise (condition | |
195 | (&message | |
196 | (message "Could not determine the state of connman.")))))))) | |
197 | ||
198 | (define (split-technology-list technologies) | |
199 | "Parse the given strings list TECHNOLOGIES, under the following format: | |
200 | ||
201 | '((\"/net/connman/technology/xxx\") | |
202 | (\"KEY = VALUE\") | |
203 | ... | |
204 | (\"/net/connman/technology/yyy\") | |
205 | (\"KEY2 = VALUE2\") | |
206 | ...) | |
207 | Return the corresponding '(((\"KEY = VALUE\") ...) ((\"KEY2 = VALUE2\") ...)) | |
208 | list so that each keys of a given technology are gathered in a separate list." | |
209 | (let loop ((result '()) | |
210 | (cur-list '()) | |
211 | (input (reverse technologies))) | |
212 | (if (null? input) | |
213 | result | |
214 | (let ((item (car input))) | |
215 | (if (string-match "/net/connman/technology" item) | |
216 | (loop (cons cur-list result) '() (cdr input)) | |
217 | (loop result (cons item cur-list) (cdr input))))))) | |
218 | ||
219 | (define (string->boolean string) | |
220 | (equal? string "True")) | |
221 | ||
222 | (define (connman-technologies) | |
223 | "Return a list of available <technology> records." | |
224 | ||
225 | (define (technology-output->technology output) | |
226 | (let ((keys (parse-keys output))) | |
227 | (technology | |
228 | (name (assoc-ref keys "Name")) | |
229 | (type (assoc-ref keys "Type")) | |
230 | (powered? (string->boolean (assoc-ref keys "Powered"))) | |
231 | (connected? (string->boolean (assoc-ref keys "Connected")))))) | |
232 | ||
233 | (let* ((output (connman "technologies")) | |
234 | (technologies (split-technology-list output))) | |
235 | (map technology-output->technology technologies))) | |
236 | ||
237 | (define (connman-enable-technology technology) | |
238 | "Enable the given TECHNOLOGY." | |
239 | (let ((type (technology-type technology))) | |
240 | (connman "enable" type))) | |
241 | ||
242 | (define (connman-disable-technology technology) | |
243 | "Disable the given TECHNOLOGY." | |
244 | (let ((type (technology-type technology))) | |
245 | (connman "disable" type))) | |
246 | ||
247 | (define (connman-scan-technology technology) | |
248 | "Run a scan for the given TECHNOLOGY." | |
249 | (let ((type (technology-type technology))) | |
250 | (connman "scan" type))) | |
251 | ||
252 | (define (connman-services) | |
253 | "Return a list of available <services> records." | |
254 | ||
255 | (define (service-output->service path output) | |
256 | (let* ((service-keys | |
257 | (match output | |
258 | ((_ . rest) rest))) | |
259 | (keys (parse-keys service-keys))) | |
260 | (service | |
261 | (name (assoc-ref keys "Name")) | |
262 | (type (assoc-ref keys "Type")) | |
263 | (path path) | |
264 | (strength (and=> (assoc-ref keys "Strength") string->number)) | |
265 | (state (assoc-ref keys "State"))))) | |
266 | ||
267 | (let* ((out (connman "services")) | |
268 | (out-filtered (delete "" out)) | |
269 | (services-path (map (lambda (service) | |
270 | (match (string-split service #\ ) | |
271 | ((_ ... path) path))) | |
272 | out-filtered)) | |
273 | (services-output (map (lambda (service) | |
274 | (connman "services" service)) | |
275 | services-path))) | |
276 | (map service-output->service services-path services-output))) | |
277 | ||
278 | (define (connman-connect service) | |
279 | "Connect to the given SERVICE." | |
280 | (let ((path (service-path service))) | |
281 | (connman "connect" path))) | |
282 | ||
283 | (define (connman-disconnect service) | |
284 | "Disconnect from the given SERVICE." | |
285 | (let ((path (service-path service))) | |
286 | (connman "disconnect" path))) | |
287 | ||
288 | (define (connman-online?) | |
289 | (let ((state (connman-state))) | |
290 | (eq? state 'online))) | |
291 | ||
292 | (define (connman-connect-with-auth service password-proc) | |
293 | "Connect to the given SERVICE with the password returned by calling | |
294 | PASSWORD-PROC. This is only possible in the interactive mode of connmanctl | |
295 | because authentication is done by communicating with an agent. | |
296 | ||
297 | As the open-pipe procedure of Guile do not allow to read from stderr, we have | |
298 | to merge stdout and stderr using bash redirection. Then error messages are | |
299 | extracted from connmanctl output using a regexp. This makes the whole | |
300 | procedure even more unreliable. | |
301 | ||
b83e4a93 | 302 | Raise &connman-connection-error if an error occurred during connection. Raise |
d0f3a672 MO |
303 | &connman-password-error if the given password is incorrect." |
304 | ||
305 | (define connman-error-regexp (make-regexp "Error[ ]*([^\n]+)\n")) | |
306 | ||
307 | (define (match-connman-error str) | |
308 | (let ((match-error (regexp-exec connman-error-regexp str))) | |
309 | (and match-error (match:substring match-error 1)))) | |
310 | ||
311 | (define* (read-regexps-or-error port regexps error-handler) | |
312 | "Read characters from port until an error is detected, or one of the given | |
313 | REGEXPS is matched. If an error is detected, call ERROR-HANDLER with the error | |
314 | string as argument. Raise an error if the eof is reached before one of the | |
315 | regexps is matched." | |
316 | (let loop ((res "")) | |
317 | (let ((char (read-char port))) | |
318 | (cond | |
319 | ((eof-object? char) | |
320 | (raise (condition | |
321 | (&message | |
322 | (message "Unable to find expected regexp."))))) | |
323 | ((match-connman-error res) | |
324 | => | |
325 | (lambda (match) | |
326 | (error-handler match))) | |
327 | ((or-map (lambda (regexp) | |
328 | (and (regexp-exec regexp res) regexp)) | |
329 | regexps) | |
330 | => | |
331 | (lambda (match) | |
332 | match)) | |
333 | (else | |
334 | (loop (string-append res (string char)))))))) | |
335 | ||
336 | (define* (read-regexp-or-error port regexp error-handler) | |
337 | "Same as READ-REGEXPS-OR-ERROR above, but with a single REGEXP." | |
338 | (read-regexps-or-error port (list regexp) error-handler)) | |
339 | ||
340 | (define (connman-error->condition path error) | |
341 | (cond | |
342 | ((string-match "Already connected" error) | |
343 | (condition (&connman-already-connected-error | |
344 | (service path) | |
345 | (output error)))) | |
346 | (else | |
347 | (condition (&connman-connection-error | |
348 | (service path) | |
349 | (output error)))))) | |
350 | ||
351 | (define (run-connection-sequence pipe) | |
352 | "Run the connection sequence using PIPE as an opened port to an | |
353 | interactive connmanctl process." | |
354 | (let* ((path (service-path service)) | |
355 | (error-handler (lambda (error) | |
356 | (raise | |
357 | (connman-error->condition path error))))) | |
358 | ;; Start the agent. | |
359 | (format pipe "agent on\n") | |
360 | (read-regexp-or-error pipe (make-regexp "Agent registered") error-handler) | |
361 | ||
362 | ;; Let's try to connect to the service. If the service does not require | |
363 | ;; a password, the connection might succeed right after this call. | |
364 | ;; Otherwise, connmanctl will prompt us for a password. | |
365 | (format pipe "connect ~a\n" path) | |
366 | (let* ((connected-regexp (make-regexp (format #f "Connected ~a" path))) | |
367 | (passphrase-regexp (make-regexp "\nPassphrase\\?[ ]*")) | |
368 | (regexps (list connected-regexp passphrase-regexp)) | |
369 | (result (read-regexps-or-error pipe regexps error-handler))) | |
370 | ||
371 | ;; A password is required. | |
372 | (when (eq? result passphrase-regexp) | |
373 | (format pipe "~a~%" (password-proc)) | |
374 | ||
375 | ;; Now, we have to wait for the connection to succeed. If an error | |
376 | ;; occurs, it is most likely because the password is incorrect. | |
377 | ;; In that case, we escape from an eventual retry loop that would | |
378 | ;; add complexity to this procedure, and raise a | |
379 | ;; &connman-password-error condition. | |
380 | (read-regexp-or-error pipe connected-regexp | |
381 | (lambda (error) | |
382 | ;; Escape from retry loop. | |
383 | (format pipe "no\n") | |
384 | (raise | |
385 | (condition (&connman-password-error | |
386 | (service path) | |
387 | (output error)))))))))) | |
388 | ||
389 | ;; XXX: Find a better way to read stderr, like with the "subprocess" | |
390 | ;; procedure of racket that return input ports piped on the process stdin and | |
391 | ;; stderr. | |
392 | (let ((pipe (open-pipe "connmanctl 2>&1" OPEN_BOTH))) | |
393 | (dynamic-wind | |
394 | (const #t) | |
395 | (lambda () | |
ea6594e0 | 396 | (setvbuf pipe 'line) |
d0f3a672 MO |
397 | (run-connection-sequence pipe) |
398 | #t) | |
399 | (lambda () | |
400 | (format pipe "quit\n") | |
401 | (close-pipe pipe))))) |