gnu/installer/connman.scm

   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?
 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 \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
 302 Raise &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
 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 ()
 396         (setvbuf pipe 'line)
 397         (run-connection-sequence pipe)
 398         #t)
 399       (lambda ()
 400         (format pipe "quit\n")
 401         (close-pipe pipe)))))