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