projects/guix·blob python-team · refs

401 lines · 14.2 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2018 Mathieu Othacehe <[email protected]>
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;;; Commentary:
20;;;
21;;; This module provides procedures for talking with the connman daemon.
22;;; The best approach would have been using connman dbus interface.
23;;; However, as Guile dbus bindings are not available yet, the console client
24;;; "connmanctl" is used to talk with the daemon.
25;;;
26
27(define-module (gnu installer connman)
28 #:use-module (gnu installer utils)
29 #:use-module (guix records)
30 #:use-module (ice-9 match)
31 #:use-module (ice-9 popen)
32 #:use-module (ice-9 regex)
33 #:use-module (srfi srfi-11)
34 #:use-module (srfi srfi-34)
35 #:use-module (srfi srfi-35)
36 #:export (<technology>
37 technology
38 technology?
39 technology-name
40 technology-type
41 technology-powered?
42 technology-connected?
43
44 <service>
45 service
46 service?
47 service-name
48 service-type
49 service-path
50 service-strength
51 service-state
52
53 &connman-error
54 connman-error?
55 connman-error-command
56 connman-error-output
57 connman-error-status
58
59 &connman-connection-error
60 connman-connection-error?
61 connman-connection-error-service
62 connman-connection-error-output
63
64 &connman-password-error
65 connman-password-error?
66
67 &connman-already-connected-error
68 connman-already-connected-error?
69
70 connman-state
71 connman-technologies
72 connman-enable-technology
73 connman-disable-technology
74 connman-scan-technology
75 connman-services
76 connman-connect
77 connman-disconnect
78 connman-online?
79 connman-connect-with-auth))
80
81
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
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?
111 (name service-name) ; string or #f
112 (type service-type) ; string
113 (path service-path) ; string
114 (strength service-strength) ; integer
115 (state service-state)) ; string
116
117
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
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
146output is discarded and &connman-error condition is raised if the command
147returns 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
162variable to C because the command output will be parsed and we don't want it
163to 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
171Return 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
183returned. Finally, an error is raised if the connman output could not be
184parsed, 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\") ...))
208list 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 (memq state '(ready online))))
291
292(define (connman-connect-with-auth service password-proc)
293 "Connect to the given SERVICE with the password returned by calling
294PASSWORD-PROC. This is only possible in the interactive mode of connmanctl
295because authentication is done by communicating with an agent.
296
297As the open-pipe procedure of Guile do not allow to read from stderr, we have
298to merge stdout and stderr using bash redirection. Then error messages are
299extracted from connmanctl output using a regexp. This makes the whole
300procedure even more unreliable.
301
302Raise &connman-connection-error if an error occurred during connection. Raise
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
313REGEXPS is matched. If an error is detected, call ERROR-HANDLER with the error
314string as argument. Raise an error if the eof is reached before one of the
315regexps 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
353interactive 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 ()
396 (setvbuf pipe 'line)
397 (run-connection-sequence pipe)
398 #t)
399 (lambda ()
400 (format pipe "quit\n")
401 (close-pipe pipe)))))