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