gnu/installer/newt/user.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (gnu installer newt user)
  20   #:use-module (gnu installer user)
  21   #:use-module (gnu installer newt page)
  22   #:use-module (gnu installer newt utils)
  23   #:use-module (guix i18n)
  24   #:use-module (newt)
  25   #:use-module (ice-9 match)
  26   #:use-module (ice-9 receive)
  27   #:use-module (srfi srfi-1)
  28   #:use-module (srfi srfi-26)
  29   #:export (run-user-page))
  30
  31 (define (run-user-add-page)
  32   (define (pad-label label)
  33     (string-pad-right label 20))
  34
  35   (let* ((label-name
  36           (make-label -1 -1 (pad-label (G_ "Name"))))
  37          (label-home-directory
  38           (make-label -1 -1 (pad-label (G_ "Home directory"))))
  39          (entry-width 30)
  40          (entry-name (make-entry -1 -1 entry-width))
  41          (entry-home-directory (make-entry -1 -1 entry-width))
  42          (entry-grid (make-grid 2 2))
  43          (button-grid (make-grid 1 1))
  44          (ok-button (make-button -1 -1 (G_ "Ok")))
  45          (grid (make-grid 1 2))
  46          (title (G_ "User creation"))
  47          (set-entry-grid-field
  48           (cut set-grid-field entry-grid <> <> GRID-ELEMENT-COMPONENT <>))
  49          (form (make-form)))
  50
  51     (set-entry-grid-field 0 0 label-name)
  52     (set-entry-grid-field 1 0 entry-name)
  53     (set-entry-grid-field 0 1 label-home-directory)
  54     (set-entry-grid-field 1 1 entry-home-directory)
  55
  56     (set-grid-field button-grid 0 0 GRID-ELEMENT-COMPONENT ok-button)
  57
  58     (add-component-callback
  59      entry-name
  60      (lambda (component)
  61        (set-entry-text entry-home-directory
  62                        (string-append "/home/" (entry-value entry-name)))))
  63
  64     (add-components-to-form form
  65                             label-name label-home-directory
  66                             entry-name entry-home-directory
  67                             ok-button)
  68
  69     (make-wrapped-grid-window (vertically-stacked-grid
  70                                GRID-ELEMENT-SUBGRID entry-grid
  71                                GRID-ELEMENT-SUBGRID button-grid)
  72                               title)
  73     (let ((error-page
  74            (lambda ()
  75              (run-error-page (G_ "Empty inputs are not allowed.")
  76                              (G_ "Empty input")))))
  77       (receive (exit-reason argument)
  78           (run-form form)
  79         (dynamic-wind
  80           (const #t)
  81           (lambda ()
  82             (when (eq? exit-reason 'exit-component)
  83               (cond
  84                ((components=? argument ok-button)
  85                 (let ((name (entry-value entry-name))
  86                       (home-directory (entry-value entry-home-directory)))
  87                   (if (or (string=? name "")
  88                           (string=? home-directory ""))
  89                       (begin
  90                         (error-page)
  91                         (run-user-add-page))
  92                       (user
  93                        (name name)
  94                        (home-directory home-directory))))))))
  95           (lambda ()
  96             (destroy-form-and-pop form)))))))
  97
  98 (define (run-user-page)
  99   (define (run users)
 100     (let* ((listbox (make-listbox
 101                      -1 -1 10
 102                      (logior FLAG-SCROLL FLAG-BORDER)))
 103            (info-textbox
 104             (make-reflowed-textbox
 105              -1 -1
 106              (G_ "Please add at least one user to system\
 107  using the 'Add' button.")
 108              40 #:flags FLAG-BORDER))
 109            (add-button (make-compact-button -1 -1 (G_ "Add")))
 110            (del-button (make-compact-button -1 -1 (G_ "Delete")))
 111            (listbox-button-grid
 112             (apply
 113              vertically-stacked-grid
 114              GRID-ELEMENT-COMPONENT add-button
 115              `(,@(if (null? users)
 116                      '()
 117                      (list GRID-ELEMENT-COMPONENT del-button)))))
 118            (ok-button (make-button -1 -1 (G_ "Ok")))
 119            (exit-button (make-button -1 -1 (G_ "Exit")))
 120            (title "User creation")
 121            (grid
 122             (vertically-stacked-grid
 123              GRID-ELEMENT-COMPONENT info-textbox
 124              GRID-ELEMENT-SUBGRID (horizontal-stacked-grid
 125                                    GRID-ELEMENT-COMPONENT listbox
 126                                    GRID-ELEMENT-SUBGRID listbox-button-grid)
 127              GRID-ELEMENT-SUBGRID (horizontal-stacked-grid
 128                                    GRID-ELEMENT-COMPONENT ok-button
 129                                    GRID-ELEMENT-COMPONENT exit-button)))
 130            (sorted-users (sort users (lambda (a b)
 131                                        (string<= (user-name a)
 132                                                  (user-name b)))))
 133            (listbox-elements
 134             (map
 135              (lambda (user)
 136                `((key . ,(append-entry-to-listbox listbox
 137                                                   (user-name user)))
 138                  (user . ,user)))
 139              sorted-users))
 140            (form (make-form)))
 141
 142
 143       (add-form-to-grid grid form #t)
 144       (make-wrapped-grid-window grid title)
 145       (if (null? users)
 146           (set-current-component form add-button)
 147           (set-current-component form ok-button))
 148
 149       (receive (exit-reason argument)
 150           (run-form form)
 151         (dynamic-wind
 152           (const #t)
 153           (lambda ()
 154             (when (eq? exit-reason 'exit-component)
 155               (cond
 156                ((components=? argument add-button)
 157                 (run (cons (run-user-add-page) users)))
 158                ((components=? argument del-button)
 159                 (let* ((current-user-key (current-listbox-entry listbox))
 160                        (users
 161                         (map (cut assoc-ref <> 'user)
 162                              (remove (lambda (element)
 163                                        (equal? (assoc-ref element 'key)
 164                                                current-user-key))
 165                                      listbox-elements))))
 166                   (run users)))
 167                ((components=? argument ok-button)
 168                 (when (null? users)
 169                   (run-error-page (G_ "Please create at least one user.")
 170                                   (G_ "No user"))
 171                   (run users))
 172                 users))))
 173           (lambda ()
 174             (destroy-form-and-pop form))))))
 175   (run '()))