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