08/80: installer: Add IETF contraints for hostname in entry form.

[John Darrington]

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

commit 304ea345d01bdf43dc0d7f56c0a532f7b6b69724
Author: John Darrington <address@hidden>
Date:   Sun Dec 18 10:07:23 2016 +0100

    installer: Add IETF contraints for hostname in entry form.
    
    * gnu/system/installer/hostname.scm (host-name-key-handler): Add hostname
    constraints.
    * gurses/form.scm (get-current-field): New procedure.
---
 gnu/system/installer/hostname.scm |   34 +++++++++++++++++++++++-----------
 gurses/form.scm                   |    5 ++++-
 2 files changed, 27 insertions(+), 12 deletions(-)

diff --git a/gnu/system/installer/hostname.scm 
b/gnu/system/installer/hostname.scm
index bc10e6b..f3bfe78 100644
--- a/gnu/system/installer/hostname.scm
+++ b/gnu/system/installer/hostname.scm
@@ -59,15 +59,10 @@
       (set! host-name (form-get-value form 0))
       (set! page-stack (cdr page-stack))
       ((page-refresh (car page-stack)) (car page-stack)))
-     
-     ((or (eq? ch KEY_RIGHT)
-         (eq? ch #\tab))
-      (form-set-enabled! form #f)
-      (buttons-select-next nav))
 
-     ((eq? ch KEY_LEFT)
+     ((eq? ch #\tab)
       (form-set-enabled! form #f)
-      (buttons-select-prev nav))
+      (buttons-select-next nav))
 
      ((eq? ch KEY_UP)
       (buttons-unselect-all nav)
@@ -76,11 +71,28 @@
      ((eq? ch KEY_DOWN)
       (buttons-unselect-all nav)
       (form-set-enabled! form #t))
-     )
 
-    (curs-set 1)
-    (form-enter form ch))
-  #f)
+     ;; Do not allow more than 64 characters
+     ((and (char? ch)
+           (char-set-contains? char-set:printing ch)
+           (>= (field-cursor-position (get-current-field form)) 64)))
+
+     ;; The first character may not be  a hyphen
+     ((and (char? ch)
+           (eq? ch #\-)
+           (zero? (field-cursor-position (get-current-field form)))))
+
+     ;; Subsequent characters must be [-A-Za-z0-9]
+     ((and (char? ch)
+           (char-set-contains? char-set:printing ch)
+           (not (char-set-contains?
+                 (char-set-adjoin char-set:letter+digit #\-) ch))
+           (positive? (field-cursor-position (get-current-field form)))))
+
+     (else
+      (curs-set 1)
+      (form-enter form ch)))
+    #f))
 
 (define my-buttons `((continue ,(N_ "Continue") #f)))
 
diff --git a/gurses/form.scm b/gurses/form.scm
index 242f112..d26d76e 100644
--- a/gurses/form.scm
+++ b/gurses/form.scm
@@ -29,6 +29,7 @@
   #:export (form-enabled?)
   #:export (form-update-cursor)
   #:export (form-set-current-field)
+  #:export (get-current-field)
 
   #:use-module (ncurses curses)
   #:use-module (srfi srfi-9))
@@ -199,7 +200,6 @@ label eq? to N"
   (form-set-current-item! form which)
   (move (form-window form) which (form-tabpos form)))
 
-
 (define (form-next-field form)
   (if (< (form-current-item form) (1- (array-length (form-items form))))
       (begin
@@ -236,3 +236,6 @@ label eq? to N"
          (let ((f (array-ref fields pos)))
            (addchstr win (make-list (field-size f) (underline #\space)) #:y 
pos #:x xpos)
            (loop fields (1+ pos)))))))
+
+(define (get-current-field form)
+  (array-ref (form-items form) (form-current-item form)))