Commit | Line | Data |
---|---|---|
69a934f2 | 1 | ;;; GNU Guix --- Functional package management for GNU |
f297c213 | 2 | ;;; Copyright © 2018, 2019 Mathieu Othacehe <m.othacehe@gmail.com> |
ff9522fb | 3 | ;;; Copyright © 2019, 2020, 2022 Ludovic Courtès <ludo@gnu.org> |
8fec416c | 4 | ;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr> |
4989f6ac | 5 | ;;; Copyright © 2022 Josselin Poiret <dev@jpoiret.xyz> |
69a934f2 MO |
6 | ;;; |
7 | ;;; This file is part of GNU Guix. | |
8 | ;;; | |
9 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
10 | ;;; under the terms of the GNU General Public License as published by | |
11 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
12 | ;;; your option) any later version. | |
13 | ;;; | |
14 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
15 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
16 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
17 | ;;; GNU General Public License for more details. | |
18 | ;;; | |
19 | ;;; You should have received a copy of the GNU General Public License | |
20 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
21 | ||
22 | (define-module (gnu installer parted) | |
23 | #:use-module (gnu installer steps) | |
24 | #:use-module (gnu installer utils) | |
25 | #:use-module (gnu installer newt page) | |
26 | #:use-module (gnu system uuid) | |
27 | #:use-module ((gnu build file-systems) | |
e12be802 MO |
28 | #:select (canonicalize-device-spec |
29 | find-partition-by-label | |
b90504cd | 30 | find-partition-by-uuid |
154a4e04 | 31 | read-partition-uuid |
59e8f3c3 | 32 | read-luks-partition-uuid)) |
e12be802 MO |
33 | #:use-module ((gnu build linux-boot) |
34 | #:select (linux-command-line | |
35 | find-long-option)) | |
50247be5 LC |
36 | #:use-module ((gnu build linux-modules) |
37 | #:select (missing-modules)) | |
38 | #:use-module ((gnu system linux-initrd) | |
39 | #:select (%base-initrd-modules)) | |
69a934f2 MO |
40 | #:use-module (guix build syscalls) |
41 | #:use-module (guix build utils) | |
ff9522fb | 42 | #:use-module (guix read-print) |
69a934f2 | 43 | #:use-module (guix records) |
bf304dbc | 44 | #:use-module (guix utils) |
69a934f2 MO |
45 | #:use-module (guix i18n) |
46 | #:use-module (parted) | |
8f71305e | 47 | #:use-module (ice-9 format) |
69a934f2 | 48 | #:use-module (ice-9 match) |
f297c213 | 49 | #:use-module (ice-9 regex) |
bf304dbc | 50 | #:use-module (rnrs io ports) |
69a934f2 | 51 | #:use-module (srfi srfi-1) |
3d3ffb30 | 52 | #:use-module (srfi srfi-19) |
69a934f2 MO |
53 | #:use-module (srfi srfi-26) |
54 | #:use-module (srfi srfi-34) | |
55 | #:use-module (srfi srfi-35) | |
56 | #:export (<user-partition> | |
57 | user-partition | |
58 | make-user-partition | |
59 | user-partition? | |
60 | user-partition-name | |
61 | user-partition-type | |
44b2d31c MO |
62 | user-partition-file-name |
63 | user-partition-disk-file-name | |
bf304dbc MO |
64 | user-partition-crypt-label |
65 | user-partition-crypt-password | |
69a934f2 MO |
66 | user-partition-fs-type |
67 | user-partition-bootable? | |
68 | user-partition-esp? | |
69 | user-partition-bios-grub? | |
70 | user-partition-size | |
71 | user-partition-start | |
72 | user-partition-end | |
73 | user-partition-mount-point | |
85caf5f3 | 74 | user-partition-need-formatting? |
69a934f2 MO |
75 | user-partition-parted-object |
76 | ||
77 | find-esp-partition | |
69a934f2 | 78 | small-freespace-partition? |
69a934f2 MO |
79 | esp-partition? |
80 | boot-partition? | |
af7a615c | 81 | efi-installation? |
69a934f2 MO |
82 | default-esp-mount-point |
83 | ||
69a934f2 | 84 | force-device-sync |
c6910baf | 85 | eligible-devices |
69a934f2 MO |
86 | partition-user-type |
87 | user-fs-type-name | |
88 | partition-filesystem-user-type | |
89 | partition-get-flags | |
90 | partition->user-partition | |
91 | create-special-user-partitions | |
92 | find-user-partition-by-parted-object | |
93 | ||
94 | device-description | |
95 | partition-end-formatted | |
96 | partition-print-number | |
97 | partition-description | |
98 | partitions-descriptions | |
99 | user-partition-description | |
100 | ||
101 | &max-primary-exceeded | |
102 | max-primary-exceeded? | |
103 | &extended-creation-error | |
104 | extended-creation-error? | |
105 | &logical-creation-error | |
106 | logical-creation-error? | |
107 | ||
108 | can-create-partition? | |
109 | mklabel | |
110 | mkpart | |
111 | rmpart | |
112 | ||
15374648 | 113 | auto-partition! |
69a934f2 MO |
114 | |
115 | &no-root-mount-point | |
116 | no-root-mount-point? | |
f5d9d6ec MO |
117 | &cannot-read-uuid |
118 | cannot-read-uuid? | |
119 | cannot-read-uuid-partition | |
69a934f2 MO |
120 | |
121 | check-user-partitions | |
44b2d31c | 122 | set-user-partitions-file-name |
69a934f2 MO |
123 | format-user-partitions |
124 | mount-user-partitions | |
125 | umount-user-partitions | |
126 | with-mounted-partitions | |
127 | user-partitions->file-systems | |
128 | user-partitions->configuration | |
129 | ||
130 | init-parted | |
131 | free-parted)) | |
132 | ||
133 | \f | |
134 | ;;; | |
135 | ;;; Partition record. | |
136 | ;;; | |
137 | ||
138 | (define-record-type* <user-partition> | |
139 | user-partition make-user-partition | |
140 | user-partition? | |
141 | (name user-partition-name ;string | |
142 | (default #f)) | |
143 | (type user-partition-type | |
144 | (default 'normal)) ; 'normal | 'logical | 'extended | |
44b2d31c | 145 | (file-name user-partition-file-name |
69a934f2 | 146 | (default #f)) |
44b2d31c | 147 | (disk-file-name user-partition-disk-file-name |
69a934f2 | 148 | (default #f)) |
bf304dbc MO |
149 | (crypt-label user-partition-crypt-label |
150 | (default #f)) | |
4814ec28 | 151 | (crypt-password user-partition-crypt-password ; <secret> |
bf304dbc | 152 | (default #f)) |
69a934f2 MO |
153 | (fs-type user-partition-fs-type |
154 | (default 'ext4)) | |
155 | (bootable? user-partition-bootable? | |
156 | (default #f)) | |
157 | (esp? user-partition-esp? | |
158 | (default #f)) | |
159 | (bios-grub? user-partition-bios-grub? | |
160 | (default #f)) | |
161 | (size user-partition-size | |
162 | (default #f)) | |
163 | (start user-partition-start ;start as string (e.g. '11MB') | |
164 | (default #f)) | |
165 | (end user-partition-end ;same as start | |
166 | (default #f)) | |
167 | (mount-point user-partition-mount-point ;string | |
168 | (default #f)) | |
85caf5f3 | 169 | (need-formatting? user-partition-need-formatting? ; boolean |
69a934f2 MO |
170 | (default #f)) |
171 | (parted-object user-partition-parted-object ; <partition> from parted | |
172 | (default #f))) | |
173 | ||
174 | \f | |
175 | ;; | |
176 | ;; Utilities. | |
177 | ;; | |
178 | ||
179 | (define (find-esp-partition partitions) | |
180 | "Find and return the ESP partition among PARTITIONS." | |
181 | (find esp-partition? partitions)) | |
182 | ||
69a934f2 MO |
183 | (define* (small-freespace-partition? device |
184 | partition | |
185 | #:key (max-size MEBIBYTE-SIZE)) | |
186 | "Return #t is PARTITION is a free-space partition with less a size strictly | |
187 | inferior to MAX-SIZE, #f otherwise." | |
188 | (let ((size (partition-length partition)) | |
189 | (max-sector-size (/ max-size | |
190 | (device-sector-size device)))) | |
191 | (< size max-sector-size))) | |
192 | ||
69a934f2 MO |
193 | (define (partition-user-type partition) |
194 | "Return the type of PARTITION, to be stored in the TYPE field of | |
195 | <user-partition> record. It can be 'normal, 'extended or 'logical." | |
196 | (cond ((normal-partition? partition) | |
197 | 'normal) | |
198 | ((extended-partition? partition) | |
199 | 'extended) | |
200 | ((logical-partition? partition) | |
201 | 'logical) | |
202 | (else #f))) | |
203 | ||
204 | (define (esp-partition? partition) | |
205 | "Return #t if partition has the ESP flag, return #f otherwise." | |
206 | (let* ((disk (partition-disk partition)) | |
af7a615c | 207 | (disk-type (disk-disk-type disk))) |
69a934f2 | 208 | (and (data-partition? partition) |
69a934f2 MO |
209 | (partition-is-flag-available? partition PARTITION-FLAG-ESP) |
210 | (partition-get-flag partition PARTITION-FLAG-ESP)))) | |
211 | ||
212 | (define (boot-partition? partition) | |
213 | "Return #t if partition has the boot flag, return #f otherwise." | |
214 | (and (data-partition? partition) | |
215 | (partition-is-flag-available? partition PARTITION-FLAG-BOOT) | |
216 | (partition-get-flag partition PARTITION-FLAG-BOOT))) | |
217 | ||
218 | ||
219 | ;; The default mount point for ESP partitions. | |
220 | (define default-esp-mount-point | |
221 | (make-parameter "/boot/efi")) | |
222 | ||
223 | (define (efi-installation?) | |
224 | "Return #t if an EFI installation should be performed, #f otherwise." | |
225 | (file-exists? "/sys/firmware/efi")) | |
226 | ||
227 | (define (user-fs-type-name fs-type) | |
228 | "Return the name of FS-TYPE as specified by libparted." | |
229 | (case fs-type | |
230 | ((ext4) "ext4") | |
231 | ((btrfs) "btrfs") | |
628d09ae | 232 | ((fat16) "fat16") |
69a934f2 | 233 | ((fat32) "fat32") |
218a67df MO |
234 | ((jfs) "jfs") |
235 | ((ntfs) "ntfs") | |
f34b8087 | 236 | ((xfs) "xfs") |
69a934f2 MO |
237 | ((swap) "linux-swap"))) |
238 | ||
239 | (define (user-fs-type->mount-type fs-type) | |
240 | "Return the mount type of FS-TYPE." | |
241 | (case fs-type | |
242 | ((ext4) "ext4") | |
243 | ((btrfs) "btrfs") | |
245cab2a | 244 | ((fat16) "vfat") |
8fec416c | 245 | ((fat32) "vfat") |
218a67df | 246 | ((jfs) "jfs") |
f34b8087 TGR |
247 | ((ntfs) "ntfs") |
248 | ((xfs) "xfs"))) | |
69a934f2 MO |
249 | |
250 | (define (partition-filesystem-user-type partition) | |
251 | "Return the filesystem type of PARTITION, to be stored in the FS-TYPE field | |
252 | of <user-partition> record." | |
253 | (let ((fs-type (partition-fs-type partition))) | |
254 | (and fs-type | |
255 | (let ((name (filesystem-type-name fs-type))) | |
256 | (cond | |
257 | ((string=? name "ext4") 'ext4) | |
258 | ((string=? name "btrfs") 'btrfs) | |
628d09ae | 259 | ((string=? name "fat16") 'fat16) |
69a934f2 | 260 | ((string=? name "fat32") 'fat32) |
8fec416c | 261 | ((string=? name "jfs") 'jfs) |
218a67df | 262 | ((string=? name "ntfs") 'ntfs) |
f34b8087 | 263 | ((string=? name "xfs") 'xfs) |
69a934f2 MO |
264 | ((or (string=? name "swsusp") |
265 | (string=? name "linux-swap(v0)") | |
266 | (string=? name "linux-swap(v1)")) | |
267 | 'swap) | |
268 | (else | |
269 | (error (format #f "Unhandled ~a fs-type~%" name)))))))) | |
270 | ||
271 | (define (partition-get-flags partition) | |
272 | "Return the list of flags supported by the given PARTITION." | |
273 | (filter-map (lambda (flag) | |
274 | (and (partition-get-flag partition flag) | |
275 | flag)) | |
276 | (partition-flags partition))) | |
277 | ||
278 | (define (partition->user-partition partition) | |
279 | "Convert PARTITION into a <user-partition> record and return it." | |
280 | (let* ((disk (partition-disk partition)) | |
281 | (device (disk-device disk)) | |
282 | (disk-type (disk-disk-type disk)) | |
283 | (has-name? (disk-type-check-feature | |
284 | disk-type | |
285 | DISK-TYPE-FEATURE-PARTITION-NAME)) | |
286 | (name (and has-name? | |
287 | (data-partition? partition) | |
288 | (partition-get-name partition)))) | |
289 | (user-partition | |
290 | (name (and (and name | |
291 | (not (string=? name ""))) | |
292 | name)) | |
293 | (type (or (partition-user-type partition) | |
294 | 'normal)) | |
44b2d31c MO |
295 | (file-name (partition-get-path partition)) |
296 | (disk-file-name (device-path device)) | |
69a934f2 MO |
297 | (fs-type (or (partition-filesystem-user-type partition) |
298 | 'ext4)) | |
299 | (mount-point (and (esp-partition? partition) | |
300 | (default-esp-mount-point))) | |
301 | (bootable? (boot-partition? partition)) | |
302 | (esp? (esp-partition? partition)) | |
303 | (parted-object partition)))) | |
304 | ||
305 | (define (create-special-user-partitions partitions) | |
306 | "Return a list with a <user-partition> record describing the ESP partition | |
307 | found in PARTITIONS, if any." | |
308 | (filter-map (lambda (partition) | |
309 | (and (esp-partition? partition) | |
310 | (partition->user-partition partition))) | |
311 | partitions)) | |
312 | ||
313 | (define (find-user-partition-by-parted-object user-partitions | |
314 | partition) | |
315 | "Find and return the <user-partition> record in USER-PARTITIONS list which | |
316 | PARTED-OBJECT field equals PARTITION, return #f if not found." | |
317 | (find (lambda (user-partition) | |
318 | (equal? (user-partition-parted-object user-partition) | |
319 | partition)) | |
320 | user-partitions)) | |
321 | ||
322 | \f | |
323 | ;; | |
324 | ;; Devices | |
325 | ;; | |
326 | ||
44b2d31c | 327 | (define (with-delay-device-in-use? file-name) |
69a934f2 MO |
328 | "Call DEVICE-IN-USE? with a few retries, as the first re-read will often |
329 | fail. See rereadpt function in wipefs.c of util-linux for an explanation." | |
f297c213 MO |
330 | ;; Kernel always return EINVAL for BLKRRPART on loopdevices. |
331 | (and (not (string-match "/dev/loop*" file-name)) | |
3d3ffb30 | 332 | (let loop ((try 16)) |
f297c213 MO |
333 | (usleep 250000) |
334 | (let ((in-use? (device-in-use? file-name))) | |
335 | (if (and in-use? (> try 0)) | |
336 | (loop (- try 1)) | |
337 | in-use?))))) | |
69a934f2 MO |
338 | |
339 | (define* (force-device-sync device) | |
340 | "Force a flushing of the given DEVICE." | |
341 | (device-open device) | |
342 | (device-sync device) | |
343 | (device-close device)) | |
344 | ||
5697a524 MO |
345 | (define (remove-logical-devices) |
346 | "Remove all active logical devices." | |
af59e536 | 347 | ((run-command-in-installer) "dmsetup" "remove_all")) |
5697a524 | 348 | |
b90504cd JP |
349 | (define (installer-root-partition-path) |
350 | "Return the root partition path, or #f if it could not be detected." | |
e12be802 | 351 | (let* ((cmdline (linux-command-line)) |
0dc019e1 | 352 | (root (find-long-option "root" cmdline))) |
e12be802 | 353 | (and root |
b90504cd JP |
354 | (or (and (access? root F_OK) root) |
355 | (find-partition-by-label root) | |
356 | (and=> (uuid root) | |
357 | find-partition-by-uuid))))) | |
e12be802 | 358 | |
c6910baf MO |
359 | ;; Minimal installation device size. |
360 | (define %min-device-size | |
361 | (* 2 GIBIBYTE-SIZE)) ;2GiB | |
362 | ||
363 | (define (eligible-devices) | |
364 | "Return all the available devices except the install device and the devices | |
365 | which are smaller than %MIN-DEVICE-SIZE." | |
b90504cd JP |
366 | |
367 | (define the-installer-root-partition-path | |
368 | (installer-root-partition-path)) | |
369 | ||
c6910baf MO |
370 | (define (small-device? device) |
371 | (let ((length (device-length device)) | |
372 | (sector-size (device-sector-size device))) | |
373 | (and (< (* length sector-size) %min-device-size) | |
4f2fd33b JP |
374 | (installer-log-line "~a is not eligible because it is smaller than \ |
375 | ~a." | |
c6910baf MO |
376 | (device-path device) |
377 | (unit-format-custom-byte device | |
378 | %min-device-size | |
379 | UNIT-GIGABYTE))))) | |
380 | ||
b90504cd JP |
381 | ;; Read partition table of device and compare each path to the one |
382 | ;; we're booting from to determine if it is the installation | |
383 | ;; device. | |
384 | (define (installation-device? device) | |
385 | ;; When using CDROM based installation, the root partition path may be the | |
386 | ;; device path. | |
c6910baf MO |
387 | (and (or (string=? the-installer-root-partition-path |
388 | (device-path device)) | |
389 | (let ((disk (disk-new device))) | |
390 | (and disk | |
391 | (any (lambda (partition) | |
392 | (string=? the-installer-root-partition-path | |
393 | (partition-get-path partition))) | |
394 | (disk-partitions disk))))) | |
4f2fd33b JP |
395 | (installer-log-line "~a is not eligible because it is the \ |
396 | installation device." | |
c6910baf MO |
397 | (device-path device)))) |
398 | ||
399 | (remove | |
400 | (lambda (device) | |
401 | (or (installation-device? device) | |
402 | (small-device? device))) | |
403 | (devices))) | |
69a934f2 MO |
404 | |
405 | \f | |
406 | ;; | |
407 | ;; Disk and partition printing. | |
408 | ;; | |
409 | ||
410 | (define* (device-description device #:optional disk) | |
411 | "Return a string describing the given DEVICE." | |
412 | (let* ((type (device-type device)) | |
44b2d31c | 413 | (file-name (device-path device)) |
69a934f2 MO |
414 | (model (device-model device)) |
415 | (type-str (device-type->string type)) | |
416 | (disk-type (if disk | |
417 | (disk-disk-type disk) | |
418 | (disk-probe device))) | |
419 | (length (device-length device)) | |
420 | (sector-size (device-sector-size device)) | |
421 | (end (unit-format-custom-byte device | |
422 | (* length sector-size) | |
423 | UNIT-GIGABYTE))) | |
424 | (string-join | |
425 | `(,@(if (string=? model "") | |
426 | `(,type-str) | |
427 | `(,model ,(string-append "(" type-str ")"))) | |
44b2d31c | 428 | ,file-name |
69a934f2 MO |
429 | ,end |
430 | ,@(if disk-type | |
431 | `(,(disk-type-name disk-type)) | |
432 | '())) | |
433 | " "))) | |
434 | ||
435 | (define (partition-end-formatted device partition) | |
436 | "Return as a string the end of PARTITION with the relevant unit." | |
437 | (unit-format-byte | |
438 | device | |
439 | (- | |
440 | (* (+ (partition-end partition) 1) | |
441 | (device-sector-size device)) | |
442 | 1))) | |
443 | ||
444 | (define (partition-print-number partition) | |
445 | "Convert the given partition NUMBER to string." | |
446 | (let ((number (partition-number partition))) | |
447 | (number->string number))) | |
448 | ||
449 | (define (partition-description partition user-partition) | |
450 | "Return a string describing the given PARTITION, located on the DISK of | |
451 | DEVICE." | |
452 | ||
453 | (define (partition-print-type partition) | |
454 | "Return the type of PARTITION as a string." | |
455 | (if (freespace-partition? partition) | |
456 | (G_ "Free space") | |
457 | (let ((type (partition-type partition))) | |
458 | (match type | |
459 | ((type-symbol) | |
460 | (symbol->string type-symbol)))))) | |
461 | ||
462 | (define (partition-print-flags partition) | |
463 | "Return the flags of PARTITION as a string of comma separated flags." | |
464 | (string-join | |
465 | (filter-map | |
466 | (lambda (flag) | |
467 | (and (partition-get-flag partition flag) | |
468 | (partition-flag-get-name flag))) | |
469 | (partition-flags partition)) | |
470 | ",")) | |
471 | ||
472 | (define (maybe-string-pad string length) | |
473 | "Returned a string formatted by padding STRING of LENGTH characters to the | |
474 | right. If STRING is #f use an empty string." | |
bf304dbc MO |
475 | (if (and string (not (string=? string ""))) |
476 | (string-pad-right string length) | |
477 | "")) | |
69a934f2 MO |
478 | |
479 | (let* ((disk (partition-disk partition)) | |
480 | (device (disk-device disk)) | |
481 | (disk-type (disk-disk-type disk)) | |
482 | (has-name? (disk-type-check-feature | |
483 | disk-type | |
484 | DISK-TYPE-FEATURE-PARTITION-NAME)) | |
485 | (has-extended? (disk-type-check-feature | |
486 | disk-type | |
487 | DISK-TYPE-FEATURE-EXTENDED)) | |
488 | (part-type (partition-print-type partition)) | |
489 | (number (and (not (freespace-partition? partition)) | |
490 | (partition-print-number partition))) | |
491 | (name (and has-name? | |
492 | (if (freespace-partition? partition) | |
493 | (G_ "Free space") | |
494 | (partition-get-name partition)))) | |
495 | (start (unit-format device | |
496 | (partition-start partition))) | |
497 | (end (partition-end-formatted device partition)) | |
498 | (size (unit-format device (partition-length partition))) | |
499 | (fs-type (partition-fs-type partition)) | |
500 | (fs-type-name (and fs-type | |
501 | (filesystem-type-name fs-type))) | |
bf304dbc MO |
502 | (crypt-label (and user-partition |
503 | (user-partition-crypt-label user-partition))) | |
69a934f2 MO |
504 | (flags (and (not (freespace-partition? partition)) |
505 | (partition-print-flags partition))) | |
506 | (mount-point (and user-partition | |
507 | (user-partition-mount-point user-partition)))) | |
508 | `(,(or number "") | |
509 | ,@(if has-extended? | |
510 | (list part-type) | |
511 | '()) | |
512 | ,size | |
513 | ,(or fs-type-name "") | |
514 | ,(or flags "") | |
515 | ,(or mount-point "") | |
bf304dbc | 516 | ,(or crypt-label "") |
69a934f2 MO |
517 | ,(maybe-string-pad name 30)))) |
518 | ||
519 | (define (partitions-descriptions partitions user-partitions) | |
520 | "Return a list of strings describing all the partitions found on | |
521 | DEVICE. METADATA partitions are not described. The strings are padded to the | |
522 | right so that they can be displayed as a table." | |
523 | ||
524 | (define (max-length-column lists column-index) | |
525 | "Return the maximum length of the string at position COLUMN-INDEX in the | |
526 | list of string lists LISTS." | |
527 | (apply max | |
528 | (map (lambda (list) | |
529 | (string-length | |
530 | (list-ref list column-index))) | |
531 | lists))) | |
532 | ||
533 | (define (pad-descriptions descriptions) | |
534 | "Return a padded version of the list of string lists DESCRIPTIONS. The | |
535 | strings are padded to the length of the longer string in a same column, as | |
536 | determined by MAX-LENGTH-COLUMN procedure." | |
537 | (let* ((description-length (length (car descriptions))) | |
538 | (paddings (map (lambda (index) | |
539 | (max-length-column descriptions index)) | |
540 | (iota description-length)))) | |
541 | (map (lambda (description) | |
542 | (map string-pad-right description paddings)) | |
543 | descriptions))) | |
544 | ||
545 | (let* ((descriptions | |
546 | (map | |
547 | (lambda (partition) | |
548 | (let ((user-partition | |
549 | (find-user-partition-by-parted-object user-partitions | |
550 | partition))) | |
551 | (partition-description partition user-partition))) | |
552 | partitions)) | |
553 | (padded-descriptions (if (null? partitions) | |
554 | '() | |
555 | (pad-descriptions descriptions)))) | |
556 | (map (cut string-join <> " ") padded-descriptions))) | |
557 | ||
558 | (define (user-partition-description user-partition) | |
559 | "Return a string describing the given USER-PARTITION record." | |
560 | (let* ((partition (user-partition-parted-object user-partition)) | |
561 | (disk (partition-disk partition)) | |
562 | (disk-type (disk-disk-type disk)) | |
563 | (device (disk-device disk)) | |
564 | (has-name? (disk-type-check-feature | |
565 | disk-type | |
566 | DISK-TYPE-FEATURE-PARTITION-NAME)) | |
567 | (has-extended? (disk-type-check-feature | |
568 | disk-type | |
569 | DISK-TYPE-FEATURE-EXTENDED)) | |
570 | (name (user-partition-name user-partition)) | |
571 | (type (user-partition-type user-partition)) | |
572 | (type-name (symbol->string type)) | |
573 | (fs-type (user-partition-fs-type user-partition)) | |
574 | (fs-type-name (user-fs-type-name fs-type)) | |
575 | (bootable? (user-partition-bootable? user-partition)) | |
576 | (esp? (user-partition-esp? user-partition)) | |
85caf5f3 | 577 | (need-formatting? (user-partition-need-formatting? user-partition)) |
bf304dbc | 578 | (crypt-label (user-partition-crypt-label user-partition)) |
69a934f2 MO |
579 | (size (user-partition-size user-partition)) |
580 | (mount-point (user-partition-mount-point user-partition))) | |
581 | `(,@(if has-name? | |
8f71305e LC |
582 | `((name . ,(format #f (G_ "Name: ~a") |
583 | (or name (G_ "None"))))) | |
69a934f2 MO |
584 | '()) |
585 | ,@(if (and has-extended? | |
586 | (freespace-partition? partition) | |
587 | (not (eq? type 'logical))) | |
8f71305e | 588 | `((type . ,(format #f (G_ "Type: ~a") type-name))) |
69a934f2 MO |
589 | '()) |
590 | ,@(if (eq? type 'extended) | |
591 | '() | |
8f71305e LC |
592 | `((fs-type . ,(format #f (G_ "File system type: ~a") |
593 | fs-type-name)))) | |
69a934f2 MO |
594 | ,@(if (or (eq? type 'extended) |
595 | (eq? fs-type 'swap) | |
596 | (not has-extended?)) | |
597 | '() | |
8f71305e LC |
598 | `((bootable . ,(format #f (G_ "Bootable flag: ~:[off~;on~]") |
599 | bootable?)))) | |
69a934f2 MO |
600 | ,@(if (and (not has-extended?) |
601 | (not (eq? fs-type 'swap))) | |
8f71305e | 602 | `((esp? . ,(format #f (G_ "ESP flag: ~:[off~;on~]") esp?))) |
69a934f2 MO |
603 | '()) |
604 | ,@(if (freespace-partition? partition) | |
605 | (let ((size-formatted | |
8f71305e | 606 | (or size (unit-format device ;XXX: i18n |
69a934f2 | 607 | (partition-length partition))))) |
8f71305e | 608 | `((size . ,(format #f (G_ "Size: ~a") size-formatted)))) |
69a934f2 | 609 | '()) |
bf304dbc MO |
610 | ,@(if (or (eq? type 'extended) |
611 | (eq? fs-type 'swap)) | |
612 | '() | |
613 | `((crypt-label | |
8f71305e LC |
614 | . ,(format #f (G_ "Encryption: ~:[No~a~;Yes (label '~a')~]") |
615 | crypt-label (or crypt-label ""))))) | |
69a934f2 MO |
616 | ,@(if (or (freespace-partition? partition) |
617 | (eq? fs-type 'swap)) | |
618 | '() | |
85caf5f3 | 619 | `((need-formatting? |
8f71305e LC |
620 | . ,(format #f (G_ "Format the partition? ~:[No~;Yes~]") |
621 | need-formatting?)))) | |
69a934f2 MO |
622 | ,@(if (or (eq? type 'extended) |
623 | (eq? fs-type 'swap)) | |
624 | '() | |
625 | `((mount-point | |
8f71305e LC |
626 | . ,(format #f (G_ "Mount point: ~a") |
627 | (or mount-point | |
628 | (and esp? (default-esp-mount-point)) | |
629 | (G_ "None"))))))))) | |
69a934f2 MO |
630 | |
631 | \f | |
632 | ;; | |
633 | ;; Partition table creation. | |
634 | ;; | |
635 | ||
636 | (define (mklabel device type-name) | |
637 | "Create a partition table on DEVICE. TYPE-NAME is the type of the partition | |
638 | table, \"msdos\" or \"gpt\"." | |
0a74509a JP |
639 | (let* ((type (disk-type-get type-name)) |
640 | (disk (disk-new-fresh device type))) | |
641 | (or disk | |
642 | (raise | |
643 | (condition | |
644 | (&error) | |
645 | (&message (message (format #f "Cannot create partition table of type | |
646 | ~a on device ~a." type-name (device-path device))))))))) | |
69a934f2 MO |
647 | |
648 | \f | |
649 | ;; | |
650 | ;; Partition creation. | |
651 | ;; | |
652 | ||
653 | ;; The maximum count of primary partitions is exceeded. | |
654 | (define-condition-type &max-primary-exceeded &condition | |
655 | max-primary-exceeded?) | |
656 | ||
657 | ;; It is not possible to create an extended partition. | |
658 | (define-condition-type &extended-creation-error &condition | |
659 | extended-creation-error?) | |
660 | ||
661 | ;; It is not possible to create a logical partition. | |
662 | (define-condition-type &logical-creation-error &condition | |
663 | logical-creation-error?) | |
664 | ||
665 | (define (can-create-primary? disk) | |
666 | "Return #t if it is possible to create a primary partition on DISK, return | |
667 | #f otherwise." | |
668 | (let ((max-primary (disk-get-max-primary-partition-count disk))) | |
669 | (find (lambda (number) | |
670 | (not (disk-get-partition disk number))) | |
671 | (iota max-primary 1)))) | |
672 | ||
673 | (define (can-create-extended? disk) | |
674 | "Return #t if it is possible to create an extended partition on DISK, return | |
675 | #f otherwise." | |
676 | (let* ((disk-type (disk-disk-type disk)) | |
677 | (has-extended? (disk-type-check-feature | |
678 | disk-type | |
679 | DISK-TYPE-FEATURE-EXTENDED))) | |
680 | (and (can-create-primary? disk) | |
681 | has-extended? | |
682 | (not (disk-extended-partition disk))))) | |
683 | ||
684 | (define (can-create-logical? disk) | |
685 | "Return #t is it is possible to create a logical partition on DISK, return | |
686 | #f otherwise." | |
687 | (let* ((disk-type (disk-disk-type disk)) | |
688 | (has-extended? (disk-type-check-feature | |
689 | disk-type | |
690 | DISK-TYPE-FEATURE-EXTENDED))) | |
691 | (and has-extended? | |
692 | (disk-extended-partition disk)))) | |
693 | ||
694 | (define (can-create-partition? user-part) | |
695 | "Return #t if it is possible to create the given USER-PART record, return #f | |
696 | otherwise." | |
697 | (let* ((type (user-partition-type user-part)) | |
698 | (partition (user-partition-parted-object user-part)) | |
699 | (disk (partition-disk partition))) | |
700 | (case type | |
701 | ((normal) | |
702 | (or (can-create-primary? disk) | |
703 | (raise | |
704 | (condition (&max-primary-exceeded))))) | |
705 | ((extended) | |
706 | (or (can-create-extended? disk) | |
707 | (raise | |
708 | (condition (&extended-creation-error))))) | |
709 | ((logical) | |
710 | (or (can-create-logical? disk) | |
711 | (raise | |
712 | (condition (&logical-creation-error)))))))) | |
713 | ||
714 | (define* (mkpart disk user-partition | |
715 | #:key (previous-partition #f)) | |
716 | "Create the given USER-PARTITION on DISK. The PREVIOUS-PARTITION argument as | |
b83e4a93 | 717 | to be set to the partition preceding USER-PARTITION if any." |
69a934f2 MO |
718 | |
719 | (define (parse-start-end start end) | |
720 | "Parse start and end strings as positions on DEVICE expressed with a unit, | |
721 | like '100GB' or '12.2KiB'. Return a list of 4 elements, the start sector, its | |
722 | range (1 unit large area centered on start sector), the end sector and its | |
723 | range." | |
724 | (let ((device (disk-device disk))) | |
725 | (call-with-values | |
726 | (lambda () | |
727 | (unit-parse start device)) | |
728 | (lambda (start-sector start-range) | |
729 | (call-with-values | |
730 | (lambda () | |
731 | (unit-parse end device)) | |
732 | (lambda (end-sector end-range) | |
733 | (list start-sector start-range | |
734 | end-sector end-range))))))) | |
735 | ||
736 | (define* (extend-ranges! start-range end-range | |
737 | #:key (offset 0)) | |
738 | "Try to extend START-RANGE by 1 MEBIBYTE to the right and END-RANGE by 1 | |
739 | MEBIBYTE to the left. This way, if the disk is aligned on 2048 sectors of | |
740 | 512KB (like frequently), we will have a chance for the | |
741 | 'optimal-align-constraint' to succeed. Do not extend ranges if that would | |
742 | cause them to cross." | |
743 | (let* ((device (disk-device disk)) | |
744 | (start-range-end (geometry-end start-range)) | |
745 | (end-range-start (geometry-start end-range)) | |
746 | (mebibyte-sector-size (/ MEBIBYTE-SIZE | |
747 | (device-sector-size device))) | |
748 | (new-start-range-end | |
749 | (+ start-range-end mebibyte-sector-size offset)) | |
750 | (new-end-range-start | |
751 | (- end-range-start mebibyte-sector-size offset))) | |
752 | (when (< new-start-range-end new-end-range-start) | |
753 | (geometry-set-end start-range new-start-range-end) | |
754 | (geometry-set-start end-range new-end-range-start)))) | |
755 | ||
756 | (match (parse-start-end (user-partition-start user-partition) | |
757 | (user-partition-end user-partition)) | |
758 | ((start-sector start-range end-sector end-range) | |
759 | (let* ((prev-end (if previous-partition | |
760 | (partition-end previous-partition) | |
761 | 0)) | |
762 | (start-distance (- start-sector prev-end)) | |
763 | (type (user-partition-type user-partition)) | |
764 | ;; There should be at least 2 unallocated sectors in front of each | |
765 | ;; logical partition, otherwise parted will fail badly: | |
766 | ;; https://gparted.org/h2-fix-msdos-pt.php#apply-action-fail. | |
767 | (start-offset (if previous-partition | |
768 | (- 3 start-distance) | |
769 | 0)) | |
770 | (start-sector* (if (and (eq? type 'logical) | |
771 | (< start-distance 3)) | |
772 | (+ start-sector start-offset) | |
773 | start-sector))) | |
b83e4a93 TGR |
774 | ;; This is a hack. Parted almost always fails to create optimally |
775 | ;; aligned partitions (unless specifying percentages) because the | |
69a934f2 MO |
776 | ;; default range of 1MB centered on the start sector is not enough when |
777 | ;; the optimal alignment is 2048 sectors of 512KB. | |
778 | (extend-ranges! start-range end-range #:offset start-offset) | |
779 | ||
780 | (let* ((device (disk-device disk)) | |
781 | (disk-type (disk-disk-type disk)) | |
782 | (length (device-length device)) | |
783 | (name (user-partition-name user-partition)) | |
784 | (filesystem-type | |
785 | (filesystem-type-get | |
786 | (user-fs-type-name | |
787 | (user-partition-fs-type user-partition)))) | |
788 | (flags `(,@(if (user-partition-bootable? user-partition) | |
789 | `(,PARTITION-FLAG-BOOT) | |
790 | '()) | |
791 | ,@(if (user-partition-esp? user-partition) | |
792 | `(,PARTITION-FLAG-ESP) | |
793 | '()) | |
794 | ,@(if (user-partition-bios-grub? user-partition) | |
795 | `(,PARTITION-FLAG-BIOS-GRUB) | |
796 | '()))) | |
797 | (has-name? (disk-type-check-feature | |
798 | disk-type | |
799 | DISK-TYPE-FEATURE-PARTITION-NAME)) | |
800 | (partition-type (partition-type->int type)) | |
801 | (partition (partition-new disk | |
802 | #:type partition-type | |
803 | #:filesystem-type filesystem-type | |
804 | #:start start-sector* | |
805 | #:end end-sector)) | |
806 | (user-constraint (constraint-new | |
807 | #:start-align 'any | |
808 | #:end-align 'any | |
809 | #:start-range start-range | |
810 | #:end-range end-range | |
811 | #:min-size 1 | |
812 | #:max-size length)) | |
813 | (dev-constraint | |
814 | (device-get-optimal-aligned-constraint device)) | |
815 | (final-constraint (constraint-intersect user-constraint | |
816 | dev-constraint)) | |
817 | (no-constraint (constraint-any device)) | |
818 | ;; Try to create a partition with an optimal alignment | |
8c287bb2 MO |
819 | ;; constraint. If it fails, fallback to creating a partition |
820 | ;; with no specific constraint. | |
821 | (partition-constraint-ok? | |
822 | (disk-add-partition disk partition final-constraint)) | |
823 | (partition-no-contraint-ok? | |
824 | (or partition-constraint-ok? | |
825 | (disk-add-partition disk partition no-constraint))) | |
69a934f2 | 826 | (partition-ok? |
8c287bb2 | 827 | (or partition-constraint-ok? partition-no-contraint-ok?))) |
4f2fd33b JP |
828 | (installer-log-line "Creating partition:") |
829 | (installer-log-line "~/type: ~a" partition-type) | |
830 | (installer-log-line "~/filesystem-type: ~a" | |
831 | (filesystem-type-name filesystem-type)) | |
eb0277e7 | 832 | (installer-log-line "~/flags: ~a" flags) |
4f2fd33b JP |
833 | (installer-log-line "~/start: ~a" start-sector*) |
834 | (installer-log-line "~/end: ~a" end-sector) | |
835 | (installer-log-line "~/start-range: [~a, ~a]" | |
836 | (geometry-start start-range) | |
837 | (geometry-end start-range)) | |
838 | (installer-log-line "~/end-range: [~a, ~a]" | |
839 | (geometry-start end-range) | |
840 | (geometry-end end-range)) | |
841 | (installer-log-line "~/constraint: ~a" | |
842 | partition-constraint-ok?) | |
843 | (installer-log-line "~/no-constraint: ~a" | |
844 | partition-no-contraint-ok?) | |
69a934f2 MO |
845 | ;; Set the partition name if supported. |
846 | (when (and partition-ok? has-name? name) | |
847 | (partition-set-name partition name)) | |
848 | ||
3c381af7 MO |
849 | ;; Both partition-set-system and partition-set-flag calls can affect |
850 | ;; the partition type. Their order is important, see: | |
851 | ;; https://issues.guix.gnu.org/55549. | |
852 | (partition-set-system partition filesystem-type) | |
853 | ||
854 | ;; Set flags if required. | |
69a934f2 MO |
855 | (for-each (lambda (flag) |
856 | (and (partition-is-flag-available? partition flag) | |
857 | (partition-set-flag partition flag 1))) | |
858 | flags) | |
859 | ||
3c381af7 | 860 | (and partition-ok? partition)))))) |
69a934f2 MO |
861 | |
862 | \f | |
863 | ;; | |
864 | ;; Partition destruction. | |
865 | ;; | |
866 | ||
867 | (define (rmpart disk number) | |
868 | "Remove the partition with the given NUMBER on DISK." | |
869 | (let ((partition (disk-get-partition disk number))) | |
70c7b7c7 | 870 | (disk-remove-partition* disk partition))) |
69a934f2 MO |
871 | |
872 | \f | |
873 | ;; | |
874 | ;; Auto partitionning. | |
875 | ;; | |
876 | ||
15374648 LC |
877 | (define* (create-adjacent-partitions! disk partitions |
878 | #:key (last-partition-end 0)) | |
69a934f2 MO |
879 | "Create the given PARTITIONS on DISK. LAST-PARTITION-END is the sector from |
880 | which we want to start creating partitions. The START and END of each created | |
881 | partition are computed from its SIZE value and the position of the last | |
882 | partition." | |
883 | (let ((device (disk-device disk))) | |
884 | (let loop ((partitions partitions) | |
885 | (remaining-space (- (device-length device) | |
886 | last-partition-end)) | |
887 | (start last-partition-end)) | |
888 | (match partitions | |
889 | (() '()) | |
890 | ((partition . rest) | |
891 | (let* ((size (user-partition-size partition)) | |
892 | (percentage-size (and (string? size) | |
893 | (read-percentage size))) | |
894 | (sector-size (device-sector-size device)) | |
895 | (partition-size (if percentage-size | |
896 | (exact->inexact | |
897 | (* (/ percentage-size 100) | |
898 | remaining-space)) | |
899 | size)) | |
900 | (end-partition (min (- (device-length device) 1) | |
901 | (nearest-exact-integer | |
902 | (+ start partition-size 1)))) | |
903 | (name (user-partition-name partition)) | |
904 | (type (user-partition-type partition)) | |
905 | (fs-type (user-partition-fs-type partition)) | |
906 | (start-formatted (unit-format-custom device | |
907 | start | |
908 | UNIT-SECTOR)) | |
909 | (end-formatted (unit-format-custom device | |
910 | end-partition | |
911 | UNIT-SECTOR)) | |
912 | (new-user-partition (user-partition | |
913 | (inherit partition) | |
914 | (start start-formatted) | |
915 | (end end-formatted))) | |
916 | (new-partition | |
917 | (mkpart disk new-user-partition))) | |
918 | (if new-partition | |
919 | (cons (user-partition | |
920 | (inherit new-user-partition) | |
44b2d31c MO |
921 | (file-name (partition-get-path new-partition)) |
922 | (disk-file-name (device-path device)) | |
69a934f2 MO |
923 | (parted-object new-partition)) |
924 | (loop rest | |
925 | (if (eq? type 'extended) | |
926 | remaining-space | |
927 | (- remaining-space | |
928 | (partition-length new-partition))) | |
929 | (if (eq? type 'extended) | |
930 | (+ start 1) | |
931 | (+ (partition-end new-partition) 1)))) | |
932 | (error | |
933 | (format #f "Unable to create partition ~a~%" name))))))))) | |
934 | ||
85caf5f3 | 935 | (define (force-user-partitions-formatting user-partitions) |
f1a3c114 | 936 | "Set the NEED-FORMATTING? fields to #t on all <user-partition> records of |
69a934f2 MO |
937 | USER-PARTITIONS list and return the updated list." |
938 | (map (lambda (p) | |
939 | (user-partition | |
940 | (inherit p) | |
85caf5f3 | 941 | (need-formatting? #t))) |
69a934f2 MO |
942 | user-partitions)) |
943 | ||
15374648 LC |
944 | (define* (auto-partition! disk |
945 | #:key | |
946 | (scheme 'entire-root)) | |
69a934f2 MO |
947 | "Automatically create partitions on DISK. All the previous |
948 | partitions (except the ESP on a GPT disk, if present) are wiped. SCHEME is the | |
949 | desired partitioning scheme. It can be 'entire-root or | |
950 | 'entire-root-home. 'entire-root will create a swap partition and a root | |
951 | partition occupying all the remaining space. 'entire-root-home will create a | |
d68de958 LC |
952 | swap partition, a root partition and a home partition. |
953 | ||
954 | Return the complete list of partitions on DISK, including the ESP when it | |
955 | exists." | |
69a934f2 MO |
956 | (let* ((device (disk-device disk)) |
957 | (disk-type (disk-disk-type disk)) | |
958 | (has-extended? (disk-type-check-feature | |
959 | disk-type | |
960 | DISK-TYPE-FEATURE-EXTENDED)) | |
961 | (partitions (filter data-partition? (disk-partitions disk))) | |
962 | (esp-partition (find-esp-partition partitions)) | |
963 | ;; According to | |
964 | ;; https://wiki.archlinux.org/index.php/EFI_system_partition, the ESP | |
965 | ;; size should be at least 550MiB. | |
966 | (new-esp-size (nearest-exact-integer | |
967 | (/ (* 550 MEBIBYTE-SIZE) | |
968 | (device-sector-size device)))) | |
969 | (end-esp-partition (and esp-partition | |
970 | (partition-end esp-partition))) | |
971 | (non-boot-partitions (remove esp-partition? partitions)) | |
972 | (bios-grub-size (/ (* 3 MEBIBYTE-SIZE) | |
973 | (device-sector-size device))) | |
974 | (five-percent-disk (nearest-exact-integer | |
975 | (* 0.05 (device-length device)))) | |
976 | (default-swap-size (nearest-exact-integer | |
977 | (/ (* 4 GIGABYTE-SIZE) | |
978 | (device-sector-size device)))) | |
979 | ;; Use a 4GB size for the swap if it represents less than 5% of the | |
980 | ;; disk space. Otherwise, set the swap size to 5% of the disk space. | |
981 | (swap-size (min default-swap-size five-percent-disk))) | |
982 | ||
af7a615c MO |
983 | ;; Remove everything but esp if it exists. |
984 | (for-each | |
985 | (lambda (partition) | |
986 | (and (data-partition? partition) | |
4989f6ac JP |
987 | ;; Do not remove logical partitions ourselves, since |
988 | ;; disk-remove-partition* will remove all the logical partitions | |
989 | ;; residing on an extended partition, which would lead to a | |
990 | ;; double-remove and ensuing SEGFAULT. | |
991 | (not (logical-partition? partition)) | |
af7a615c MO |
992 | (disk-remove-partition* disk partition))) |
993 | non-boot-partitions) | |
69a934f2 MO |
994 | |
995 | (let* ((start-partition | |
af7a615c MO |
996 | (if (efi-installation?) |
997 | (and (not esp-partition) | |
69a934f2 | 998 | (user-partition |
af7a615c MO |
999 | (fs-type 'fat32) |
1000 | (esp? #t) | |
1001 | (size new-esp-size) | |
1002 | (mount-point (default-esp-mount-point)))) | |
1003 | (user-partition | |
1004 | (fs-type 'ext4) | |
1005 | (bootable? #t) | |
1006 | (bios-grub? #t) | |
1007 | (size bios-grub-size)))) | |
69a934f2 | 1008 | (new-partitions |
bf304dbc MO |
1009 | (cond |
1010 | ((or (eq? scheme 'entire-root) | |
5737ba84 MO |
1011 | (eq? scheme 'entire-encrypted-root)) |
1012 | (let ((encrypted? (eq? scheme 'entire-encrypted-root))) | |
bf304dbc MO |
1013 | `(,@(if start-partition |
1014 | `(,start-partition) | |
1015 | '()) | |
5737ba84 | 1016 | ,@(if encrypted? |
44b2d31c MO |
1017 | '() |
1018 | `(,(user-partition | |
1019 | (fs-type 'swap) | |
1020 | (size swap-size)))) | |
bf304dbc MO |
1021 | ,(user-partition |
1022 | (fs-type 'ext4) | |
1023 | (bootable? has-extended?) | |
5737ba84 | 1024 | (crypt-label (and encrypted? "cryptroot")) |
bf304dbc MO |
1025 | (size "100%") |
1026 | (mount-point "/"))))) | |
1027 | ((or (eq? scheme 'entire-root-home) | |
5737ba84 MO |
1028 | (eq? scheme 'entire-encrypted-root-home)) |
1029 | (let ((encrypted? (eq? scheme 'entire-encrypted-root-home))) | |
bf304dbc MO |
1030 | `(,@(if start-partition |
1031 | `(,start-partition) | |
1032 | '()) | |
1033 | ,(user-partition | |
1034 | (fs-type 'ext4) | |
1035 | (bootable? has-extended?) | |
5737ba84 | 1036 | (crypt-label (and encrypted? "cryptroot")) |
bf304dbc MO |
1037 | (size "33%") |
1038 | (mount-point "/")) | |
1039 | ,@(if has-extended? | |
1040 | `(,(user-partition | |
1041 | (type 'extended) | |
1042 | (size "100%"))) | |
1043 | '()) | |
5737ba84 | 1044 | ,@(if encrypted? |
bf304dbc MO |
1045 | '() |
1046 | `(,(user-partition | |
1047 | (type (if has-extended? | |
1048 | 'logical | |
1049 | 'normal)) | |
1050 | (fs-type 'swap) | |
1051 | (size swap-size)))) | |
1052 | ,(user-partition | |
1053 | (type (if has-extended? | |
1054 | 'logical | |
1055 | 'normal)) | |
1056 | (fs-type 'ext4) | |
5737ba84 | 1057 | (crypt-label (and encrypted? "crypthome")) |
bf304dbc MO |
1058 | (size "100%") |
1059 | (mount-point "/home"))))))) | |
85caf5f3 | 1060 | (new-partitions* (force-user-partitions-formatting |
69a934f2 | 1061 | new-partitions))) |
d68de958 LC |
1062 | (append (if esp-partition |
1063 | (list (partition->user-partition esp-partition)) | |
1064 | '()) | |
1065 | (create-adjacent-partitions! disk | |
1066 | new-partitions* | |
1067 | #:last-partition-end | |
1068 | (or end-esp-partition 0)))))) | |
69a934f2 MO |
1069 | |
1070 | \f | |
1071 | ;; | |
1072 | ;; Convert user-partitions. | |
1073 | ;; | |
1074 | ||
1075 | ;; No root mount point found. | |
1076 | (define-condition-type &no-root-mount-point &condition | |
1077 | no-root-mount-point?) | |
1078 | ||
f5d9d6ec MO |
1079 | ;; Cannot not read the partition UUID. |
1080 | (define-condition-type &cannot-read-uuid &condition | |
1081 | cannot-read-uuid? | |
1082 | (partition cannot-read-uuid-partition)) | |
1083 | ||
69a934f2 | 1084 | (define (check-user-partitions user-partitions) |
f5d9d6ec MO |
1085 | "Check the following statements: |
1086 | ||
1087 | The USER-PARTITIONS list contains one <user-partition> record with a | |
1088 | mount-point set to '/'. Raise &no-root-mount-point condition otherwise. | |
1089 | ||
1090 | All the USER-PARTITIONS with a mount point and that will not be formatted have | |
1091 | a valid UUID. Raise a &cannot-read-uuid condition specifying the faulty | |
1092 | partition otherwise. | |
1093 | ||
1094 | Return #t if all the statements are valid." | |
1095 | (define (check-root) | |
1096 | (let ((mount-points | |
1097 | (map user-partition-mount-point user-partitions))) | |
1098 | (or (member "/" mount-points) | |
1099 | (raise | |
1100 | (condition (&no-root-mount-point)))))) | |
1101 | ||
1102 | (define (check-uuid) | |
1103 | (let ((mount-partitions | |
1104 | (filter user-partition-mount-point user-partitions))) | |
1105 | (every | |
1106 | (lambda (user-partition) | |
1107 | (let ((file-name (user-partition-file-name user-partition)) | |
1108 | (need-formatting? | |
1109 | (user-partition-need-formatting? user-partition))) | |
1110 | (or need-formatting? | |
1111 | (read-partition-uuid file-name) | |
1112 | (raise | |
1113 | (condition | |
1114 | (&cannot-read-uuid | |
1115 | (partition file-name))))))) | |
1116 | mount-partitions))) | |
1117 | ||
1118 | (and (check-root) | |
1119 | (check-uuid) | |
1120 | #t)) | |
69a934f2 | 1121 | |
44b2d31c MO |
1122 | (define (set-user-partitions-file-name user-partitions) |
1123 | "Set the partition file-name of <user-partition> records in USER-PARTITIONS | |
1124 | list and return the updated list." | |
69a934f2 MO |
1125 | (map (lambda (p) |
1126 | (let* ((partition (user-partition-parted-object p)) | |
44b2d31c | 1127 | (file-name (partition-get-path partition))) |
69a934f2 MO |
1128 | (user-partition |
1129 | (inherit p) | |
44b2d31c | 1130 | (file-name file-name)))) |
69a934f2 MO |
1131 | user-partitions)) |
1132 | ||
c5b13778 | 1133 | (define (create-btrfs-file-system partition) |
1133596b | 1134 | "Create a btrfs file-system for PARTITION file-name." |
af59e536 | 1135 | ((run-command-in-installer) "mkfs.btrfs" "-f" partition)) |
c5b13778 | 1136 | |
69a934f2 | 1137 | (define (create-ext4-file-system partition) |
44b2d31c | 1138 | "Create an ext4 file-system for PARTITION file-name." |
af59e536 | 1139 | ((run-command-in-installer) "mkfs.ext4" "-F" partition)) |
69a934f2 | 1140 | |
628d09ae DM |
1141 | (define (create-fat16-file-system partition) |
1142 | "Create a fat16 file-system for PARTITION file-name." | |
af59e536 | 1143 | ((run-command-in-installer) "mkfs.fat" "-F16" partition)) |
628d09ae | 1144 | |
69a934f2 | 1145 | (define (create-fat32-file-system partition) |
b7488b32 | 1146 | "Create a fat32 file-system for PARTITION file-name." |
af59e536 | 1147 | ((run-command-in-installer) "mkfs.fat" "-F32" partition)) |
69a934f2 | 1148 | |
8fec416c TGR |
1149 | (define (create-jfs-file-system partition) |
1150 | "Create a JFS file-system for PARTITION file-name." | |
af59e536 | 1151 | ((run-command-in-installer) "jfs_mkfs" "-f" partition)) |
8fec416c | 1152 | |
218a67df MO |
1153 | (define (create-ntfs-file-system partition) |
1154 | "Create a JFS file-system for PARTITION file-name." | |
af59e536 | 1155 | ((run-command-in-installer) "mkfs.ntfs" "-F" "-f" partition)) |
218a67df | 1156 | |
f34b8087 TGR |
1157 | (define (create-xfs-file-system partition) |
1158 | "Create an XFS file-system for PARTITION file-name." | |
af59e536 | 1159 | ((run-command-in-installer) "mkfs.xfs" "-f" partition)) |
f34b8087 | 1160 | |
69a934f2 | 1161 | (define (create-swap-partition partition) |
44b2d31c | 1162 | "Set up swap area on PARTITION file-name." |
af59e536 | 1163 | ((run-command-in-installer) "mkswap" "-f" partition)) |
69a934f2 | 1164 | |
bf304dbc MO |
1165 | (define (call-with-luks-key-file password proc) |
1166 | "Write PASSWORD in a temporary file and pass it to PROC as argument." | |
1167 | (call-with-temporary-output-file | |
1168 | (lambda (file port) | |
1169 | (put-string port password) | |
1170 | (close port) | |
1171 | (proc file)))) | |
1172 | ||
44b2d31c MO |
1173 | (define (user-partition-upper-file-name user-partition) |
1174 | "Return the file-name of the virtual block device corresponding to | |
1175 | USER-PARTITION if it is encrypted, or the plain file-name otherwise." | |
bf304dbc | 1176 | (let ((crypt-label (user-partition-crypt-label user-partition)) |
44b2d31c | 1177 | (file-name (user-partition-file-name user-partition))) |
bf304dbc MO |
1178 | (if crypt-label |
1179 | (string-append "/dev/mapper/" crypt-label) | |
44b2d31c | 1180 | file-name))) |
bf304dbc MO |
1181 | |
1182 | (define (luks-format-and-open user-partition) | |
5737ba84 | 1183 | "Format and open the encrypted partition pointed by USER-PARTITION." |
44b2d31c | 1184 | (let* ((file-name (user-partition-file-name user-partition)) |
bf304dbc | 1185 | (label (user-partition-crypt-label user-partition)) |
4814ec28 | 1186 | (password (secret-content (user-partition-crypt-password user-partition)))) |
bf304dbc MO |
1187 | (call-with-luks-key-file |
1188 | password | |
1189 | (lambda (key-file) | |
4f2fd33b | 1190 | (installer-log-line "formatting and opening LUKS entry ~s at ~s" |
5c04b00c | 1191 | label file-name) |
af59e536 JP |
1192 | ((run-command-in-installer) "cryptsetup" "-q" "luksFormat" |
1193 | file-name key-file) | |
1194 | ((run-command-in-installer) "cryptsetup" "open" "--type" "luks" | |
1195 | "--key-file" key-file file-name label))))) | |
bf304dbc | 1196 | |
fd942712 JP |
1197 | (define (luks-ensure-open user-partition) |
1198 | "Ensure partition pointed by USER-PARTITION is opened." | |
1199 | (unless (file-exists? (user-partition-upper-file-name user-partition)) | |
1200 | (let* ((file-name (user-partition-file-name user-partition)) | |
1201 | (label (user-partition-crypt-label user-partition)) | |
1202 | (password (secret-content (user-partition-crypt-password user-partition)))) | |
1203 | (call-with-luks-key-file | |
1204 | password | |
1205 | (lambda (key-file) | |
1206 | (installer-log-line "opening LUKS entry ~s at ~s" | |
1207 | label file-name) | |
1208 | ((run-command-in-installer) "cryptsetup" "open" "--type" "luks" | |
1209 | "--key-file" key-file file-name label)))))) | |
1210 | ||
bf304dbc | 1211 | (define (luks-close user-partition) |
5737ba84 | 1212 | "Close the encrypted partition pointed by USER-PARTITION." |
bf304dbc | 1213 | (let ((label (user-partition-crypt-label user-partition))) |
4f2fd33b | 1214 | (installer-log-line "closing LUKS entry ~s" label) |
af59e536 | 1215 | ((run-command-in-installer) "cryptsetup" "close" label))) |
bf304dbc | 1216 | |
69a934f2 MO |
1217 | (define (format-user-partitions user-partitions) |
1218 | "Format the <user-partition> records in USER-PARTITIONS list with | |
f1a3c114 | 1219 | NEED-FORMATTING? field set to #t." |
69a934f2 MO |
1220 | (for-each |
1221 | (lambda (user-partition) | |
85caf5f3 LC |
1222 | (let* ((need-formatting? |
1223 | (user-partition-need-formatting? user-partition)) | |
69a934f2 | 1224 | (type (user-partition-type user-partition)) |
bf304dbc | 1225 | (crypt-label (user-partition-crypt-label user-partition)) |
44b2d31c | 1226 | (file-name (user-partition-upper-file-name user-partition)) |
69a934f2 | 1227 | (fs-type (user-partition-fs-type user-partition))) |
bf304dbc MO |
1228 | (when crypt-label |
1229 | (luks-format-and-open user-partition)) | |
1230 | ||
69a934f2 | 1231 | (case fs-type |
c5b13778 DM |
1232 | ((btrfs) |
1233 | (and need-formatting? | |
1234 | (not (eq? type 'extended)) | |
1235 | (create-btrfs-file-system file-name))) | |
69a934f2 | 1236 | ((ext4) |
85caf5f3 | 1237 | (and need-formatting? |
69a934f2 | 1238 | (not (eq? type 'extended)) |
44b2d31c | 1239 | (create-ext4-file-system file-name))) |
628d09ae DM |
1240 | ((fat16) |
1241 | (and need-formatting? | |
1242 | (not (eq? type 'extended)) | |
1243 | (create-fat16-file-system file-name))) | |
69a934f2 | 1244 | ((fat32) |
85caf5f3 | 1245 | (and need-formatting? |
69a934f2 | 1246 | (not (eq? type 'extended)) |
44b2d31c | 1247 | (create-fat32-file-system file-name))) |
8fec416c TGR |
1248 | ((jfs) |
1249 | (and need-formatting? | |
1250 | (not (eq? type 'extended)) | |
1251 | (create-jfs-file-system file-name))) | |
218a67df MO |
1252 | ((ntfs) |
1253 | (and need-formatting? | |
1254 | (not (eq? type 'extended)) | |
1255 | (create-ntfs-file-system file-name))) | |
f34b8087 TGR |
1256 | ((xfs) |
1257 | (and need-formatting? | |
1258 | (not (eq? type 'extended)) | |
1259 | (create-xfs-file-system file-name))) | |
69a934f2 | 1260 | ((swap) |
44b2d31c | 1261 | (create-swap-partition file-name)) |
69a934f2 MO |
1262 | (else |
1263 | ;; TODO: Add support for other file-system types. | |
1264 | #t)))) | |
1265 | user-partitions)) | |
1266 | ||
1267 | (define (sort-partitions user-partitions) | |
1268 | "Sort USER-PARTITIONS by mount-points, so that the more nested mount-point | |
1269 | comes last. This is useful to mount/umount partitions in a coherent order." | |
1270 | (sort user-partitions | |
1271 | (lambda (a b) | |
1272 | (let ((mount-point-a (user-partition-mount-point a)) | |
1273 | (mount-point-b (user-partition-mount-point b))) | |
1274 | (string-prefix? mount-point-a mount-point-b))))) | |
1275 | ||
1276 | (define (mount-user-partitions user-partitions) | |
1277 | "Mount the <user-partition> records in USER-PARTITIONS list on their | |
b624206d | 1278 | respective mount-points." |
69a934f2 MO |
1279 | (let* ((mount-partitions (filter user-partition-mount-point user-partitions)) |
1280 | (sorted-partitions (sort-partitions mount-partitions))) | |
1281 | (for-each (lambda (user-partition) | |
1282 | (let* ((mount-point | |
1283 | (user-partition-mount-point user-partition)) | |
1284 | (target | |
1285 | (string-append (%installer-target-dir) | |
1286 | mount-point)) | |
1287 | (fs-type | |
1288 | (user-partition-fs-type user-partition)) | |
bf304dbc MO |
1289 | (crypt-label |
1290 | (user-partition-crypt-label user-partition)) | |
69a934f2 MO |
1291 | (mount-type |
1292 | (user-fs-type->mount-type fs-type)) | |
44b2d31c MO |
1293 | (file-name |
1294 | (user-partition-upper-file-name user-partition))) | |
fd942712 JP |
1295 | (when crypt-label |
1296 | (luks-ensure-open user-partition)) | |
b624206d | 1297 | (mkdir-p target) |
4f2fd33b | 1298 | (installer-log-line "mounting ~s on ~s" file-name target) |
44b2d31c | 1299 | (mount file-name target mount-type))) |
69a934f2 MO |
1300 | sorted-partitions))) |
1301 | ||
1302 | (define (umount-user-partitions user-partitions) | |
b624206d | 1303 | "Unmount all the <user-partition> records in USER-PARTITIONS list." |
69a934f2 MO |
1304 | (let* ((mount-partitions (filter user-partition-mount-point user-partitions)) |
1305 | (sorted-partitions (sort-partitions mount-partitions))) | |
1306 | (for-each (lambda (user-partition) | |
1307 | (let* ((mount-point | |
1308 | (user-partition-mount-point user-partition)) | |
bf304dbc MO |
1309 | (crypt-label |
1310 | (user-partition-crypt-label user-partition)) | |
69a934f2 MO |
1311 | (target |
1312 | (string-append (%installer-target-dir) | |
1313 | mount-point))) | |
4f2fd33b | 1314 | (installer-log-line "unmounting ~s" target) |
bf304dbc MO |
1315 | (umount target) |
1316 | (when crypt-label | |
1317 | (luks-close user-partition)))) | |
69a934f2 MO |
1318 | (reverse sorted-partitions)))) |
1319 | ||
b624206d MO |
1320 | (define (find-swap-user-partitions user-partitions) |
1321 | "Return the subset of <user-partition> records in USER-PARTITIONS list with | |
1322 | the FS-TYPE field set to 'swap, return the empty list if none found." | |
1323 | (filter (lambda (user-partition) | |
44b2d31c MO |
1324 | (let ((fs-type (user-partition-fs-type user-partition))) |
1325 | (eq? fs-type 'swap))) | |
1326 | user-partitions)) | |
b624206d MO |
1327 | |
1328 | (define (start-swapping user-partitions) | |
e1f37889 | 1329 | "Start swapping on <user-partition> records with FS-TYPE equal to 'swap." |
b624206d | 1330 | (let* ((swap-user-partitions (find-swap-user-partitions user-partitions)) |
44b2d31c | 1331 | (swap-devices (map user-partition-file-name swap-user-partitions))) |
b624206d MO |
1332 | (for-each swapon swap-devices))) |
1333 | ||
1334 | (define (stop-swapping user-partitions) | |
e1f37889 | 1335 | "Stop swapping on <user-partition> records with FS-TYPE equal to 'swap." |
b624206d | 1336 | (let* ((swap-user-partitions (find-swap-user-partitions user-partitions)) |
44b2d31c | 1337 | (swap-devices (map user-partition-file-name swap-user-partitions))) |
b624206d MO |
1338 | (for-each swapoff swap-devices))) |
1339 | ||
69a934f2 | 1340 | (define-syntax-rule (with-mounted-partitions user-partitions exp ...) |
b624206d | 1341 | "Mount USER-PARTITIONS and start swapping within the dynamic extent of EXP." |
69a934f2 MO |
1342 | (dynamic-wind |
1343 | (lambda () | |
b624206d MO |
1344 | (mount-user-partitions user-partitions) |
1345 | (start-swapping user-partitions)) | |
69a934f2 MO |
1346 | (lambda () |
1347 | exp ...) | |
1348 | (lambda () | |
1349 | (umount-user-partitions user-partitions) | |
b624206d | 1350 | (stop-swapping user-partitions) |
69a934f2 MO |
1351 | #f))) |
1352 | ||
1353 | (define (user-partition->file-system user-partition) | |
1354 | "Convert the given USER-PARTITION record in a FILE-SYSTEM record from | |
1355 | (gnu system file-systems) module and return it." | |
1356 | (let* ((mount-point (user-partition-mount-point user-partition)) | |
1357 | (fs-type (user-partition-fs-type user-partition)) | |
bf304dbc | 1358 | (crypt-label (user-partition-crypt-label user-partition)) |
69a934f2 | 1359 | (mount-type (user-fs-type->mount-type fs-type)) |
44b2d31c MO |
1360 | (file-name (user-partition-file-name user-partition)) |
1361 | (upper-file-name (user-partition-upper-file-name user-partition)) | |
59e8f3c3 MO |
1362 | ;; Only compute uuid if partition is not encrypted. |
1363 | (uuid (or crypt-label | |
44b2d31c | 1364 | (uuid->string (read-partition-uuid file-name) fs-type)))) |
69a934f2 MO |
1365 | `(file-system |
1366 | (mount-point ,mount-point) | |
bf304dbc | 1367 | (device ,@(if crypt-label |
44b2d31c | 1368 | `(,upper-file-name) |
bf304dbc MO |
1369 | `((uuid ,uuid (quote ,fs-type))))) |
1370 | (type ,mount-type) | |
1371 | ,@(if crypt-label | |
1372 | '((dependencies mapped-devices)) | |
1373 | '())))) | |
69a934f2 MO |
1374 | |
1375 | (define (user-partitions->file-systems user-partitions) | |
1376 | "Convert the given USER-PARTITIONS list of <user-partition> records into a | |
1377 | list of <file-system> records." | |
1378 | (filter-map | |
1379 | (lambda (user-partition) | |
1380 | (let ((mount-point | |
1381 | (user-partition-mount-point user-partition))) | |
1382 | (and mount-point | |
1383 | (user-partition->file-system user-partition)))) | |
1384 | user-partitions)) | |
1385 | ||
bf304dbc MO |
1386 | (define (user-partition->mapped-device user-partition) |
1387 | "Convert the given USER-PARTITION record into a MAPPED-DEVICE record | |
1388 | from (gnu system mapped-devices) and return it." | |
1389 | (let ((label (user-partition-crypt-label user-partition)) | |
44b2d31c | 1390 | (file-name (user-partition-file-name user-partition))) |
bf304dbc | 1391 | `(mapped-device |
59e8f3c3 | 1392 | (source (uuid ,(uuid->string |
44b2d31c | 1393 | (read-luks-partition-uuid file-name) |
59e8f3c3 | 1394 | 'luks))) |
bf304dbc MO |
1395 | (target ,label) |
1396 | (type luks-device-mapping)))) | |
1397 | ||
50247be5 LC |
1398 | (define (root-user-partition? partition) |
1399 | "Return true if PARTITION is the root partition." | |
1400 | (let ((mount-point (user-partition-mount-point partition))) | |
1401 | (and mount-point | |
1402 | (string=? mount-point "/")))) | |
1403 | ||
69a934f2 MO |
1404 | (define (bootloader-configuration user-partitions) |
1405 | "Return the bootloader configuration field for USER-PARTITIONS." | |
50247be5 LC |
1406 | (let* ((root-partition (find root-user-partition? |
1407 | user-partitions)) | |
44b2d31c | 1408 | (root-partition-disk (user-partition-disk-file-name root-partition))) |
69a934f2 MO |
1409 | `((bootloader-configuration |
1410 | ,@(if (efi-installation?) | |
1411 | `((bootloader grub-efi-bootloader) | |
da4e4094 | 1412 | (targets (list ,(default-esp-mount-point)))) |
69a934f2 | 1413 | `((bootloader grub-bootloader) |
da4e4094 | 1414 | (targets (list ,root-partition-disk)))) |
3191b5f6 LC |
1415 | |
1416 | ;; XXX: Assume we defined the 'keyboard-layout' field of | |
1417 | ;; <operating-system> right above. | |
1418 | (keyboard-layout keyboard-layout))))) | |
69a934f2 | 1419 | |
50247be5 LC |
1420 | (define (user-partition-missing-modules user-partitions) |
1421 | "Return the list of kernel modules missing from the default set of kernel | |
1422 | modules to access USER-PARTITIONS." | |
1423 | (let ((devices (filter user-partition-crypt-label user-partitions)) | |
1424 | (root (find root-user-partition? user-partitions))) | |
1425 | (delete-duplicates | |
1426 | (append-map (lambda (device) | |
1427 | (catch 'system-error | |
1428 | (lambda () | |
1429 | (missing-modules device %base-initrd-modules)) | |
1430 | (const '()))) | |
1431 | (delete-duplicates | |
1432 | (map user-partition-file-name | |
1433 | (cons root devices))))))) | |
1434 | ||
1435 | (define (initrd-configuration user-partitions) | |
1436 | "Return an 'initrd-modules' field with everything needed for | |
1437 | USER-PARTITIONS, or return nothing." | |
1438 | (match (user-partition-missing-modules user-partitions) | |
1439 | (() | |
1440 | '()) | |
1441 | ((modules ...) | |
0b051bac LC |
1442 | `((initrd-modules (append ',modules |
1443 | %base-initrd-modules)))))) | |
50247be5 | 1444 | |
69a934f2 MO |
1445 | (define (user-partitions->configuration user-partitions) |
1446 | "Return the configuration field for USER-PARTITIONS." | |
1447 | (let* ((swap-user-partitions (find-swap-user-partitions user-partitions)) | |
44b2d31c | 1448 | (swap-devices (map user-partition-file-name swap-user-partitions)) |
5737ba84 | 1449 | (encrypted-partitions |
bf304dbc | 1450 | (filter user-partition-crypt-label user-partitions))) |
54043bf2 | 1451 | `((bootloader ,@(bootloader-configuration user-partitions)) |
50247be5 | 1452 | ,@(initrd-configuration user-partitions) |
54043bf2 | 1453 | ,@(if (null? swap-devices) |
69a934f2 | 1454 | '() |
1c6d9853 LC |
1455 | (let* ((uuids (map (lambda (file) |
1456 | (uuid->string (read-partition-uuid file))) | |
1457 | swap-devices))) | |
d64b78ef MO |
1458 | `((swap-devices |
1459 | (list ,@(map (lambda (uuid) | |
1460 | `(swap-space | |
1461 | (target (uuid ,uuid)))) | |
1462 | uuids)))))) | |
5737ba84 | 1463 | ,@(if (null? encrypted-partitions) |
bf304dbc MO |
1464 | '() |
1465 | `((mapped-devices | |
1466 | (list ,@(map user-partition->mapped-device | |
5737ba84 | 1467 | encrypted-partitions))))) |
ff9522fb LC |
1468 | |
1469 | ,(vertical-space 1) | |
1470 | ,(let-syntax ((G_ (syntax-rules () ((_ str) str)))) | |
1471 | (comment (G_ "\ | |
1472 | ;; The list of file systems that get \"mounted\". The unique | |
1473 | ;; file system identifiers there (\"UUIDs\") can be obtained | |
1474 | ;; by running 'blkid' in a terminal.\n"))) | |
69a934f2 MO |
1475 | (file-systems (cons* |
1476 | ,@(user-partitions->file-systems user-partitions) | |
1477 | %base-file-systems))))) | |
1478 | ||
1479 | \f | |
1480 | ;; | |
1481 | ;; Initialization. | |
1482 | ;; | |
1483 | ||
1484 | (define (init-parted) | |
1485 | "Initialize libparted support." | |
70c7b7c7 | 1486 | (probe-all-devices!) |
5697a524 MO |
1487 | ;; Remove all logical devices, otherwise "device-is-busy?" will report true |
1488 | ;; on all devices containaing active logical volumes. | |
1489 | (remove-logical-devices) | |
69a934f2 MO |
1490 | (exception-set-handler (lambda (exception) |
1491 | EXCEPTION-OPTION-UNHANDLED))) | |
1492 | ||
1493 | (define (free-parted devices) | |
1494 | "Deallocate memory used for DEVICES in parted, force sync them and wait for | |
1495 | the devices not to be used before returning." | |
85caf5f3 | 1496 | ;; XXX: Formatting and further operations on disk partition table may fail |
69a934f2 MO |
1497 | ;; because the partition table changes are not synced, or because the device |
1498 | ;; is still in use, even if parted should have finished editing | |
1499 | ;; partitions. This is not well understood, but syncing devices and waiting | |
1500 | ;; them to stop returning EBUSY to BLKRRPART ioctl seems to be enough. The | |
1501 | ;; same kind of issue is described here: | |
1502 | ;; https://mail.gnome.org/archives/commits-list/2013-March/msg18423.html. | |
44b2d31c | 1503 | (let ((device-file-names (map device-path devices))) |
69a934f2 | 1504 | (for-each force-device-sync devices) |
44b2d31c | 1505 | (for-each (lambda (file-name) |
3d3ffb30 MO |
1506 | (let/time ((time in-use? |
1507 | (with-delay-device-in-use? file-name))) | |
1508 | (if in-use? | |
1509 | (error | |
1510 | (format #f (G_ "Device ~a is still in use.") | |
1511 | file-name)) | |
4f2fd33b | 1512 | (installer-log-line "Syncing ~a took ~a seconds." |
3d3ffb30 | 1513 | file-name (time-second time))))) |
44b2d31c | 1514 | device-file-names))) |