01/06: installer: Add predicate for the network task.

[John Darrington]

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

commit e4734b48a3243eb7b130c23890bebbaaedee2536
Author: John Darrington <address@hidden>
Date:   Mon Jan 2 11:43:03 2017 +0100

    installer: Add predicate for the network task.
    
    * gnu/system/installer/ping.scm (substitute-is-reachable?): New function.
    * gnu/system/installer/guixsd-installer.scm (main-options): Use it as a
    predicate for the network task.
---
 gnu/system/installer/guixsd-installer.scm |   60 ++++++++++++++---------------
 gnu/system/installer/ping.scm             |   18 ++++++++-
 2 files changed, 47 insertions(+), 31 deletions(-)

diff --git a/gnu/system/installer/guixsd-installer.scm 
b/gnu/system/installer/guixsd-installer.scm
index 4817ef9..6372721 100644
--- a/gnu/system/installer/guixsd-installer.scm
+++ b/gnu/system/installer/guixsd-installer.scm
@@ -33,11 +33,12 @@
             (gnu system installer network)
              (gnu system installer install)
             (gnu system installer page)
+             (gnu system installer ping)
             (gnu system installer dialog)
 
              (guix build utils)
              (guix utils)
-             
+
             (ice-9 format)
              (ice-9 match)
             (ice-9 pretty-print)
@@ -66,8 +67,7 @@
         0 (volumes)))
 
 (define main-options
-  `(
-    (disk . ,(make-task partition-menu-title
+  `((disk . ,(make-task partition-menu-title
                         '()
                         (lambda () (< minimum-store-size 
(size-of-largest-disk)))
                         (lambda (page)
@@ -76,32 +76,32 @@
                            partition-menu-title))))
 
     (filesystems . ,(make-task filesystem-menu-title
-                        '(disk)
-                        filesystem-task-complete?
-                        (lambda (page)
-                          (make-filesystem-page
-                           page
-                           filesystem-menu-title))))
+                               '(disk)
+                               filesystem-task-complete?
+                               (lambda (page)
+                                 (make-filesystem-page
+                                  page
+                                  filesystem-menu-title))))
 
     (network . ,(make-task network-menu-title
-                        '()
-                        (lambda () #f)
-                        (lambda (page)
-                          (make-network-page
-                           page
-                           network-menu-title))))
+                           '()
+                           substitute-is-reachable?
+                           (lambda (page)
+                             (make-network-page
+                              page
+                              network-menu-title))))
 
     (timezone . ,(make-task timezone-menu-title
-                        '()
-                        (lambda () (not (equal? "" time-zone)))
-                        (lambda (page)
-                          (make-tz-browser
-                           page
-                           (or
-                            (getenv "TZDIR")
-                            (string-append (car (slurp "guix build tzdata" #f))
-                                           "/share/zoneinfo"))
-                    page-stack))))
+                            '()
+                            (lambda () (not (equal? "" time-zone)))
+                            (lambda (page)
+                              (make-tz-browser
+                               page
+                               (or
+                                (getenv "TZDIR")
+                                (string-append (car (slurp "guix build tzdata" 
#f))
+                                               "/share/zoneinfo"))
+                               page-stack))))
 
     (hostname . ,(make-task hostname-menu-title
                             '()
@@ -122,7 +122,7 @@
                                (make-configure-page
                                 page
                                 generate-menu-title))))
-                             
+
     (install .  ,(make-task installation-menu-title
                             '(network generate)
                             (lambda () #f)
@@ -199,16 +199,16 @@
       (page-set-wwin! page frame)
       (page-set-datum! page 'menu main-menu)
       (menu-post main-menu win))
-    
+
     ;; Do the key action labels
     (let ((ypos (1- (getmaxy background)))
          (str0 (gettext "Get a Shell <F1>"))
          (str1 (gettext "Language <F9>"))
          (str2 (gettext "Keyboard <F10>")))
-      
+
       (addstr background str0 #:y ypos #:x 0)
       (addstr background str1 #:y ypos #:x
-             (truncate (/ (- (getmaxx background) 
+             (truncate (/ (- (getmaxx background)
                              (string-length str1)) 2)))
       (addstr background str2 #:y ypos #:x
              (- (getmaxx background) (string-length str2))))))
@@ -218,7 +218,7 @@
   (when (not (page-initialised? page))
     (main-page-init page)
     (page-set-initialised! page #t))
-  
+
   (touchwin (outer (page-wwin page)))
   (refresh (outer (page-wwin page)))
   (refresh (inner (page-wwin page)))
diff --git a/gnu/system/installer/ping.scm b/gnu/system/installer/ping.scm
index 7b8db35..5f117bc 100644
--- a/gnu/system/installer/ping.scm
+++ b/gnu/system/installer/ping.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016 John Darrington <address@hidden>
+;;; Copyright © 2016, 2017 John Darrington <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -25,10 +25,26 @@
   #:use-module (gurses buttons)
   #:use-module (ncurses curses)
   #:use-module (web uri)
+  #:use-module (srfi srfi-1)
+
+  #:export (substitute-is-reachable?)
   #:export (ping-page-refresh)
   #:export (ping-page-key-handler))
 
 
+(define (substitute-is-reachable?)
+  "Return #t if at least one substitute URL responds to pings"
+  (with-output-to-file "/dev/null"
+    (lambda ()
+      (with-error-to-file "/dev/null"
+        (lambda ()
+          (fold (lambda (x prev)
+                  (or prev
+                      (zero? (system*
+                              "ping" "-q" "-c" "1"
+                              (uri-host (string->uri x))))))
+                #f %default-substitute-urls))))))
+
 (define my-buttons `((test ,(N_ "_Test") #t)
                     (continue  ,(N_ "_Continue") #t)
                     (back     ,(N_ "Go _Back") #t)))