26/80: installer: Add a new menu to configure wireless interfaces.

[John Darrington]

jmd pushed a commit to branch wip-installer
in repository guix.

commit 472803b6b12503782797e0081251591fd7e013ee
Author: John Darrington <address@hidden>
Date:   Sat Dec 24 11:49:22 2016 +0100

    installer: Add a new menu to configure wireless interfaces.
    
    * gnu/system/installer/wireless.scm: New file.
    * gnu/local.mk (GNU_SYSTEM_MODULES): Add it.
    * gnu/system/installer/network.scm: Call wireless menu on activate.
---
 gnu/local.mk                      |   27 ++---
 gnu/system/installer/network.scm  |   46 +++++---
 gnu/system/installer/wireless.scm |  228 +++++++++++++++++++++++++++++++++++++
 3 files changed, 271 insertions(+), 30 deletions(-)

diff --git a/gnu/local.mk b/gnu/local.mk
index 4b0f348..6e39d83 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -437,20 +437,21 @@ GNU_SYSTEM_MODULES =                              \
   %D%/system/shadow.scm                                \
   %D%/system/vm.scm                            \
                                                \
-  %D%/system/installer/filesystems.scm         \
-  %D%/system/installer/network.scm             \
-  %D%/system/installer/dialog.scm             \
+  %D%/system/installer/filesystems.scm          \
+  %D%/system/installer/network.scm              \
+  %D%/system/installer/wireless.scm             \
+  %D%/system/installer/dialog.scm               \
   %D%/system/installer/hostname.scm             \
-  %D%/system/installer/mount-point.scm             \
-  %D%/system/installer/new.scm             \
-  %D%/system/installer/disks.scm             \
-  %D%/system/installer/ping.scm             \
-  %D%/system/installer/file-browser.scm             \
-  %D%/system/installer/utils.scm             \
-  %D%/system/installer/page.scm             \
-  %D%/system/installer/time-zone.scm             \
-  %D%/system/installer/misc.scm             \
-  %D%/system/installer/partition-reader.scm             \
+  %D%/system/installer/mount-point.scm          \
+  %D%/system/installer/new.scm                  \
+  %D%/system/installer/disks.scm                \
+  %D%/system/installer/ping.scm                 \
+  %D%/system/installer/file-browser.scm         \
+  %D%/system/installer/utils.scm                \
+  %D%/system/installer/page.scm                 \
+  %D%/system/installer/time-zone.scm            \
+  %D%/system/installer/misc.scm                 \
+  %D%/system/installer/partition-reader.scm     \
                \
   %D%/build/activation.scm                     \
   %D%/build/cross-toolchain.scm                        \
diff --git a/gnu/system/installer/network.scm b/gnu/system/installer/network.scm
index 61af33b..db49b0f 100644
--- a/gnu/system/installer/network.scm
+++ b/gnu/system/installer/network.scm
@@ -21,6 +21,7 @@
   #:use-module (gnu system installer ping)
   #:use-module (gnu system installer misc)
   #:use-module (gnu system installer utils)
+  #:use-module (gnu system installer wireless)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
   #:use-module (gurses menu)
@@ -37,19 +38,23 @@
             network-page-key-handler))
 
 
-(define (interfaces) 
-                           (slurp "ip -o link"
-                                  (lambda (s)
-                                    (match (string-split s #\space)
-                                      ((_ interface-name _ _ _ _ _ _
-                                          state _ _ _ _ _ _ _ _ _ class . _)
-                                       `((name . 
-                                              ,(string-trim-right
-                                                interface-name #\:))
-                                         (state . ,state)
-                                         (class . ,class)))))))
-
-
+(define (interfaces)
+  "Return a alist of network interfaces. Keys include 'name, 'class and 'state"
+  (slurp "ip -o link"
+         (lambda (s)
+           (match (string-split s #\space)
+             ((_ interface-name _ _ _ _ _ _
+                 state _ _ _ _ _ _ _ _ _ class . _)
+              (let ((clean-name (string-trim-right interface-name #\:)))
+              `((name .  ,clean-name)
+                (state . ,state)
+                (class . ,(cond
+                           ((equal? class "link/loopback") 'loopback)
+                           ((equal? class "link/ether")
+                            (if (zero? (system* "iw" "dev" clean-name "info"))
+                                 'wireless
+                                 'ethernet))
+                           (else 'other))))))))))
 
 (define my-buttons `((continue ,(N_ "_Continue") #t)
                     (test     ,(N_ "_Test") #t)))
@@ -84,7 +89,14 @@
       (buttons-unselect-all nav)
       (menu-set-active! menu #t))
 
- 
+     ((and (select-key? ch)
+           (eq? 'wireless (assq-ref (menu-get-current-item menu) 'class)))
+
+      (let ((next (make-essid-page page (N_ "Wireless interface setup")
+                                   (assq-ref (menu-get-current-item menu) 
'name))))
+        (set! page-stack (cons next page-stack))
+        ((page-refresh next) next)))
+    
 
      ((buttons-key-matches-symbol? nav ch 'continue)
        (delwin (outer (page-wwin page)))
@@ -139,7 +151,9 @@
                       (getmaxy text-window) 0 #:panel #f))
         
         (menu (make-menu
-               (filter (lambda (i) (equal? "link/ether" (assq-ref i 'class)))
+               (filter (lambda (i) (memq
+                                     (assq-ref i 'class)
+                                     '(ethernet wireless)))
                         (interfaces))
                #:disp-proc
                (lambda (datum row)
@@ -180,5 +194,3 @@
     (refresh (outer pr))
     (refresh text-window)
     (refresh bwin)))
-                             
-
diff --git a/gnu/system/installer/wireless.scm 
b/gnu/system/installer/wireless.scm
new file mode 100644
index 0000000..26b08d8
--- /dev/null
+++ b/gnu/system/installer/wireless.scm
@@ -0,0 +1,228 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 John Darrington <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu system installer wireless)
+  #:use-module (gnu system installer page)
+  #:use-module (gnu system installer ping)
+  #:use-module (gnu system installer misc)
+  #:use-module (gnu system installer utils)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (gurses menu)
+  #:use-module (gurses buttons)
+  #:use-module (ncurses curses)
+  #:use-module (guix store)
+  #:use-module (guix utils)
+
+  #:export (make-essid-page))
+
+
+(define (make-essid-page parent title interface)
+  (let ((page (make-page (page-surface parent)
+                         title
+                         essid-page-refresh
+                         essid-page-key-handler)))
+
+    (page-set-datum! page 'ifce interface)
+    page))
+
+
+(define my-buttons `((continue ,(N_ "_Continue") #t)))
+
+(define (essid-page-key-handler page ch)
+
+  (let ((nav  (page-datum page 'navigation))
+        (menu  (page-datum page 'menu))
+       (test-window  (page-datum page 'test-window)))
+
+    (cond
+     ((eq? ch KEY_RIGHT)
+      (buttons-select-next nav))
+
+     ((eq? ch #\tab)
+      (cond
+       ((eqv? (buttons-selected nav) (1- (buttons-n-buttons nav)))
+       (buttons-unselect-all nav))
+
+       (else
+       (buttons-select-next nav))))
+
+     ((eq? ch KEY_LEFT)
+      (buttons-select-prev nav))
+
+     ((eq? ch KEY_UP)
+      (buttons-unselect-all nav))
+
+
+     ((buttons-key-matches-symbol? nav ch 'continue)
+
+      (with-output-to-file "/tmp/wpa_supplicant.conf"
+        (lambda ()
+         (format #t "
+network={
+\tssid=\"~a\"
+\tkey_mgmt=WPA-PSK
+\tpsk=\"~a\"
+}
+"
+                 (assq-ref (menu-get-current-item menu) 'essid)
+                 "Passphrase")))
+
+      (and (zero? (system* "wpa_supplicant" "-c" "/tmp/wpa_supplicant.conf" 
"-i"
+               (page-datum page 'ifce)
+               "-B"))
+           (zero? (system* "dhclient" (page-datum page 'ifce))))
+
+      (delwin (outer (page-wwin page)))
+      (delwin (inner (page-wwin page)))
+
+      (set! page-stack (cdr page-stack))))
+
+
+    (std-menu-key-handler menu ch)
+
+    #f))
+
+(define (essid-page-refresh page)
+  (when (not (page-initialised? page))
+    (essid-page-init page)
+    (page-set-initialised! page #t))
+  (touchwin (outer (page-wwin page)))
+  (refresh (outer (page-wwin page)))
+  (refresh (inner (page-wwin page)))
+  (menu-refresh (page-datum page 'menu)))
+
+
+(define (essid-page-init p)
+  (let* ((s (page-surface p))
+        (pr (make-boxed-window  #f
+             (- (getmaxy s) 3) (- (getmaxx s) 2)
+             2 1
+             #:title (page-title p)))
+        (text-window (derwin
+                      (car pr)
+                      5 (getmaxx (inner pr))
+                      0 0
+                      #:panel #f))
+                       
+        (bwin (derwin (inner pr)
+                      3 (getmaxx (inner pr))
+                      (- (getmaxy (inner pr)) 3) 0
+                         #:panel #f))
+        (buttons (make-buttons my-buttons 1))
+
+        (mwin (derwin (inner pr)
+                      (- (getmaxy (inner pr)) (getmaxy text-window) 3)
+                      (- (getmaxx (inner pr)) 0)
+                      (getmaxy text-window) 0 #:panel #f))
+
+        (menu (make-menu
+                ;; Present a menu of available Access points in decreasing
+                ;; order of signal strength
+                (sort
+                 (get-wifi
+                  (page-datum p 'ifce))
+                 (lambda (i j)
+                   (<
+                    (assq-ref j 'signal)
+                    (assq-ref i 'signal))))
+                #:disp-proc
+                (lambda (d _) (assq-ref d 'essid)))
+               ))
+
+    (addstr*   text-window  (format #f
+             (gettext
+              "Select an access point to connect.")))
+
+    (page-set-wwin! p pr)
+    (page-set-datum! p 'menu menu)
+    (page-set-datum! p 'navigation buttons)
+    (menu-post menu mwin)
+    (buttons-post buttons bwin)
+    (refresh (outer pr))
+    (refresh text-window)
+    (refresh bwin)))
+                       
+
+
+(use-modules (ice-9 pretty-print))
+(use-modules (ice-9 regex))
+(use-modules (srfi srfi-1))
+
+(define (drop-quotes s)
+  "Drop any double quote characters from S"
+  (string-fold
+   (lambda (c prev)
+     (string-append
+      prev
+      (if (eq? c #\") "" (make-string 1 c))))
+   "" s))
+
+(define (scan-wifi ifce)
+  (cdr (slurp (string-append "iwlist " ifce " scan") string-trim-both)))
+
+(define (drop-prefix pfx s)
+  "Drop PFX from S if it is the first string"
+  (if (string-prefix? pfx s)
+      (string-drop s (string-length pfx))
+      s))
+
+(define (get-wifi ifce)
+  (begin (system* "ip" "link" "set" ifce "up")
+         (fold
+          (lambda (x prev)
+            (let ((mtch (string-match "Cell [0-9][0-9] - " x)))
+              (cond (mtch
+                     (cons
+                      (list
+                       `(address . ,
+                                 (drop-prefix "Address: "
+                                              (string-drop x (string-length 
(match:substring mtch))))))
+                      prev))
+
+                    ((string-prefix? "Encryption key:" x)
+                     (cons
+                      (append (car prev)
+                              (list `(encryption .
+                                                 ,(string-suffix? "on" x))))
+                      (cdr prev)))
+
+                    ((string-prefix? "Quality=" x)
+                     (let ((lvl (string-match "level=(-?[0-9][0-9]*) dBm" x)))
+                       (if lvl
+                           (cons
+                            (append (car prev)
+                                    (list
+                                     `(signal . ,(string->number 
(match:substring lvl 1))))
+                                    )
+                            (cdr prev))
+                           prev)))
+
+                    ((string-prefix? "ESSID:" x)
+                     (cons
+                      (append (car prev)
+                              (list
+                               `(essid . ,(drop-prefix "ESSID:"
+                                                       (drop-quotes
+                                                        x))))
+                              )
+                      (cdr prev)))
+
+                    (else
+                     prev))))
+          '() (scan-wifi ifce))))