You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

401 lines
14 KiB

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