projects/guix·blob python-team · refs

1606 lines · 63.8 KiB

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