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