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