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