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