169/197: installer: Add users page.

[Danny Milosavljevic]

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

commit 88fa2b4bc5c72fef0adc57982ccf46bb0e663e8f
Author: John Darrington <address@hidden>
Date:   Mon Feb 6 17:04:03 2017 +0100

    installer: Add users page.
    
    * gnu/system/installer/users.scm: New file.
    * gnu/local.mk: Add it.
    * gnu/system/installer/configure.scm (generate-config): Enable
    generation of user accounts.
    * gnu/system/installer/guixsd-installer.scm (main-options): New member.
    * gnu/system/installer/misc.scm (users): New variable.
---
 gnu/local.mk                              |   1 +
 gnu/system/installer/configure.scm        |  13 ++-
 gnu/system/installer/guixsd-installer.scm |  10 ++
 gnu/system/installer/misc.scm             |  20 ++++
 gnu/system/installer/users.scm            | 153 ++++++++++++++++++++++++++++++
 5 files changed, 196 insertions(+), 1 deletion(-)

diff --git a/gnu/local.mk b/gnu/local.mk
index 0cf29d7..3e8bdb7 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -476,6 +476,7 @@ GNU_SYSTEM_MODULES =                                \
   %D%/system/installer/ping.scm                 \
   %D%/system/installer/key-map.scm              \
   %D%/system/installer/role.scm                 \
+  %D%/system/installer/users.scm                \
   %D%/system/installer/utils.scm                \
   %D%/system/installer/page.scm                 \
   %D%/system/installer/passphrase.scm           \
diff --git a/gnu/system/installer/configure.scm 
b/gnu/system/installer/configure.scm
index 5f68412..a68ac5d 100644
--- a/gnu/system/installer/configure.scm
+++ b/gnu/system/installer/configure.scm
@@ -26,6 +26,7 @@
   #:use-module (gnu system installer partition-reader)
   #:use-module (gnu system installer filesystems)
   #:use-module (gnu system installer disks)
+  #:use-module (gnu system shadow)
   #:use-module (ice-9 format)
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 match)
@@ -190,7 +191,17 @@
                          (let ((fss (cdr x)))
                            (eq? 'swap (file-system-spec-type fss))))
                        mount-points)))
-        (users (cons* %base-user-accounts))
+        (users (cons*
+                ,@(map (lambda (account)
+                        (list 'user-account
+                              (list 'name (user-account-name account))
+                              (list 'group (user-account-group account))
+                              (list 'supplementary-groups
+                                    `(quote 
,(user-account-supplementary-groups account)))
+                              (list 'comment (user-account-comment account))
+                              (list 'home (user-account-home-directory 
account))))
+                      users)
+                %base-user-accounts))
         (packages (cons*
                    ,@(if system-role
                          (role-packages system-role)
diff --git a/gnu/system/installer/guixsd-installer.scm 
b/gnu/system/installer/guixsd-installer.scm
index 0d48f1e..12f0d90 100644
--- a/gnu/system/installer/guixsd-installer.scm
+++ b/gnu/system/installer/guixsd-installer.scm
@@ -36,6 +36,7 @@
              (gnu system installer install)
              (gnu system installer format)
             (gnu system installer page)
+             (gnu system installer users)
              (gnu system installer ping)
             (gnu system installer dialog)
 
@@ -64,6 +65,7 @@
 (define network-menu-title      (M_ "Set up the network"))
 (define timezone-menu-title     (M_ "Set the time zone"))
 (define hostname-menu-title     (M_ "Set the host name"))
+(define users-menu-title        (M_ "Add users"))
 (define installation-menu-title (M_ "Install the system"))
 (define role-menu-title         (M_ "Select a role for the system"))
 (define generate-menu-title     (M_ "Generate the configuration"))
@@ -124,6 +126,14 @@
                                page
                                hostname-menu-title))))
 
+    (users . ,(make-task users-menu-title
+                            '()
+                            (lambda () #t)
+                            (lambda (page)
+                              (make-users-page
+                               page
+                               users-menu-title))))
+
     (role . ,(make-task role-menu-title
                             '()
                             (lambda () (and system-role (role? system-role)))
diff --git a/gnu/system/installer/misc.scm b/gnu/system/installer/misc.scm
index 4bed5b8..c3cc93c 100644
--- a/gnu/system/installer/misc.scm
+++ b/gnu/system/installer/misc.scm
@@ -18,6 +18,7 @@
 
 (define-module (gnu system installer misc)
   #:use-module (ncurses curses)
+  #:use-module (gnu system shadow)
 
   #:export (livery-title)
   #:export (strong-colour)
@@ -26,6 +27,7 @@
   #:export (config-file)
   #:export (key-map)
   #:export (system-role)
+  #:export (users)
   #:export (installer-texinfo-markup)
   #:export (mount-points))
 
@@ -71,3 +73,21 @@
     (sansserif    . ,normal)
     (slanted      . ,normal)
     (t            . ,normal)))
+
+
+(define users
+  (list
+   (user-account
+    (name "fred")
+    (supplementary-groups '("video" "audio" "desktop"))
+    (group "users")
+    (comment "Fred Bloggs")
+    (home-directory "/home/empty")
+    )
+
+   (user-account
+    (name "john")
+    (group "users")
+    (comment "John Darrington")
+    (home-directory "/home/john")
+    )))
diff --git a/gnu/system/installer/users.scm b/gnu/system/installer/users.scm
new file mode 100644
index 0000000..03137cf
--- /dev/null
+++ b/gnu/system/installer/users.scm
@@ -0,0 +1,153 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 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 users)
+  #:use-module (gnu system installer page)
+  #:use-module (gnu system installer misc)
+  #:use-module (gnu system installer utils)
+  #:use-module (gnu system shadow)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (gurses menu)
+  #:use-module (gurses buttons)
+  #:use-module (ncurses curses)
+  #:use-module (ice-9 pretty-print)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+
+  #:export (make-users-page))
+
+(include "i18n.scm")
+
+(define (make-users-page parent  title)
+  (make-page (page-surface parent)
+            title
+            users-page-refresh
+             0
+            users-page-key-handler))
+
+
+(define my-buttons `((delete ,(M_ "_Delete") #t)
+                     (add ,(M_ "_Add") #t)
+                     (cancel ,(M_ "Canc_el") #t)))
+
+(define (users-page-key-handler page ch)
+  (let ((menu (page-datum page 'menu))
+       (nav  (page-datum page 'navigation)))
+
+    (cond
+     ((eq? ch #\tab)
+      (cond
+       ((menu-active menu)
+         (menu-set-active! menu #f)
+         (buttons-select nav 0))
+
+       ((eqv? (buttons-selected nav) (1- (buttons-n-buttons nav)))
+       (menu-set-active! menu #t)
+       (buttons-unselect-all nav))
+
+       (else
+       (buttons-select-next nav))))
+
+     ((eq? ch KEY_RIGHT)
+      (menu-set-active! menu #f)
+      (buttons-select-next nav))
+
+     ((eq? ch KEY_LEFT)
+      (menu-set-active! menu #f)
+      (buttons-select-prev nav))
+
+     ((eq? ch KEY_UP)
+      (buttons-unselect-all nav)
+      (menu-set-active! menu #t))
+
+
+     ((select-key? ch)
+      (page-leave))
+
+     ((buttons-key-matches-symbol? nav ch 'cancel)
+      (page-leave))
+
+     ((buttons-key-matches-symbol? nav ch 'delete)
+      (set! users (remove (lambda (user)
+                             (equal? user (menu-get-current-item menu)))
+                           users))
+      (page-set-initialised! page #f)))
+
+    (std-menu-key-handler menu ch))
+  #f)
+
+
+(define (users-page-refresh page)
+  (when (not (page-initialised? page))
+    (users-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 (users-page-init p)
+  (let* ((s (page-surface p))
+        (pr (make-boxed-window  #f
+             (- (getmaxy s) 4) (- (getmaxx s) 2)
+             2 1
+             #:title (page-title p)))
+        (text-window (derwin
+                      (inner 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 users
+                          #:disp-proc (lambda (x r)
+                                        (format #f "~16a ~40a"
+                                                (user-account-name x)
+                                                (user-account-comment x))))))
+
+    (addstr*
+     text-window
+     (if (null? users)
+         (format #f
+                 (M_ "Currently there are no users in the system 
configuration.  You can add some users now, or you can ignore this step and add 
them after the system has been installed.  The root user will be automatically 
created regardless."))
+         (format #f (M_
+                     "The following user accounts are currently configured.  
You can edit the account details here and add or remove them as desired."))))
+
+    (push-cursor (page-cursor-visibility p))
+
+    (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)))