gnu/installer/parted.scm

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