gnu/installer/newt/user.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
   3 ;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (gnu installer newt user)
  21   #:use-module (gnu installer user)
  22   #:use-module (gnu installer newt page)
  23   #:use-module (gnu installer newt utils)
  24   #:use-module (guix i18n)
  25   #:use-module (newt)
  26   #:use-module (ice-9 match)
  27   #:use-module (ice-9 receive)
  28   #:use-module (srfi srfi-1)
  29   #:use-module (srfi srfi-26)
  30   #:export (run-user-page))
  31
  32 (define* (run-user-add-page #:key (name "") (real-name "")
  33                             (home-directory ""))
  34   "Run a form to enter the user name, home directory, and password.  Use NAME,
  35 REAL-NAME, and HOME-DIRECTORY as the initial values in the form."
  36   (define (pad-label label)
  37     (string-pad-right label 20))
  38
  39   (let* ((label-name
  40           (make-label -1 -1 (pad-label (G_ "Name"))))
  41          (label-real-name
  42           (make-label -1 -1 (pad-label (G_ "Real name"))))
  43          (label-home-directory
  44           (make-label -1 -1 (pad-label (G_ "Home directory"))))
  45          (label-password
  46           (make-label -1 -1 (pad-label (G_ "Password"))))
  47          (entry-width 30)
  48          (entry-name (make-entry -1 -1 entry-width
  49                                  #:initial-value name))
  50          (entry-real-name (make-entry -1 -1 entry-width
  51                                       #:initial-value real-name))
  52          (entry-home-directory (make-entry -1 -1 entry-width
  53                                            #:initial-value home-directory))
  54          (entry-password (make-entry -1 -1 entry-width
  55                                      #:flags FLAG-PASSWORD))
  56          (entry-grid (make-grid 2 5))
  57          (button-grid (make-grid 1 1))
  58          (ok-button (make-button -1 -1 (G_ "OK")))
  59          (grid (make-grid 1 2))
  60          (title (G_ "User creation"))
  61          (set-entry-grid-field
  62           (cut set-grid-field entry-grid <> <> GRID-ELEMENT-COMPONENT <>))
  63          (form (make-form)))
  64
  65     (set-entry-grid-field 0 0 label-name)
  66     (set-entry-grid-field 1 0 entry-name)
  67     (set-entry-grid-field 0 1 label-real-name)
  68     (set-entry-grid-field 1 1 entry-real-name)
  69     (set-entry-grid-field 0 2 label-home-directory)
  70     (set-entry-grid-field 1 2 entry-home-directory)
  71     (set-entry-grid-field 0 3 label-password)
  72     (set-entry-grid-field 1 3 entry-password)
  73
  74     (set-grid-field button-grid 0 0 GRID-ELEMENT-COMPONENT ok-button)
  75
  76     (add-component-callback
  77      entry-name
  78      (lambda (component)
  79        (set-entry-text entry-home-directory
  80                        (string-append "/home/" (entry-value entry-name)))
  81
  82        (when (string-null? (entry-value entry-real-name))
  83          (set-entry-text entry-real-name
  84                          (string-titlecase (entry-value entry-name))))))
  85
  86     (add-components-to-form form
  87                             label-name label-real-name
  88                             label-home-directory label-password
  89                             entry-name entry-real-name
  90                             entry-home-directory entry-password
  91                             ok-button)
  92
  93     (make-wrapped-grid-window (vertically-stacked-grid
  94                                GRID-ELEMENT-SUBGRID entry-grid
  95                                GRID-ELEMENT-SUBGRID button-grid)
  96                               title)
  97     (let ((error-page
  98            (lambda ()
  99              (run-error-page (G_ "Empty inputs are not allowed.")
 100                              (G_ "Empty input")))))
 101       (receive (exit-reason argument)
 102           (run-form form)
 103         (dynamic-wind
 104           (const #t)
 105           (lambda ()
 106             (when (eq? exit-reason 'exit-component)
 107               (cond
 108                ((components=? argument ok-button)
 109                 (let ((name           (entry-value entry-name))
 110                       (real-name      (entry-value entry-real-name))
 111                       (home-directory (entry-value entry-home-directory))
 112                       (password       (entry-value entry-password)))
 113                   (if (or (string=? name "")
 114                           (string=? home-directory ""))
 115                       (begin
 116                         (error-page)
 117                         (run-user-add-page))
 118                       (let ((password (confirm-password password)))
 119                         (if password
 120                             (user
 121                              (name name)
 122                              (real-name real-name)
 123                              (home-directory home-directory)
 124                              (password password))
 125                             (run-user-add-page #:name name
 126                                                #:real-name real-name
 127                                                #:home-directory
 128                                                home-directory)))))))))
 129           (lambda ()
 130             (destroy-form-and-pop form)))))))
 131
 132 (define* (confirm-password password #:optional (try-again (const #f)))
 133   "Ask the user to confirm PASSWORD, a possibly empty string.  Call TRY-AGAIN,
 134 a thunk, if the confirmation doesn't match PASSWORD, and return its result."
 135   (define confirmation
 136     (run-input-page (G_ "Please confirm the password.")
 137                     (G_ "Password confirmation required")
 138                     #:allow-empty-input? #t
 139                     #:input-flags FLAG-PASSWORD))
 140
 141   (if (string=? password confirmation)
 142       password
 143       (begin
 144         (run-error-page
 145          (G_ "Password mismatch, please try again.")
 146          (G_ "Password error"))
 147         (try-again))))
 148
 149 (define (run-root-password-page)
 150   ;; TRANSLATORS: Leave "root" untranslated: it refers to the name of the
 151   ;; system administrator account.
 152   (define password
 153     (run-input-page (G_ "Please choose a password for the system \
 154 administrator (\"root\").")
 155                     (G_ "System administrator password")
 156                     #:input-flags FLAG-PASSWORD))
 157
 158   (confirm-password password run-root-password-page))
 159
 160 (define (run-user-page)
 161   (define (run users)
 162     (let* ((listbox (make-listbox
 163                      -1 -1 10
 164                      (logior FLAG-SCROLL FLAG-BORDER)))
 165            (info-textbox
 166             (make-reflowed-textbox
 167              -1 -1
 168              (G_ "Please add at least one user to system\
 169  using the 'Add' button.")
 170              40 #:flags FLAG-BORDER))
 171            (add-button (make-compact-button -1 -1 (G_ "Add")))
 172            (del-button (make-compact-button -1 -1 (G_ "Delete")))
 173            (listbox-button-grid
 174             (apply
 175              vertically-stacked-grid
 176              GRID-ELEMENT-COMPONENT add-button
 177              `(,@(if (null? users)
 178                      '()
 179                      (list GRID-ELEMENT-COMPONENT del-button)))))
 180            (ok-button (make-button -1 -1 (G_ "OK")))
 181            (exit-button (make-button -1 -1 (G_ "Exit")))
 182            (title "User creation")
 183            (grid
 184             (vertically-stacked-grid
 185              GRID-ELEMENT-COMPONENT info-textbox
 186              GRID-ELEMENT-SUBGRID (horizontal-stacked-grid
 187                                    GRID-ELEMENT-COMPONENT listbox
 188                                    GRID-ELEMENT-SUBGRID listbox-button-grid)
 189              GRID-ELEMENT-SUBGRID (horizontal-stacked-grid
 190                                    GRID-ELEMENT-COMPONENT ok-button
 191                                    GRID-ELEMENT-COMPONENT exit-button)))
 192            (sorted-users (sort users (lambda (a b)
 193                                        (string<= (user-name a)
 194                                                  (user-name b)))))
 195            (listbox-elements
 196             (map
 197              (lambda (user)
 198                `((key . ,(append-entry-to-listbox listbox
 199                                                   (user-name user)))
 200                  (user . ,user)))
 201              sorted-users))
 202            (form (make-form)))
 203
 204
 205       (add-form-to-grid grid form #t)
 206       (make-wrapped-grid-window grid title)
 207       (if (null? users)
 208           (set-current-component form add-button)
 209           (set-current-component form ok-button))
 210
 211       (receive (exit-reason argument)
 212           (run-form form)
 213         (dynamic-wind
 214           (const #t)
 215           (lambda ()
 216             (when (eq? exit-reason 'exit-component)
 217               (cond
 218                ((components=? argument add-button)
 219                 (run (cons (run-user-add-page) users)))
 220                ((components=? argument del-button)
 221                 (let* ((current-user-key (current-listbox-entry listbox))
 222                        (users
 223                         (map (cut assoc-ref <> 'user)
 224                              (remove (lambda (element)
 225                                        (equal? (assoc-ref element 'key)
 226                                                current-user-key))
 227                                      listbox-elements))))
 228                   (run users)))
 229                ((components=? argument ok-button)
 230                 (when (null? users)
 231                   (run-error-page (G_ "Please create at least one user.")
 232                                   (G_ "No user"))
 233                   (run users))
 234                 (reverse users)))))
 235           (lambda ()
 236             (destroy-form-and-pop form))))))
 237
 238   ;; Add a "root" user simply to convey the root password.
 239   (cons (user (name "root")
 240               (home-directory "/root")
 241               (password (run-root-password-page)))
 242         (run '())))