Commit | Line | Data |
---|---|---|
d0f3a672 MO |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com> | |
898677ed | 3 | ;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org> |
d0f3a672 MO |
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) | |
35e99a23 | 21 | #:use-module (gnu installer user) |
d0f3a672 MO |
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 | ||
187122b9 LC |
32 | (define* (run-user-add-page #:key (name "") (home-directory "")) |
33 | "Run a form to enter the user name, home directory, and password. Use NAME | |
34 | and HOME-DIRECTORY as the initial values in the form." | |
d0f3a672 MO |
35 | (define (pad-label label) |
36 | (string-pad-right label 20)) | |
37 | ||
38 | (let* ((label-name | |
39 | (make-label -1 -1 (pad-label (G_ "Name")))) | |
d0f3a672 MO |
40 | (label-home-directory |
41 | (make-label -1 -1 (pad-label (G_ "Home directory")))) | |
898677ed LC |
42 | (label-password |
43 | (make-label -1 -1 (pad-label (G_ "Password")))) | |
d0f3a672 | 44 | (entry-width 30) |
187122b9 LC |
45 | (entry-name (make-entry -1 -1 entry-width |
46 | #:initial-value name)) | |
47 | (entry-home-directory (make-entry -1 -1 entry-width | |
48 | #:initial-value home-directory)) | |
898677ed LC |
49 | (entry-password (make-entry -1 -1 entry-width |
50 | #:flags FLAG-PASSWORD)) | |
51 | (entry-grid (make-grid 3 4)) | |
d0f3a672 | 52 | (button-grid (make-grid 1 1)) |
ebb36dec | 53 | (ok-button (make-button -1 -1 (G_ "OK"))) |
d0f3a672 MO |
54 | (grid (make-grid 1 2)) |
55 | (title (G_ "User creation")) | |
56 | (set-entry-grid-field | |
57 | (cut set-grid-field entry-grid <> <> GRID-ELEMENT-COMPONENT <>)) | |
58 | (form (make-form))) | |
59 | ||
60 | (set-entry-grid-field 0 0 label-name) | |
61 | (set-entry-grid-field 1 0 entry-name) | |
35e99a23 MO |
62 | (set-entry-grid-field 0 1 label-home-directory) |
63 | (set-entry-grid-field 1 1 entry-home-directory) | |
898677ed LC |
64 | (set-entry-grid-field 0 2 label-password) |
65 | (set-entry-grid-field 1 2 entry-password) | |
d0f3a672 MO |
66 | |
67 | (set-grid-field button-grid 0 0 GRID-ELEMENT-COMPONENT ok-button) | |
68 | ||
69 | (add-component-callback | |
70 | entry-name | |
71 | (lambda (component) | |
72 | (set-entry-text entry-home-directory | |
73 | (string-append "/home/" (entry-value entry-name))))) | |
74 | ||
75 | (add-components-to-form form | |
898677ed LC |
76 | label-name label-home-directory label-password |
77 | entry-name entry-home-directory entry-password | |
d0f3a672 MO |
78 | ok-button) |
79 | ||
80 | (make-wrapped-grid-window (vertically-stacked-grid | |
81 | GRID-ELEMENT-SUBGRID entry-grid | |
82 | GRID-ELEMENT-SUBGRID button-grid) | |
83 | title) | |
84 | (let ((error-page | |
85 | (lambda () | |
d700d131 | 86 | (run-error-page (G_ "Empty inputs are not allowed.") |
d0f3a672 MO |
87 | (G_ "Empty input"))))) |
88 | (receive (exit-reason argument) | |
89 | (run-form form) | |
90 | (dynamic-wind | |
91 | (const #t) | |
92 | (lambda () | |
93 | (when (eq? exit-reason 'exit-component) | |
94 | (cond | |
95 | ((components=? argument ok-button) | |
898677ed LC |
96 | (let ((name (entry-value entry-name)) |
97 | (home-directory (entry-value entry-home-directory)) | |
98 | (password (entry-value entry-password))) | |
d0f3a672 | 99 | (if (or (string=? name "") |
d0f3a672 MO |
100 | (string=? home-directory "")) |
101 | (begin | |
102 | (error-page) | |
103 | (run-user-add-page)) | |
35e99a23 MO |
104 | (user |
105 | (name name) | |
898677ed | 106 | (home-directory home-directory) |
187122b9 LC |
107 | (password |
108 | (confirm-password password | |
109 | (lambda () | |
110 | (run-user-add-page | |
111 | #:name name | |
112 | #:home-directory | |
113 | home-directory))))))))))) | |
d0f3a672 MO |
114 | (lambda () |
115 | (destroy-form-and-pop form))))))) | |
116 | ||
8f2b7e3c LC |
117 | (define (confirm-password password try-again) |
118 | "Ask the user to confirm PASSWORD, a possibly empty string. Call TRY-AGAIN, | |
119 | a thunk, if the confirmation doesn't match PASSWORD. Return the confirmed | |
120 | password." | |
121 | (define confirmation | |
122 | (run-input-page (G_ "Please confirm the password.") | |
123 | (G_ "Password confirmation required") | |
124 | #:allow-empty-input? #t | |
125 | #:input-flags FLAG-PASSWORD)) | |
126 | ||
127 | (if (string=? password confirmation) | |
128 | password | |
129 | (begin | |
130 | (run-error-page | |
131 | (G_ "Password mismatch, please try again.") | |
132 | (G_ "Password error")) | |
133 | (try-again)))) | |
134 | ||
91a7c499 LC |
135 | (define (run-root-password-page) |
136 | ;; TRANSLATORS: Leave "root" untranslated: it refers to the name of the | |
137 | ;; system administrator account. | |
8f2b7e3c LC |
138 | (define password |
139 | (run-input-page (G_ "Please choose a password for the system \ | |
91a7c499 | 140 | administrator (\"root\").") |
8f2b7e3c LC |
141 | (G_ "System administrator password") |
142 | #:input-flags FLAG-PASSWORD)) | |
143 | ||
144 | (confirm-password password run-root-password-page)) | |
91a7c499 | 145 | |
d0f3a672 MO |
146 | (define (run-user-page) |
147 | (define (run users) | |
148 | (let* ((listbox (make-listbox | |
149 | -1 -1 10 | |
150 | (logior FLAG-SCROLL FLAG-BORDER))) | |
151 | (info-textbox | |
152 | (make-reflowed-textbox | |
153 | -1 -1 | |
154 | (G_ "Please add at least one user to system\ | |
155 | using the 'Add' button.") | |
156 | 40 #:flags FLAG-BORDER)) | |
157 | (add-button (make-compact-button -1 -1 (G_ "Add"))) | |
158 | (del-button (make-compact-button -1 -1 (G_ "Delete"))) | |
159 | (listbox-button-grid | |
160 | (apply | |
161 | vertically-stacked-grid | |
162 | GRID-ELEMENT-COMPONENT add-button | |
163 | `(,@(if (null? users) | |
164 | '() | |
165 | (list GRID-ELEMENT-COMPONENT del-button))))) | |
ebb36dec | 166 | (ok-button (make-button -1 -1 (G_ "OK"))) |
7d812901 | 167 | (exit-button (make-button -1 -1 (G_ "Exit"))) |
35e99a23 | 168 | (title "User creation") |
d0f3a672 MO |
169 | (grid |
170 | (vertically-stacked-grid | |
171 | GRID-ELEMENT-COMPONENT info-textbox | |
172 | GRID-ELEMENT-SUBGRID (horizontal-stacked-grid | |
173 | GRID-ELEMENT-COMPONENT listbox | |
174 | GRID-ELEMENT-SUBGRID listbox-button-grid) | |
175 | GRID-ELEMENT-SUBGRID (horizontal-stacked-grid | |
176 | GRID-ELEMENT-COMPONENT ok-button | |
7d812901 | 177 | GRID-ELEMENT-COMPONENT exit-button))) |
d0f3a672 | 178 | (sorted-users (sort users (lambda (a b) |
35e99a23 MO |
179 | (string<= (user-name a) |
180 | (user-name b))))) | |
d0f3a672 MO |
181 | (listbox-elements |
182 | (map | |
183 | (lambda (user) | |
184 | `((key . ,(append-entry-to-listbox listbox | |
35e99a23 | 185 | (user-name user))) |
d0f3a672 MO |
186 | (user . ,user))) |
187 | sorted-users)) | |
188 | (form (make-form))) | |
189 | ||
190 | ||
191 | (add-form-to-grid grid form #t) | |
192 | (make-wrapped-grid-window grid title) | |
193 | (if (null? users) | |
194 | (set-current-component form add-button) | |
195 | (set-current-component form ok-button)) | |
196 | ||
197 | (receive (exit-reason argument) | |
198 | (run-form form) | |
199 | (dynamic-wind | |
200 | (const #t) | |
201 | (lambda () | |
202 | (when (eq? exit-reason 'exit-component) | |
203 | (cond | |
204 | ((components=? argument add-button) | |
205 | (run (cons (run-user-add-page) users))) | |
206 | ((components=? argument del-button) | |
207 | (let* ((current-user-key (current-listbox-entry listbox)) | |
208 | (users | |
209 | (map (cut assoc-ref <> 'user) | |
210 | (remove (lambda (element) | |
211 | (equal? (assoc-ref element 'key) | |
212 | current-user-key)) | |
213 | listbox-elements)))) | |
214 | (run users))) | |
215 | ((components=? argument ok-button) | |
216 | (when (null? users) | |
217 | (run-error-page (G_ "Please create at least one user.") | |
218 | (G_ "No user")) | |
35e99a23 | 219 | (run users)) |
e7c7b733 | 220 | (reverse users))))) |
d0f3a672 MO |
221 | (lambda () |
222 | (destroy-form-and-pop form)))))) | |
91a7c499 LC |
223 | |
224 | ;; Add a "root" user simply to convey the root password. | |
225 | (cons (user (name "root") | |
226 | (home-directory "/root") | |
227 | (password (run-root-password-page))) | |
228 | (run '()))) |