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 steps) #:select (&installer-step-abort))
  23   #:use-module (gnu installer newt page)
  24   #:use-module (gnu installer newt utils)
  25   #:use-module (guix i18n)
  26   #:use-module (newt)
  27   #:use-module (ice-9 match)
  28   #:use-module (ice-9 receive)
  29   #:use-module (srfi srfi-1)
  30   #:use-module (srfi srfi-26)
  31   #:use-module (srfi srfi-34)
  32   #:use-module (srfi srfi-35)
  33   #:export (run-user-page))
  34
  35 (define* (run-user-add-page #:key (name "") (real-name "")
  36                             (home-directory ""))
  37   "Run a form to enter the user name, home directory, and password.  Use NAME,
  38 REAL-NAME, and HOME-DIRECTORY as the initial values in the form."
  39   (define (pad-label label)
  40     (string-pad-right label 25))
  41
  42   (let* ((label-name
  43           (make-label -1 -1 (pad-label (G_ "Name"))))
  44          (label-real-name
  45           (make-label -1 -1 (pad-label (G_ "Real name"))))
  46          (label-home-directory
  47           (make-label -1 -1 (pad-label (G_ "Home directory"))))
  48          (label-password
  49           (make-label -1 -1 (pad-label (G_ "Password"))))
  50          (entry-width 35)
  51          (entry-name (make-entry -1 -1 entry-width
  52                                  #:initial-value name))
  53          (entry-real-name (make-entry -1 -1 entry-width
  54                                       #:initial-value real-name))
  55          (entry-home-directory (make-entry -1 -1 entry-width
  56                                            #:initial-value home-directory))
  57          (password-visible-cb
  58           (make-checkbox -1 -1 (G_ "Hide") #\x "x "))
  59          (entry-password (make-entry -1 -1 entry-width
  60                                      #:flags (logior FLAG-PASSWORD
  61                                                      FLAG-SCROLL)))
  62          (entry-grid (make-grid 3 5))
  63          (button-grid (make-grid 1 1))
  64          (ok-button (make-button -1 -1 (G_ "OK")))
  65          (grid (make-grid 1 2))
  66          (title (G_ "User creation"))
  67          (set-entry-grid-field
  68           (cut set-grid-field entry-grid <> <> GRID-ELEMENT-COMPONENT <>))
  69          (form (make-form)))
  70
  71     (set-entry-grid-field 0 0 label-name)
  72     (set-entry-grid-field 1 0 entry-name)
  73     (set-entry-grid-field 0 1 label-real-name)
  74     (set-entry-grid-field 1 1 entry-real-name)
  75     (set-entry-grid-field 0 2 label-home-directory)
  76     (set-entry-grid-field 1 2 entry-home-directory)
  77     (set-entry-grid-field 0 3 label-password)
  78     (set-entry-grid-field 1 3 entry-password)
  79
  80     (set-grid-field entry-grid
  81                     2 3
  82                     GRID-ELEMENT-COMPONENT
  83                     password-visible-cb
  84                     #:pad-left 1)
  85
  86     (set-grid-field button-grid 0 0 GRID-ELEMENT-COMPONENT ok-button)
  87
  88     (add-component-callback
  89      entry-name
  90      (lambda (component)
  91        (set-entry-text entry-home-directory
  92                        (string-append "/home/" (entry-value entry-name)))
  93
  94        (when (string-null? (entry-value entry-real-name))
  95          (set-entry-text entry-real-name
  96                          (string-titlecase (entry-value entry-name))))))
  97
  98     (add-component-callback
  99      password-visible-cb
 100      (lambda (component)
 101        (set-entry-flags entry-password
 102                         FLAG-PASSWORD
 103                         FLAG-ROLE-TOGGLE)))
 104
 105     (add-components-to-form form
 106                             label-name label-real-name
 107                             label-home-directory label-password
 108                             entry-name entry-real-name
 109                             entry-home-directory entry-password
 110                             password-visible-cb
 111                             ok-button)
 112
 113     (make-wrapped-grid-window (vertically-stacked-grid
 114                                GRID-ELEMENT-SUBGRID entry-grid
 115                                GRID-ELEMENT-SUBGRID button-grid)
 116                               title)
 117     (let ((error-page
 118            (lambda ()
 119              (run-error-page (G_ "Empty inputs are not allowed.")
 120                              (G_ "Empty input")))))
 121       (receive (exit-reason argument)
 122           (run-form form)
 123         (dynamic-wind
 124           (const #t)
 125           (lambda ()
 126             (when (eq? exit-reason 'exit-component)
 127               (cond
 128                ((components=? argument ok-button)
 129                 (let ((name           (entry-value entry-name))
 130                       (real-name      (entry-value entry-real-name))
 131                       (home-directory (entry-value entry-home-directory))
 132                       (password       (entry-value entry-password)))
 133                   (if (or (string=? name "")
 134                           (string=? home-directory ""))
 135                       (begin
 136                         (error-page)
 137                         (run-user-add-page))
 138                       (let ((password (confirm-password password)))
 139                         (if password
 140                             (user
 141                              (name name)
 142                              (real-name real-name)
 143                              (home-directory home-directory)
 144                              (password password))
 145                             (run-user-add-page #:name name
 146                                                #:real-name real-name
 147                                                #:home-directory
 148                                                home-directory)))))))))
 149           (lambda ()
 150             (destroy-form-and-pop form)))))))
 151
 152 (define* (confirm-password password #:optional (try-again (const #f)))
 153   "Ask the user to confirm PASSWORD, a possibly empty string.  Call TRY-AGAIN,
 154 a thunk, if the confirmation doesn't match PASSWORD, and return its result."
 155   (define confirmation
 156     (run-input-page (G_ "Please confirm the password.")
 157                     (G_ "Password confirmation required")
 158                     #:allow-empty-input? #t
 159                     #:input-hide-checkbox? #t))
 160
 161   (if (string=? password confirmation)
 162       password
 163       (begin
 164         (run-error-page
 165          (G_ "Password mismatch, please try again.")
 166          (G_ "Password error"))
 167         (try-again))))
 168
 169 (define (run-root-password-page)
 170   ;; TRANSLATORS: Leave "root" untranslated: it refers to the name of the
 171   ;; system administrator account.
 172   (define password
 173     (run-input-page (G_ "Please choose a password for the system \
 174 administrator (\"root\").")
 175                     (G_ "System administrator password")
 176                     #:input-hide-checkbox? #t))
 177
 178   (confirm-password password run-root-password-page))
 179
 180 (define (run-user-page)
 181   (define (run users)
 182     (let* ((listbox (make-listbox
 183                      -1 -1 10
 184                      (logior FLAG-SCROLL FLAG-BORDER)))
 185            (info-textbox
 186             (make-reflowed-textbox
 187              -1 -1
 188              (G_ "Please add at least one user to system\
 189  using the 'Add' button.")
 190              40 #:flags FLAG-BORDER))
 191            (add-button (make-compact-button -1 -1 (G_ "Add")))
 192            (del-button (make-compact-button -1 -1 (G_ "Delete")))
 193            (listbox-button-grid
 194             (apply
 195              vertically-stacked-grid
 196              GRID-ELEMENT-COMPONENT add-button
 197              `(,@(if (null? users)
 198                      '()
 199                      (list GRID-ELEMENT-COMPONENT del-button)))))
 200            (ok-button (make-button -1 -1 (G_ "OK")))
 201            (exit-button (make-button -1 -1 (G_ "Exit")))
 202            (title (G_ "User creation"))
 203            (grid
 204             (vertically-stacked-grid
 205              GRID-ELEMENT-COMPONENT info-textbox
 206              GRID-ELEMENT-SUBGRID (horizontal-stacked-grid
 207                                    GRID-ELEMENT-COMPONENT listbox
 208                                    GRID-ELEMENT-SUBGRID listbox-button-grid)
 209              GRID-ELEMENT-SUBGRID (horizontal-stacked-grid
 210                                    GRID-ELEMENT-COMPONENT ok-button
 211                                    GRID-ELEMENT-COMPONENT exit-button)))
 212            (sorted-users (sort users (lambda (a b)
 213                                        (string<= (user-name a)
 214                                                  (user-name b)))))
 215            (listbox-elements
 216             (map
 217              (lambda (user)
 218                `((key . ,(append-entry-to-listbox listbox
 219                                                   (user-name user)))
 220                  (user . ,user)))
 221              sorted-users))
 222            (form (make-form)))
 223
 224
 225       (add-form-to-grid grid form #t)
 226       (make-wrapped-grid-window grid title)
 227       (if (null? users)
 228           (set-current-component form add-button)
 229           (set-current-component form ok-button))
 230
 231       (receive (exit-reason argument)
 232           (run-form form)
 233         (dynamic-wind
 234           (const #t)
 235           (lambda ()
 236             (when (eq? exit-reason 'exit-component)
 237               (cond
 238                ((components=? argument add-button)
 239                 (run (cons (run-user-add-page) users)))
 240                ((components=? argument del-button)
 241                 (let* ((current-user-key (current-listbox-entry listbox))
 242                        (users
 243                         (map (cut assoc-ref <> 'user)
 244                              (remove (lambda (element)
 245                                        (equal? (assoc-ref element 'key)
 246                                                current-user-key))
 247                                      listbox-elements))))
 248                   (run users)))
 249                ((components=? argument ok-button)
 250                 (when (null? users)
 251                   (run-error-page (G_ "Please create at least one user.")
 252                                   (G_ "No user"))
 253                   (run users))
 254                 (reverse users))
 255                ((components=? argument exit-button)
 256                 (raise
 257                  (condition
 258                   (&installer-step-abort)))))))
 259           (lambda ()
 260             (destroy-form-and-pop form))))))
 261
 262   ;; Add a "root" user simply to convey the root password.
 263   (cons (user (name "root")
 264               (home-directory "/root")
 265               (password (run-root-password-page)))
 266         (run '())))