Commit | Line | Data |
---|---|---|
69a934f2 | 1 | ;;; GNU Guix --- Functional package management for GNU |
3dd3ac4d | 2 | ;;; Copyright © 2018, 2019 Mathieu Othacehe <m.othacehe@gmail.com> |
c73e554c | 3 | ;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org> |
69a934f2 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 partition) | |
21 | #:use-module (gnu installer parted) | |
22 | #:use-module (gnu installer steps) | |
23 | #:use-module (gnu installer utils) | |
24 | #:use-module (gnu installer newt page) | |
25 | #:use-module (gnu installer newt utils) | |
26 | #:use-module (guix i18n) | |
27 | #:use-module (ice-9 match) | |
28 | #:use-module (srfi srfi-1) | |
29 | #:use-module (srfi srfi-26) | |
30 | #:use-module (srfi srfi-34) | |
31 | #:use-module (srfi srfi-35) | |
32 | #:use-module (newt) | |
33 | #:use-module (parted) | |
34 | #:export (run-partioning-page)) | |
35 | ||
7d812901 | 36 | (define (button-exit-action) |
69a934f2 MO |
37 | "Raise the &installer-step-abort condition." |
38 | (raise | |
39 | (condition | |
40 | (&installer-step-abort)))) | |
41 | ||
42 | (define (run-scheme-page) | |
43 | "Run a page asking the user for a partitioning scheme." | |
44 | (let* ((items | |
7dbdbbfd LC |
45 | `((root . ,(G_ "Everything is one partition")) |
46 | (root-home . ,(G_ "Separate /home partition")))) | |
69a934f2 MO |
47 | (result (run-listbox-selection-page |
48 | #:info-text (G_ "Please select a partitioning scheme.") | |
49 | #:title (G_ "Partition scheme") | |
50 | #:listbox-items items | |
51 | #:listbox-item->text cdr | |
d1e5f758 | 52 | #:listbox-height 4 |
9d2d9cb1 | 53 | #:sort-listbox-items? #f ;keep the 'root' option first |
7d812901 MO |
54 | #:button-text (G_ "Exit") |
55 | #:button-callback-procedure button-exit-action))) | |
69a934f2 MO |
56 | (car result))) |
57 | ||
85caf5f3 | 58 | (define (draw-formatting-page) |
c73e554c LC |
59 | "Draw a page asking for confirmation, and then indicating that partitions |
60 | are being formatted." | |
61 | (run-confirmation-page (G_ "We are about to format your hard disk. All \ | |
62 | its data will be lost. Do you wish to continue?") | |
63 | (G_ "Format disk?") | |
64 | #:exit-button-procedure button-exit-action) | |
69a934f2 | 65 | (draw-info-page |
85caf5f3 | 66 | (format #f (G_ "Partition formatting is in progress, please wait.")) |
69a934f2 MO |
67 | (G_ "Preparing partitions"))) |
68 | ||
69 | (define (run-device-page devices) | |
70 | "Run a page asking the user to select a device among those in the given | |
71 | DEVICES list." | |
72 | (define (device-items) | |
73 | (map (lambda (device) | |
74 | `(,device . ,(device-description device))) | |
75 | devices)) | |
76 | ||
77 | (let* ((result (run-listbox-selection-page | |
78 | #:info-text (G_ "Please select a disk.") | |
79 | #:title (G_ "Disk") | |
80 | #:listbox-items (device-items) | |
81 | #:listbox-item->text cdr | |
d1e5f758 | 82 | #:listbox-height 10 |
7d812901 MO |
83 | #:button-text (G_ "Exit") |
84 | #:button-callback-procedure button-exit-action)) | |
69a934f2 MO |
85 | (device (car result))) |
86 | device)) | |
87 | ||
cbeb2702 | 88 | (define (run-label-page button-text button-callback) |
69a934f2 MO |
89 | "Run a page asking the user to select a partition table label." |
90 | (run-listbox-selection-page | |
91 | #:info-text (G_ "Select a new partition table type. \ | |
92 | Be careful, all data on the disk will be lost.") | |
93 | #:title (G_ "Partition table") | |
94 | #:listbox-items '("msdos" "gpt") | |
95 | #:listbox-item->text identity | |
cbeb2702 | 96 | #:button-text button-text |
69a934f2 MO |
97 | #:button-callback-procedure button-callback)) |
98 | ||
99 | (define (run-type-page partition) | |
100 | "Run a page asking the user to select a partition type." | |
101 | (let* ((disk (partition-disk partition)) | |
102 | (partitions (disk-partitions disk)) | |
103 | (other-extended-partitions? | |
104 | (any extended-partition? partitions)) | |
105 | (items | |
106 | `(normal ,@(if other-extended-partitions? | |
107 | '() | |
108 | '(extended))))) | |
109 | (run-listbox-selection-page | |
d700d131 | 110 | #:info-text (G_ "Please select a partition type.") |
69a934f2 MO |
111 | #:title (G_ "Partition type") |
112 | #:listbox-items items | |
113 | #:listbox-item->text symbol->string | |
114 | #:sort-listbox-items? #f | |
7d812901 MO |
115 | #:button-text (G_ "Exit") |
116 | #:button-callback-procedure button-exit-action))) | |
69a934f2 MO |
117 | |
118 | (define (run-fs-type-page) | |
119 | "Run a page asking the user to select a file-system type." | |
120 | (run-listbox-selection-page | |
d700d131 | 121 | #:info-text (G_ "Please select the file-system type for this partition.") |
69a934f2 | 122 | #:title (G_ "File-system type") |
1a92f1ff | 123 | #:listbox-items '(ext4 btrfs fat16 fat32 swap) |
69a934f2 MO |
124 | #:listbox-item->text user-fs-type-name |
125 | #:sort-listbox-items? #f | |
7d812901 MO |
126 | #:button-text (G_ "Exit") |
127 | #:button-callback-procedure button-exit-action)) | |
69a934f2 MO |
128 | |
129 | (define (inform-can-create-partition? user-partition) | |
130 | "Return #t if it is possible to create USER-PARTITION. This is determined by | |
131 | calling CAN-CREATE-PARTITION? procedure. If an exception is raised, catch it | |
132 | an inform the user with an appropriate error-page and return #f." | |
133 | (guard (c ((max-primary-exceeded? c) | |
134 | (run-error-page | |
d700d131 | 135 | (G_ "Primary partitions count exceeded.") |
69a934f2 MO |
136 | (G_ "Creation error")) |
137 | #f) | |
138 | ((extended-creation-error? c) | |
139 | (run-error-page | |
d700d131 | 140 | (G_ "Extended partition creation error.") |
69a934f2 MO |
141 | (G_ "Creation error")) |
142 | #f) | |
143 | ((logical-creation-error? c) | |
144 | (run-error-page | |
d700d131 | 145 | (G_ "Logical partition creation error.") |
69a934f2 MO |
146 | (G_ "Creation error")) |
147 | #f)) | |
148 | (can-create-partition? user-partition))) | |
149 | ||
bf304dbc MO |
150 | (define (prompt-luks-passwords user-partitions) |
151 | "Prompt for the luks passwords of the encrypted partitions in | |
152 | USER-PARTITIONS list. Return this list with password fields filled-in." | |
153 | (map (lambda (user-part) | |
154 | (let* ((crypt-label (user-partition-crypt-label user-part)) | |
44b2d31c | 155 | (file-name (user-partition-file-name user-part)) |
bf304dbc MO |
156 | (password-page |
157 | (lambda () | |
158 | (run-input-page | |
159 | (format #f (G_ "Please enter the password for the \ | |
44b2d31c | 160 | encryption of partition ~a (label: ~a).") file-name crypt-label) |
445bd4d5 | 161 | (G_ "Password required") |
3dd3ac4d | 162 | #:input-visibility-checkbox? #t))) |
f40728f9 MO |
163 | (password-confirm-page |
164 | (lambda () | |
165 | (run-input-page | |
166 | (format #f (G_ "Please confirm the password for the \ | |
167 | encryption of partition ~a (label: ~a).") file-name crypt-label) | |
453c9765 | 168 | (G_ "Password confirmation required") |
3dd3ac4d | 169 | #:input-visibility-checkbox? #t)))) |
bf304dbc | 170 | (if crypt-label |
f40728f9 MO |
171 | (let loop () |
172 | (let ((password (password-page)) | |
173 | (confirmation (password-confirm-page))) | |
174 | (if (string=? password confirmation) | |
175 | (user-partition | |
176 | (inherit user-part) | |
177 | (crypt-password password)) | |
178 | (begin | |
179 | (run-error-page | |
180 | (G_ "Password mismatch, please try again.") | |
181 | (G_ "Password error")) | |
182 | (loop))))) | |
bf304dbc MO |
183 | user-part))) |
184 | user-partitions)) | |
185 | ||
69a934f2 MO |
186 | (define* (run-partition-page target-user-partition |
187 | #:key | |
188 | (default-item #f)) | |
189 | "Run a page allowing the user to edit the given TARGET-USER-PARTITION | |
190 | record. If the argument DEFAULT-ITEM is passed, use it to select the current | |
191 | listbox item. This is used to avoid the focus to switch back to the first | |
192 | listbox entry while calling this procedure recursively." | |
193 | ||
194 | (define (numeric-size device size) | |
195 | "Parse the given SIZE on DEVICE and return it." | |
196 | (call-with-values | |
197 | (lambda () | |
198 | (unit-parse size device)) | |
199 | (lambda (value range) | |
200 | value))) | |
201 | ||
202 | (define (numeric-size-range device size) | |
203 | "Parse the given SIZE on DEVICE and return the associated RANGE." | |
204 | (call-with-values | |
205 | (lambda () | |
206 | (unit-parse size device)) | |
207 | (lambda (value range) | |
208 | range))) | |
209 | ||
210 | (define* (fill-user-partition-geom user-part | |
211 | #:key | |
212 | device (size #f) start end) | |
213 | "Return the given USER-PART with the START, END and SIZE fields set to the | |
214 | eponym arguments. Use UNIT-FORMAT-CUSTOM to format START and END arguments as | |
215 | sectors on DEVICE." | |
216 | (user-partition | |
217 | (inherit user-part) | |
218 | (size size) | |
219 | (start (unit-format-custom device start UNIT-SECTOR)) | |
220 | (end (unit-format-custom device end UNIT-SECTOR)))) | |
221 | ||
222 | (define (apply-user-partition-changes user-part) | |
223 | "Set the name, file-system type and boot flag on the partition specified | |
224 | by USER-PART, if it is applicable for the partition type." | |
225 | (let* ((partition (user-partition-parted-object user-part)) | |
226 | (disk (partition-disk partition)) | |
227 | (disk-type (disk-disk-type disk)) | |
228 | (device (disk-device disk)) | |
229 | (has-name? (disk-type-check-feature | |
230 | disk-type | |
231 | DISK-TYPE-FEATURE-PARTITION-NAME)) | |
232 | (name (user-partition-name user-part)) | |
233 | (fs-type (filesystem-type-get | |
234 | (user-fs-type-name | |
235 | (user-partition-fs-type user-part)))) | |
236 | (bootable? (user-partition-bootable? user-part)) | |
237 | (esp? (user-partition-esp? user-part)) | |
238 | (flag-bootable? | |
239 | (partition-is-flag-available? partition PARTITION-FLAG-BOOT)) | |
240 | (flag-esp? | |
241 | (partition-is-flag-available? partition PARTITION-FLAG-ESP))) | |
242 | (when (and has-name? name) | |
243 | (partition-set-name partition name)) | |
244 | (partition-set-system partition fs-type) | |
245 | (when flag-bootable? | |
246 | (partition-set-flag partition | |
247 | PARTITION-FLAG-BOOT | |
248 | (if bootable? 1 0))) | |
249 | (when flag-esp? | |
250 | (partition-set-flag partition | |
251 | PARTITION-FLAG-ESP | |
252 | (if esp? 1 0))) | |
253 | #t)) | |
254 | ||
255 | (define (listbox-action listbox-item) | |
256 | (let* ((item (car listbox-item)) | |
257 | (partition (user-partition-parted-object | |
258 | target-user-partition)) | |
259 | (disk (partition-disk partition)) | |
260 | (device (disk-device disk))) | |
261 | (list | |
262 | item | |
263 | (case item | |
264 | ((name) | |
265 | (let* ((old-name (user-partition-name target-user-partition)) | |
266 | (name | |
267 | (run-input-page (G_ "Please enter the partition gpt name.") | |
268 | (G_ "Partition name") | |
269 | #:default-text old-name))) | |
270 | (user-partition | |
271 | (inherit target-user-partition) | |
272 | (name name)))) | |
273 | ((type) | |
274 | (let ((new-type (run-type-page partition))) | |
275 | (user-partition | |
276 | (inherit target-user-partition) | |
277 | (type new-type)))) | |
278 | ((bootable) | |
279 | (user-partition | |
280 | (inherit target-user-partition) | |
281 | (bootable? (not (user-partition-bootable? | |
282 | target-user-partition))))) | |
283 | ((esp?) | |
284 | (let ((new-esp? (not (user-partition-esp? | |
285 | target-user-partition)))) | |
286 | (user-partition | |
287 | (inherit target-user-partition) | |
288 | (esp? new-esp?) | |
289 | (mount-point (if new-esp? | |
290 | (default-esp-mount-point) | |
291 | ""))))) | |
bf304dbc MO |
292 | ((crypt-label) |
293 | (let* ((label (user-partition-crypt-label | |
294 | target-user-partition)) | |
295 | (new-label | |
296 | (and (not label) | |
297 | (run-input-page | |
298 | (G_ "Please enter the encrypted label") | |
299 | (G_ "Encryption label"))))) | |
300 | (user-partition | |
301 | (inherit target-user-partition) | |
85caf5f3 | 302 | (need-formatting? #t) |
bf304dbc | 303 | (crypt-label new-label)))) |
85caf5f3 | 304 | ((need-formatting?) |
69a934f2 MO |
305 | (user-partition |
306 | (inherit target-user-partition) | |
85caf5f3 LC |
307 | (need-formatting? |
308 | (not (user-partition-need-formatting? | |
69a934f2 MO |
309 | target-user-partition))))) |
310 | ((size) | |
311 | (let* ((old-size (user-partition-size target-user-partition)) | |
312 | (max-size-value (partition-length partition)) | |
313 | (max-size (unit-format device max-size-value)) | |
314 | (start (partition-start partition)) | |
315 | (size (run-input-page | |
316 | (format #f (G_ "Please enter the size of the partition.\ | |
317 | The maximum size is ~a.") max-size) | |
318 | (G_ "Partition size") | |
319 | #:default-text (or old-size max-size))) | |
320 | (size-percentage (read-percentage size)) | |
321 | (size-value (if size-percentage | |
322 | (nearest-exact-integer | |
323 | (/ (* max-size-value size-percentage) | |
324 | 100)) | |
325 | (numeric-size device size))) | |
326 | (end (and size-value | |
327 | (+ start size-value))) | |
328 | (size-range (numeric-size-range device size)) | |
329 | (size-range-ok? (and size-range | |
330 | (< (+ start | |
331 | (geometry-start size-range)) | |
332 | (partition-end partition))))) | |
333 | (cond | |
334 | ((and size-percentage (> size-percentage 100)) | |
335 | (run-error-page | |
336 | (G_ "The percentage can not be superior to 100.") | |
337 | (G_ "Size error")) | |
338 | target-user-partition) | |
339 | ((not size-value) | |
340 | (run-error-page | |
341 | (G_ "The requested size is incorrectly formatted, or too large.") | |
342 | (G_ "Size error")) | |
343 | target-user-partition) | |
344 | ((not (or size-percentage size-range-ok?)) | |
345 | (run-error-page | |
346 | (G_ "The request size is superior to the maximum size.") | |
347 | (G_ "Size error")) | |
348 | target-user-partition) | |
349 | (else | |
350 | (fill-user-partition-geom target-user-partition | |
351 | #:device device | |
352 | #:size size | |
353 | #:start start | |
354 | #:end end))))) | |
355 | ((fs-type) | |
356 | (let ((fs-type (run-fs-type-page))) | |
357 | (user-partition | |
358 | (inherit target-user-partition) | |
359 | (fs-type fs-type)))) | |
360 | ((mount-point) | |
361 | (let* ((old-mount (or (user-partition-mount-point | |
362 | target-user-partition) | |
363 | "")) | |
364 | (mount | |
365 | (run-input-page | |
366 | (G_ "Please enter the desired mounting point for this \ | |
367 | partition. Leave this field empty if you don't want to set a mounting point.") | |
368 | (G_ "Mounting point") | |
369 | #:default-text old-mount | |
370 | #:allow-empty-input? #t))) | |
371 | (user-partition | |
372 | (inherit target-user-partition) | |
373 | (mount-point (and (not (string=? mount "")) | |
374 | mount))))))))) | |
375 | ||
376 | (define (button-action) | |
377 | (let* ((partition (user-partition-parted-object | |
378 | target-user-partition)) | |
379 | (prev-part (partition-prev partition)) | |
380 | (disk (partition-disk partition)) | |
381 | (device (disk-device disk)) | |
382 | (creation? (freespace-partition? partition)) | |
383 | (start (partition-start partition)) | |
384 | (end (partition-end partition)) | |
385 | (new-user-partition | |
386 | (if (user-partition-start target-user-partition) | |
387 | target-user-partition | |
388 | (fill-user-partition-geom target-user-partition | |
389 | #:device device | |
390 | #:start start | |
391 | #:end end)))) | |
392 | ;; It the backend PARTITION has free-space type, it means we are | |
393 | ;; creating a new partition, otherwise, we are editing an already | |
394 | ;; existing PARTITION. | |
395 | (if creation? | |
396 | (let* ((ok-create-partition? | |
397 | (inform-can-create-partition? new-user-partition)) | |
398 | (new-partition | |
399 | (and ok-create-partition? | |
400 | (mkpart disk | |
401 | new-user-partition | |
402 | #:previous-partition prev-part)))) | |
403 | (and new-partition | |
404 | (user-partition | |
405 | (inherit new-user-partition) | |
85caf5f3 | 406 | (need-formatting? #t) |
44b2d31c MO |
407 | (file-name (partition-get-path new-partition)) |
408 | (disk-file-name (device-path device)) | |
69a934f2 MO |
409 | (parted-object new-partition)))) |
410 | (and (apply-user-partition-changes new-user-partition) | |
411 | new-user-partition)))) | |
412 | ||
413 | (let* ((items (user-partition-description target-user-partition)) | |
414 | (partition (user-partition-parted-object | |
415 | target-user-partition)) | |
416 | (disk (partition-disk partition)) | |
417 | (device (disk-device disk)) | |
44b2d31c | 418 | (file-name (device-path device)) |
69a934f2 MO |
419 | (number-str (partition-print-number partition)) |
420 | (type (user-partition-type target-user-partition)) | |
421 | (type-str (symbol->string type)) | |
422 | (start (unit-format device (partition-start partition))) | |
423 | (creation? (freespace-partition? partition)) | |
424 | (default-item (and default-item | |
425 | (find (lambda (item) | |
426 | (eq? (car item) default-item)) | |
427 | items))) | |
428 | (result | |
429 | (run-listbox-selection-page | |
430 | #:info-text | |
431 | (if creation? | |
7dbdbbfd LC |
432 | (format #f (G_ "Creating ~a partition starting at ~a of ~a.") |
433 | type-str start file-name) | |
434 | (format #f (G_ "You are currently editing partition ~a.") | |
435 | number-str)) | |
69a934f2 MO |
436 | #:title (if creation? |
437 | (G_ "Partition creation") | |
438 | (G_ "Partition edit")) | |
439 | #:listbox-items items | |
440 | #:listbox-item->text cdr | |
441 | #:sort-listbox-items? #f | |
442 | #:listbox-default-item default-item | |
ebb36dec | 443 | #:button-text (G_ "OK") |
69a934f2 MO |
444 | #:listbox-callback-procedure listbox-action |
445 | #:button-callback-procedure button-action))) | |
446 | (match result | |
447 | ((item new-user-partition) | |
448 | (run-partition-page new-user-partition | |
449 | #:default-item item)) | |
450 | (else result)))) | |
451 | ||
452 | (define* (run-disk-page disks | |
ee4004b3 MO |
453 | #:optional (user-partitions '()) |
454 | #:key (guided? #f)) | |
69a934f2 MO |
455 | "Run a page allowing to edit the partition tables of the given DISKS. If |
456 | specified, USER-PARTITIONS is a list of <user-partition> records associated to | |
457 | the partitions on DISKS." | |
458 | ||
459 | (define (other-logical-partitions? partitions) | |
460 | "Return #t if at least one of the partition in PARTITIONS list is a | |
461 | logical partition, return #f otherwise." | |
462 | (any logical-partition? partitions)) | |
463 | ||
464 | (define (other-non-logical-partitions? partitions) | |
465 | "Return #t is at least one of the partitions in PARTITIONS list is not a | |
466 | logical partition, return #f otherwise." | |
467 | (let ((non-logical-partitions | |
468 | (remove logical-partition? partitions))) | |
469 | (or (any normal-partition? non-logical-partitions) | |
470 | (any freespace-partition? non-logical-partitions)))) | |
471 | ||
472 | (define (add-tree-symbols partitions descriptions) | |
473 | "Concatenate tree symbols to the given DESCRIPTIONS list and return | |
474 | it. The PARTITIONS list is the list of partitions described in | |
475 | DESCRIPTIONS. The tree symbols are used to indicate the partition's disk and | |
476 | for logical partitions, the extended partition which includes them." | |
477 | (match descriptions | |
478 | (() '()) | |
479 | ((description . rest-descriptions) | |
480 | (match partitions | |
481 | ((partition . rest-partitions) | |
482 | (if (null? rest-descriptions) | |
483 | (list (if (logical-partition? partition) | |
484 | (string-append " ┗━ " description) | |
485 | (string-append "┗━ " description))) | |
486 | (cons (cond | |
487 | ((extended-partition? partition) | |
488 | (if (other-non-logical-partitions? rest-partitions) | |
489 | (string-append "┣┳ " description) | |
490 | (string-append "┗┳ " description))) | |
491 | ((logical-partition? partition) | |
492 | (if (other-logical-partitions? rest-partitions) | |
493 | (if (other-non-logical-partitions? rest-partitions) | |
494 | (string-append "┃┣━ " description) | |
495 | (string-append " ┣━ " description)) | |
496 | (if (other-non-logical-partitions? rest-partitions) | |
497 | (string-append "┃┗━ " description) | |
498 | (string-append " ┗━ " description)))) | |
499 | (else | |
500 | (string-append "┣━ " description))) | |
501 | (add-tree-symbols rest-partitions | |
502 | rest-descriptions)))))))) | |
503 | ||
504 | (define (skip-item? item) | |
505 | (eq? (car item) 'skip)) | |
506 | ||
507 | (define (disk-items) | |
508 | "Return the list of strings describing DISKS." | |
509 | (let loop ((disks disks)) | |
510 | (match disks | |
511 | (() '()) | |
512 | ((disk . rest) | |
513 | (let* ((device (disk-device disk)) | |
514 | (partitions (disk-partitions disk)) | |
515 | (partitions* | |
516 | (filter-map | |
517 | (lambda (partition) | |
518 | (and (not (metadata-partition? partition)) | |
519 | (not (small-freespace-partition? device | |
520 | partition)) | |
521 | partition)) | |
522 | partitions)) | |
523 | (descriptions (add-tree-symbols | |
524 | partitions* | |
525 | (partitions-descriptions partitions* | |
526 | user-partitions))) | |
527 | (partition-items (map cons partitions* descriptions))) | |
528 | (append | |
529 | `((,disk . ,(device-description device disk)) | |
530 | ,@partition-items | |
531 | ,@(if (null? rest) | |
532 | '() | |
533 | '((skip . "")))) | |
534 | (loop rest))))))) | |
535 | ||
536 | (define (remove-user-partition-by-partition user-partitions partition) | |
537 | "Return the USER-PARTITIONS list with the record with the given PARTITION | |
538 | object removed. If PARTITION is an extended partition, also remove all logical | |
539 | partitions from USER-PARTITIONS." | |
540 | (remove (lambda (p) | |
541 | (let ((cur-partition (user-partition-parted-object p))) | |
542 | (or (equal? cur-partition partition) | |
543 | (and (extended-partition? partition) | |
544 | (logical-partition? cur-partition))))) | |
545 | user-partitions)) | |
546 | ||
547 | (define (remove-user-partition-by-disk user-partitions disk) | |
548 | "Return the USER-PARTITIONS list with the <user-partition> records located | |
549 | on given DISK removed." | |
550 | (remove (lambda (p) | |
551 | (let* ((partition (user-partition-parted-object p)) | |
552 | (cur-disk (partition-disk partition))) | |
553 | (equal? cur-disk disk))) | |
554 | user-partitions)) | |
555 | ||
556 | (define (update-user-partitions user-partitions new-user-partition) | |
557 | "Update or insert NEW-USER-PARTITION record in USER-PARTITIONS list | |
558 | depending if one of the <user-partition> record in USER-PARTITIONS has the | |
559 | same PARTITION object as NEW-USER-PARTITION." | |
560 | (let* ((partition (user-partition-parted-object new-user-partition)) | |
561 | (user-partitions* | |
562 | (remove-user-partition-by-partition user-partitions | |
563 | partition))) | |
564 | (cons new-user-partition user-partitions*))) | |
565 | ||
566 | (define (button-ok-action) | |
567 | "Commit the modifications to all DISKS and return #t." | |
568 | (for-each (lambda (disk) | |
569 | (disk-commit disk)) | |
570 | disks) | |
571 | #t) | |
572 | ||
573 | (define (listbox-action listbox-item) | |
574 | "A disk or a partition has been selected. If it's a disk, ask for a label | |
575 | to create a new partition table. If it is a partition, propose the user to | |
576 | edit it." | |
577 | (let ((item (car listbox-item))) | |
578 | (cond | |
579 | ((disk? item) | |
cbeb2702 | 580 | (let ((label (run-label-page (G_ "Back") (const #f)))) |
69a934f2 MO |
581 | (if label |
582 | (let* ((device (disk-device item)) | |
583 | (new-disk (mklabel device label)) | |
584 | (commit-new-disk (disk-commit new-disk)) | |
585 | (other-disks (remove (lambda (disk) | |
586 | (equal? disk item)) | |
587 | disks)) | |
588 | (new-user-partitions | |
589 | (remove-user-partition-by-disk user-partitions item))) | |
590 | (disk-destroy item) | |
591 | `((disks . ,(cons new-disk other-disks)) | |
592 | (user-partitions . ,new-user-partitions))) | |
593 | `((disks . ,disks) | |
594 | (user-partitions . ,user-partitions))))) | |
595 | ((partition? item) | |
596 | (let* ((partition item) | |
597 | (disk (partition-disk partition)) | |
598 | (device (disk-device disk)) | |
599 | (existing-user-partition | |
600 | (find-user-partition-by-parted-object user-partitions | |
601 | partition)) | |
602 | (edit-user-partition | |
603 | (or existing-user-partition | |
604 | (partition->user-partition partition)))) | |
605 | `((disks . ,disks) | |
606 | (user-partitions . ,user-partitions) | |
607 | (edit-user-partition . ,edit-user-partition))))))) | |
608 | ||
609 | (define (hotkey-action key listbox-item) | |
610 | "The DELETE key has been pressed on a disk or a partition item." | |
611 | (let ((item (car listbox-item)) | |
612 | (default-result | |
613 | `((disks . ,disks) | |
614 | (user-partitions . ,user-partitions)))) | |
615 | (cond | |
616 | ((disk? item) | |
617 | (let* ((device (disk-device item)) | |
44b2d31c | 618 | (file-name (device-path device)) |
69a934f2 MO |
619 | (info-text |
620 | (format #f (G_ "Are you sure you want to delete everything on disk ~a?") | |
44b2d31c | 621 | file-name)) |
69a934f2 | 622 | (result (choice-window (G_ "Delete disk") |
ebb36dec | 623 | (G_ "OK") |
7d812901 | 624 | (G_ "Exit") |
69a934f2 MO |
625 | info-text))) |
626 | (case result | |
627 | ((1) | |
628 | (disk-delete-all item) | |
629 | `((disks . ,disks) | |
630 | (user-partitions | |
631 | . ,(remove-user-partition-by-disk user-partitions item)))) | |
632 | (else | |
633 | default-result)))) | |
634 | ((partition? item) | |
635 | (if (freespace-partition? item) | |
636 | (run-error-page (G_ "You cannot delete a free space area.") | |
637 | (G_ "Delete partition")) | |
638 | (let* ((disk (partition-disk item)) | |
639 | (number-str (partition-print-number item)) | |
640 | (info-text | |
641 | (format #f (G_ "Are you sure you want to delete partition ~a?") | |
642 | number-str)) | |
643 | (result (choice-window (G_ "Delete partition") | |
ebb36dec | 644 | (G_ "OK") |
7d812901 | 645 | (G_ "Exit") |
69a934f2 MO |
646 | info-text))) |
647 | (case result | |
648 | ((1) | |
649 | (let ((new-user-partitions | |
650 | (remove-user-partition-by-partition user-partitions | |
651 | item))) | |
652 | (disk-delete-partition disk item) | |
653 | `((disks . ,disks) | |
654 | (user-partitions . ,new-user-partitions)))) | |
655 | (else | |
656 | default-result)))))))) | |
657 | ||
ee4004b3 | 658 | (let* ((info-text (G_ "You can change a disk's partition table by \ |
69a934f2 MO |
659 | selecting it and pressing ENTER. You can also edit a partition by selecting it \ |
660 | and pressing ENTER, or remove it by pressing DELETE. To create a new \ | |
661 | partition, select a free space area and press ENTER. | |
662 | ||
ee4004b3 | 663 | At least one partition must have its mounting point set to '/'.")) |
71cd8a58 | 664 | (guided-info-text (format #f (G_ "This is the proposed \ |
5737ba84 | 665 | partitioning. It is still possible to edit it or to go back to install menu \ |
71cd8a58 | 666 | by pressing the Exit button.~%~%"))) |
ee4004b3 MO |
667 | (result |
668 | (run-listbox-selection-page | |
669 | #:info-text (if guided? | |
670 | (string-append guided-info-text info-text) | |
671 | info-text) | |
69a934f2 | 672 | |
ee4004b3 MO |
673 | #:title (if guided? |
674 | (G_ "Guided partitioning") | |
675 | (G_ "Manual partitioning")) | |
ed5a5d38 LC |
676 | #:info-textbox-width 76 ;we need a lot of room for INFO-TEXT |
677 | #:listbox-height 12 | |
69a934f2 MO |
678 | #:listbox-items (disk-items) |
679 | #:listbox-item->text cdr | |
680 | #:sort-listbox-items? #f | |
681 | #:skip-item-procedure? skip-item? | |
682 | #:allow-delete? #t | |
ebb36dec | 683 | #:button-text (G_ "OK") |
69a934f2 | 684 | #:button-callback-procedure button-ok-action |
7d812901 MO |
685 | #:button2-text (G_ "Exit") |
686 | #:button2-callback-procedure button-exit-action | |
69a934f2 MO |
687 | #:listbox-callback-procedure listbox-action |
688 | #:hotkey-callback-procedure hotkey-action))) | |
689 | (if (eq? result #t) | |
690 | (let ((user-partitions-ok? | |
691 | (guard | |
692 | (c ((no-root-mount-point? c) | |
693 | (run-error-page | |
d700d131 | 694 | (G_ "No root mount point found.") |
69a934f2 MO |
695 | (G_ "Missing mount point")) |
696 | #f)) | |
697 | (check-user-partitions user-partitions)))) | |
698 | (if user-partitions-ok? | |
699 | (begin | |
700 | (for-each (cut disk-destroy <>) disks) | |
701 | user-partitions) | |
ee4004b3 MO |
702 | (run-disk-page disks user-partitions |
703 | #:guided? guided?))) | |
69a934f2 MO |
704 | (let* ((result-disks (assoc-ref result 'disks)) |
705 | (result-user-partitions (assoc-ref result | |
706 | 'user-partitions)) | |
707 | (edit-user-partition (assoc-ref result | |
708 | 'edit-user-partition)) | |
709 | (can-create-partition? | |
710 | (and edit-user-partition | |
711 | (inform-can-create-partition? edit-user-partition))) | |
712 | (new-user-partition (and edit-user-partition | |
713 | can-create-partition? | |
714 | (run-partition-page | |
715 | edit-user-partition))) | |
716 | (new-user-partitions | |
717 | (if new-user-partition | |
718 | (update-user-partitions result-user-partitions | |
719 | new-user-partition) | |
720 | result-user-partitions))) | |
ee4004b3 MO |
721 | (run-disk-page result-disks new-user-partitions |
722 | #:guided? guided?))))) | |
69a934f2 MO |
723 | |
724 | (define (run-partioning-page) | |
725 | "Run a page asking the user for a partitioning method." | |
726 | (define (run-page devices) | |
727 | (let* ((items | |
7dbdbbfd LC |
728 | `((entire . ,(G_ "Guided - using the entire disk")) |
729 | (entire-encrypted . ,(G_ "Guided - using the entire disk with encryption")) | |
730 | (manual . ,(G_ "Manual")))) | |
69a934f2 MO |
731 | (result (run-listbox-selection-page |
732 | #:info-text (G_ "Please select a partitioning method.") | |
733 | #:title (G_ "Partitioning method") | |
d1e5f758 | 734 | #:listbox-height (+ (length items) 2) |
69a934f2 MO |
735 | #:listbox-items items |
736 | #:listbox-item->text cdr | |
1d8da896 | 737 | #:sort-listbox-items? #f |
7d812901 MO |
738 | #:button-text (G_ "Exit") |
739 | #:button-callback-procedure button-exit-action)) | |
69a934f2 | 740 | (method (car result))) |
bf304dbc MO |
741 | (cond |
742 | ((or (eq? method 'entire) | |
44b2d31c | 743 | (eq? method 'entire-encrypted)) |
69a934f2 MO |
744 | (let* ((device (run-device-page devices)) |
745 | (disk-type (disk-probe device)) | |
746 | (disk (if disk-type | |
747 | (disk-new device) | |
748 | (let* ((label (run-label-page | |
cbeb2702 | 749 | (G_ "Exit") |
7d812901 | 750 | button-exit-action)) |
69a934f2 MO |
751 | (disk (mklabel device label))) |
752 | (disk-commit disk) | |
753 | disk))) | |
754 | (scheme (symbol-append method '- (run-scheme-page))) | |
d68de958 | 755 | (user-partitions (auto-partition! disk #:scheme scheme))) |
ee4004b3 MO |
756 | (run-disk-page (list disk) user-partitions |
757 | #:guided? #t))) | |
bf304dbc | 758 | ((eq? method 'manual) |
8cca59ee | 759 | (let* ((disks (filter-map disk-new devices)) |
69a934f2 MO |
760 | (user-partitions (append-map |
761 | create-special-user-partitions | |
762 | (map disk-partitions disks))) | |
763 | (result-user-partitions (run-disk-page disks | |
764 | user-partitions))) | |
765 | result-user-partitions))))) | |
766 | ||
767 | (init-parted) | |
768 | (let* ((non-install-devices (non-install-devices)) | |
769 | (user-partitions (run-page non-install-devices)) | |
bf304dbc MO |
770 | (user-partitions-with-pass (prompt-luks-passwords |
771 | user-partitions)) | |
85caf5f3 LC |
772 | (form (draw-formatting-page))) |
773 | ;; Make sure the disks are not in use before proceeding to formatting. | |
69a934f2 | 774 | (free-parted non-install-devices) |
bf304dbc | 775 | (format-user-partitions user-partitions-with-pass) |
69a934f2 MO |
776 | (destroy-form-and-pop form) |
777 | user-partitions)) |