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