gnu/installer/parted.scm

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