18/22: installer: New predicate valid-hostname?

[John Darrington]

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

commit 2a44b2d40ee210fd2c610f4a4db5e002748c0ce2
Author: John Darrington <address@hidden>
Date:   Mon Dec 26 12:08:58 2016 +0100

    installer: New predicate valid-hostname?
    
    * gnu/system/installer/hostname.scm (valid-hostname?): New procedure.
    * gnu/system/installer/new.scm (main-options): Use valid-hostname? as
    completed predicate.
---
 gnu/system/installer/hostname.scm |   21 +++++++++++++++++----
 gnu/system/installer/new.scm      |    2 +-
 2 files changed, 18 insertions(+), 5 deletions(-)

diff --git a/gnu/system/installer/hostname.scm 
b/gnu/system/installer/hostname.scm
index f71da81..aecc327 100644
--- a/gnu/system/installer/hostname.scm
+++ b/gnu/system/installer/hostname.scm
@@ -23,10 +23,22 @@
   #:use-module (gurses form)
   #:use-module (gurses buttons)
   #:use-module (ncurses curses)
+  #:use-module (ice-9 regex)
 
+  #:export (valid-hostname?)
   #:export (make-host-name-page))
 
-(define my-fields `((name   ,(N_ "Host Name") 64)))
+(define max-length ((const 63)))
+
+(define my-fields `((name   ,(N_ "Host Name") ,max-length)))
+
+(define (valid-hostname? name)
+  "Return #t iff NAME is a valid hostname as defined by RFC 1034"
+  (and
+   (positive? (string-length name))
+   (string-match "^[0-9A-Za-z-]*$" name)
+   (not (eq? (string-ref name 0) #\-))  ;; First char may not be '-'
+   (<= (string-length name) max-length)))
 
 (define (make-host-name-page parent  title)
   (make-page (page-surface parent)
@@ -44,7 +56,8 @@
     (clear text-window)
     (addstr*
      text-window
-     (gettext "Enter the host name for the new system.  Only letters, digits 
and hyphens are allowed. The first character may not be a hyphen.  A maximum of 
64 characters are allowed."))
+     (gettext
+      (format #f "Enter the host name for the new system.  Only letters, 
digits and hyphens are allowed. The first character may not be a hyphen.  A 
maximum of ~a characters are allowed." max-length)))
     (refresh text-window)
     (refresh (outer (page-wwin page)))
     (refresh (form-window form))))
@@ -72,10 +85,10 @@
       (buttons-unselect-all nav)
       (form-set-enabled! form #t))
 
-     ;; Do not allow more than 64 characters
+     ;; Do not allow more than 63 characters
      ((and (char? ch)
            (char-set-contains? char-set:printing ch)
-           (>= (field-cursor-position (get-current-field form)) 64)))
+           (>= (field-cursor-position (get-current-field form)) max-length)))
 
      ;; The first character may not be  a hyphen
      ((and (char? ch)
diff --git a/gnu/system/installer/new.scm b/gnu/system/installer/new.scm
index 97cb850..1a2cf74 100644
--- a/gnu/system/installer/new.scm
+++ b/gnu/system/installer/new.scm
@@ -105,7 +105,7 @@
 
     (hostname . ,(make-task hostname-menu-title
                             '()
-                            (lambda () (not (equal? "" host-name)))
+                            (lambda () (valid-hostname? host-name))
                             (lambda (page)
                               (make-host-name-page
                                page