gnu/installer/newt/partition.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
   3 ;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (gnu installer newt partition)
  21   #:use-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 installer newt utils)
  26   #:use-module (guix i18n)
  27   #:use-module (ice-9 match)
  28   #:use-module (srfi srfi-1)
  29   #:use-module (srfi srfi-26)
  30   #:use-module (srfi srfi-34)
  31   #:use-module (srfi srfi-35)
  32   #:use-module (newt)
  33   #:use-module (parted)
  34   #:export (run-partioning-page))
  35
  36 (define (button-exit-action)
  37   "Raise the &installer-step-abort condition."
  38   (raise
  39    (condition
  40     (&installer-step-abort))))
  41
  42 (define (run-scheme-page)
  43   "Run a page asking the user for a partitioning scheme."
  44   (let* ((items
  45           `((root . ,(G_ "Everything is one partition"))
  46             (root-home . ,(G_ "Separate /home partition"))))
  47          (result (run-listbox-selection-page
  48                   #:info-text (G_ "Please select a partitioning scheme.")
  49                   #:title (G_ "Partition scheme")
  50                   #:listbox-items items
  51                   #:listbox-item->text cdr
  52                   #:button-text (G_ "Exit")
  53                   #:button-callback-procedure button-exit-action)))
  54     (car result)))
  55
  56 (define (draw-formatting-page)
  57   "Draw a page asking for confirmation, and then indicating that partitions
  58 are being formatted."
  59   (run-confirmation-page (G_ "We are about to format your hard disk.  All \
  60 its data will be lost.  Do you wish to continue?")
  61                          (G_ "Format disk?")
  62                          #:exit-button-procedure button-exit-action)
  63   (draw-info-page
  64    (format #f (G_ "Partition formatting is in progress, please wait."))
  65    (G_ "Preparing partitions")))
  66
  67 (define (run-device-page devices)
  68   "Run a page asking the user to select a device among those in the given
  69 DEVICES list."
  70   (define (device-items)
  71     (map (lambda (device)
  72            `(,device . ,(device-description device)))
  73          devices))
  74
  75   (let* ((result (run-listbox-selection-page
  76                   #:info-text (G_ "Please select a disk.")
  77                   #:title (G_ "Disk")
  78                   #:listbox-items (device-items)
  79                   #:listbox-item->text cdr
  80                   #:button-text (G_ "Exit")
  81                   #:button-callback-procedure button-exit-action))
  82          (device (car result)))
  83     device))
  84
  85 (define (run-label-page button-text button-callback)
  86   "Run a page asking the user to select a partition table label."
  87   (run-listbox-selection-page
  88    #:info-text (G_ "Select a new partition table type. \
  89 Be careful, all data on the disk will be lost.")
  90    #:title (G_ "Partition table")
  91    #:listbox-items '("msdos" "gpt")
  92    #:listbox-item->text identity
  93    #:button-text button-text
  94    #:button-callback-procedure button-callback))
  95
  96 (define (run-type-page partition)
  97   "Run a page asking the user to select a partition type."
  98   (let* ((disk (partition-disk partition))
  99          (partitions (disk-partitions disk))
 100          (other-extended-partitions?
 101           (any extended-partition? partitions))
 102          (items
 103           `(normal ,@(if other-extended-partitions?
 104                          '()
 105                          '(extended)))))
 106     (run-listbox-selection-page
 107      #:info-text (G_ "Please select a partition type.")
 108      #:title (G_ "Partition type")
 109      #:listbox-items items
 110      #:listbox-item->text symbol->string
 111      #:sort-listbox-items? #f
 112      #:button-text (G_ "Exit")
 113      #:button-callback-procedure button-exit-action)))
 114
 115 (define (run-fs-type-page)
 116   "Run a page asking the user to select a file-system type."
 117   (run-listbox-selection-page
 118    #:info-text (G_ "Please select the file-system type for this partition.")
 119    #:title (G_ "File-system type")
 120    #:listbox-items '(ext4 btrfs fat32 swap)
 121    #:listbox-item->text user-fs-type-name
 122    #:sort-listbox-items? #f
 123    #:button-text (G_ "Exit")
 124    #:button-callback-procedure button-exit-action))
 125
 126 (define (inform-can-create-partition? user-partition)
 127   "Return #t if it is possible to create USER-PARTITION. This is determined by
 128 calling CAN-CREATE-PARTITION? procedure. If an exception is raised, catch it
 129 an inform the user with an appropriate error-page and return #f."
 130   (guard (c ((max-primary-exceeded? c)
 131             (run-error-page
 132              (G_ "Primary partitions count exceeded.")
 133              (G_ "Creation error"))
 134             #f)
 135            ((extended-creation-error? c)
 136             (run-error-page
 137              (G_ "Extended partition creation error.")
 138              (G_ "Creation error"))
 139             #f)
 140            ((logical-creation-error? c)
 141             (run-error-page
 142              (G_ "Logical partition creation error.")
 143              (G_ "Creation error"))
 144             #f))
 145     (can-create-partition? user-partition)))
 146
 147 (define (prompt-luks-passwords user-partitions)
 148   "Prompt for the luks passwords of the encrypted partitions in
 149 USER-PARTITIONS list. Return this list with password fields filled-in."
 150   (map (lambda (user-part)
 151          (let* ((crypt-label (user-partition-crypt-label user-part))
 152                 (file-name (user-partition-file-name user-part))
 153                 (password-page
 154                  (lambda ()
 155                    ;; Note: Don't use FLAG-PASSWORD here because this is the
 156                    ;; first bit of text that the user types in, so it's
 157                    ;; probably safer if they can see that the keyboard layout
 158                    ;; they chose is in effect.
 159                    (run-input-page
 160                     (format #f (G_ "Please enter the password for the \
 161 encryption of partition ~a (label: ~a).") file-name crypt-label)
 162                     (G_ "Password required"))))
 163                 (password-confirm-page
 164                  (lambda ()
 165                    (run-input-page
 166                     (format #f (G_ "Please confirm the password for the \
 167 encryption of partition ~a (label: ~a).") file-name crypt-label)
 168                     (G_ "Password confirmation required")
 169                     #:input-flags FLAG-PASSWORD))))
 170            (if crypt-label
 171                (let loop ()
 172                  (let ((password (password-page))
 173                        (confirmation (password-confirm-page)))
 174                    (if (string=? password confirmation)
 175                        (user-partition
 176                         (inherit user-part)
 177                         (crypt-password password))
 178                        (begin
 179                          (run-error-page
 180                           (G_ "Password mismatch, please try again.")
 181                           (G_ "Password error"))
 182                          (loop)))))
 183                user-part)))
 184        user-partitions))
 185
 186 (define* (run-partition-page target-user-partition
 187                              #:key
 188                              (default-item #f))
 189   "Run a page allowing the user to edit the given TARGET-USER-PARTITION
 190 record. If the argument DEFAULT-ITEM is passed, use it to select the current
 191 listbox item. This is used to avoid the focus to switch back to the first
 192 listbox entry while calling this procedure recursively."
 193
 194   (define (numeric-size device size)
 195     "Parse the given SIZE on DEVICE and return it."
 196     (call-with-values
 197         (lambda ()
 198           (unit-parse size device))
 199       (lambda (value range)
 200         value)))
 201
 202   (define (numeric-size-range device size)
 203     "Parse the given SIZE on DEVICE and return the associated RANGE."
 204     (call-with-values
 205         (lambda ()
 206           (unit-parse size device))
 207       (lambda (value range)
 208         range)))
 209
 210   (define* (fill-user-partition-geom user-part
 211                                      #:key
 212                                      device (size #f) start end)
 213     "Return the given USER-PART with the START, END and SIZE fields set to the
 214 eponym arguments. Use UNIT-FORMAT-CUSTOM to format START and END arguments as
 215 sectors on DEVICE."
 216     (user-partition
 217      (inherit user-part)
 218      (size size)
 219      (start (unit-format-custom device start UNIT-SECTOR))
 220      (end (unit-format-custom device end UNIT-SECTOR))))
 221
 222   (define (apply-user-partition-changes user-part)
 223     "Set the name, file-system type and boot flag on the partition specified
 224 by USER-PART, if it is applicable for the partition type."
 225     (let* ((partition (user-partition-parted-object user-part))
 226            (disk (partition-disk partition))
 227            (disk-type (disk-disk-type disk))
 228            (device (disk-device disk))
 229            (has-name? (disk-type-check-feature
 230                        disk-type
 231                        DISK-TYPE-FEATURE-PARTITION-NAME))
 232            (name (user-partition-name user-part))
 233            (fs-type (filesystem-type-get
 234                      (user-fs-type-name
 235                       (user-partition-fs-type user-part))))
 236            (bootable? (user-partition-bootable? user-part))
 237            (esp? (user-partition-esp? user-part))
 238            (flag-bootable?
 239             (partition-is-flag-available? partition PARTITION-FLAG-BOOT))
 240            (flag-esp?
 241             (partition-is-flag-available? partition PARTITION-FLAG-ESP)))
 242       (when (and has-name? name)
 243         (partition-set-name partition name))
 244       (partition-set-system partition fs-type)
 245       (when flag-bootable?
 246         (partition-set-flag partition
 247                             PARTITION-FLAG-BOOT
 248                             (if bootable? 1 0)))
 249       (when flag-esp?
 250         (partition-set-flag partition
 251                             PARTITION-FLAG-ESP
 252                             (if esp? 1 0)))
 253       #t))
 254
 255   (define (listbox-action listbox-item)
 256     (let* ((item (car listbox-item))
 257            (partition (user-partition-parted-object
 258                        target-user-partition))
 259            (disk (partition-disk partition))
 260            (device (disk-device disk)))
 261       (list
 262        item
 263        (case item
 264          ((name)
 265           (let* ((old-name (user-partition-name target-user-partition))
 266                  (name
 267                   (run-input-page (G_ "Please enter the partition gpt name.")
 268                                   (G_ "Partition name")
 269                                   #:default-text old-name)))
 270             (user-partition
 271              (inherit target-user-partition)
 272              (name name))))
 273          ((type)
 274           (let ((new-type (run-type-page partition)))
 275             (user-partition
 276              (inherit target-user-partition)
 277              (type new-type))))
 278          ((bootable)
 279           (user-partition
 280            (inherit target-user-partition)
 281            (bootable? (not (user-partition-bootable?
 282                             target-user-partition)))))
 283          ((esp?)
 284           (let ((new-esp? (not (user-partition-esp?
 285                                 target-user-partition))))
 286             (user-partition
 287              (inherit target-user-partition)
 288              (esp? new-esp?)
 289              (mount-point (if new-esp?
 290                               (default-esp-mount-point)
 291                               "")))))
 292          ((crypt-label)
 293           (let* ((label (user-partition-crypt-label
 294                          target-user-partition))
 295                  (new-label
 296                   (and (not label)
 297                        (run-input-page
 298                         (G_ "Please enter the encrypted label")
 299                         (G_ "Encryption label")))))
 300             (user-partition
 301              (inherit target-user-partition)
 302              (need-formatting? #t)
 303              (crypt-label new-label))))
 304          ((need-formatting?)
 305           (user-partition
 306            (inherit target-user-partition)
 307            (need-formatting?
 308             (not (user-partition-need-formatting?
 309                   target-user-partition)))))
 310          ((size)
 311           (let* ((old-size (user-partition-size target-user-partition))
 312                  (max-size-value (partition-length partition))
 313                  (max-size (unit-format device max-size-value))
 314                  (start (partition-start partition))
 315                  (size (run-input-page
 316                         (format #f (G_ "Please enter the size of the partition.\
 317  The maximum size is ~a.") max-size)
 318                         (G_ "Partition size")
 319                         #:default-text (or old-size max-size)))
 320                  (size-percentage (read-percentage size))
 321                  (size-value (if size-percentage
 322                                  (nearest-exact-integer
 323                                   (/ (* max-size-value size-percentage)
 324                                      100))
 325                                  (numeric-size device size)))
 326                  (end (and size-value
 327                            (+ start size-value)))
 328                  (size-range (numeric-size-range device size))
 329                  (size-range-ok? (and size-range
 330                                       (< (+ start
 331                                             (geometry-start size-range))
 332                                          (partition-end partition)))))
 333             (cond
 334              ((and size-percentage (> size-percentage 100))
 335               (run-error-page
 336                (G_ "The percentage can not be superior to 100.")
 337                (G_ "Size error"))
 338               target-user-partition)
 339              ((not size-value)
 340               (run-error-page
 341                (G_ "The requested size is incorrectly formatted, or too large.")
 342                (G_ "Size error"))
 343               target-user-partition)
 344              ((not (or size-percentage size-range-ok?))
 345               (run-error-page
 346                (G_ "The request size is superior to the maximum size.")
 347                (G_ "Size error"))
 348               target-user-partition)
 349              (else
 350               (fill-user-partition-geom target-user-partition
 351                                         #:device device
 352                                         #:size size
 353                                         #:start start
 354                                         #:end end)))))
 355          ((fs-type)
 356           (let ((fs-type (run-fs-type-page)))
 357             (user-partition
 358              (inherit target-user-partition)
 359              (fs-type fs-type))))
 360          ((mount-point)
 361           (let* ((old-mount (or (user-partition-mount-point
 362                                  target-user-partition)
 363                                 ""))
 364                  (mount
 365                   (run-input-page
 366                    (G_ "Please enter the desired mounting point for this \
 367 partition. Leave this field empty if you don't want to set a mounting point.")
 368                    (G_ "Mounting point")
 369                    #:default-text old-mount
 370                    #:allow-empty-input? #t)))
 371             (user-partition
 372              (inherit target-user-partition)
 373              (mount-point (and (not (string=? mount ""))
 374                                mount)))))))))
 375
 376   (define (button-action)
 377     (let* ((partition (user-partition-parted-object
 378                        target-user-partition))
 379            (prev-part (partition-prev partition))
 380            (disk (partition-disk partition))
 381            (device (disk-device disk))
 382            (creation? (freespace-partition? partition))
 383            (start (partition-start partition))
 384            (end (partition-end partition))
 385            (new-user-partition
 386             (if (user-partition-start target-user-partition)
 387                 target-user-partition
 388                 (fill-user-partition-geom target-user-partition
 389                                           #:device device
 390                                           #:start start
 391                                           #:end end))))
 392       ;; It the backend PARTITION has free-space type, it means we are
 393       ;; creating a new partition, otherwise, we are editing an already
 394       ;; existing PARTITION.
 395       (if creation?
 396           (let* ((ok-create-partition?
 397                   (inform-can-create-partition? new-user-partition))
 398                  (new-partition
 399                   (and ok-create-partition?
 400                        (mkpart disk
 401                                new-user-partition
 402                                #:previous-partition prev-part))))
 403             (and new-partition
 404                  (user-partition
 405                   (inherit new-user-partition)
 406                   (need-formatting? #t)
 407                   (file-name (partition-get-path new-partition))
 408                   (disk-file-name (device-path device))
 409                   (parted-object new-partition))))
 410           (and (apply-user-partition-changes new-user-partition)
 411                new-user-partition))))
 412
 413   (let* ((items (user-partition-description target-user-partition))
 414          (partition (user-partition-parted-object
 415                      target-user-partition))
 416          (disk (partition-disk partition))
 417          (device (disk-device disk))
 418          (file-name (device-path device))
 419          (number-str (partition-print-number partition))
 420          (type (user-partition-type target-user-partition))
 421          (type-str (symbol->string type))
 422          (start (unit-format device (partition-start partition)))
 423          (creation? (freespace-partition? partition))
 424          (default-item (and default-item
 425                             (find (lambda (item)
 426                                     (eq? (car item) default-item))
 427                                   items)))
 428          (result
 429           (run-listbox-selection-page
 430            #:info-text
 431            (if creation?
 432                (format #f (G_ "Creating ~a partition starting at ~a of ~a.")
 433                        type-str start file-name)
 434                (format #f (G_ "You are currently editing partition ~a.")
 435                        number-str))
 436            #:title (if creation?
 437                        (G_ "Partition creation")
 438                        (G_ "Partition edit"))
 439            #:listbox-items items
 440            #:listbox-item->text cdr
 441            #:sort-listbox-items? #f
 442            #:listbox-default-item default-item
 443            #:button-text (G_ "OK")
 444            #:listbox-callback-procedure listbox-action
 445            #:button-callback-procedure button-action)))
 446     (match result
 447       ((item new-user-partition)
 448        (run-partition-page new-user-partition
 449                            #:default-item item))
 450       (else result))))
 451
 452 (define* (run-disk-page disks
 453                         #:optional (user-partitions '())
 454                         #:key (guided? #f))
 455   "Run a page allowing to edit the partition tables of the given DISKS. If
 456 specified, USER-PARTITIONS is a list of <user-partition> records associated to
 457 the partitions on DISKS."
 458
 459   (define (other-logical-partitions? partitions)
 460     "Return #t if at least one of the partition in PARTITIONS list is a
 461 logical partition, return #f otherwise."
 462     (any logical-partition? partitions))
 463
 464   (define (other-non-logical-partitions? partitions)
 465     "Return #t is at least one of the partitions in PARTITIONS list is not a
 466 logical partition, return #f otherwise."
 467     (let ((non-logical-partitions
 468            (remove logical-partition? partitions)))
 469       (or (any normal-partition? non-logical-partitions)
 470           (any freespace-partition? non-logical-partitions))))
 471
 472   (define (add-tree-symbols partitions descriptions)
 473     "Concatenate tree symbols to the given DESCRIPTIONS list and return
 474 it. The PARTITIONS list is the list of partitions described in
 475 DESCRIPTIONS. The tree symbols are used to indicate the partition's disk and
 476 for logical partitions, the extended partition which includes them."
 477     (match descriptions
 478       (() '())
 479       ((description . rest-descriptions)
 480        (match partitions
 481          ((partition . rest-partitions)
 482           (if (null? rest-descriptions)
 483               (list (if (logical-partition? partition)
 484                         (string-append " ┗━ " description)
 485                         (string-append "┗━  " description)))
 486               (cons (cond
 487                      ((extended-partition? partition)
 488                       (if (other-non-logical-partitions? rest-partitions)
 489                           (string-append "┣┳  " description)
 490                           (string-append "┗┳  " description)))
 491                      ((logical-partition? partition)
 492                       (if (other-logical-partitions? rest-partitions)
 493                           (if (other-non-logical-partitions? rest-partitions)
 494                               (string-append "┃┣━ " description)
 495                               (string-append " ┣━ " description))
 496                           (if (other-non-logical-partitions? rest-partitions)
 497                               (string-append "┃┗━ " description)
 498                               (string-append " ┗━ " description))))
 499                      (else
 500                       (string-append "┣━  " description)))
 501                     (add-tree-symbols rest-partitions
 502                                       rest-descriptions))))))))
 503
 504   (define (skip-item? item)
 505     (eq? (car item) 'skip))
 506
 507   (define (disk-items)
 508     "Return the list of strings describing DISKS."
 509     (let loop ((disks disks))
 510       (match disks
 511         (() '())
 512         ((disk . rest)
 513          (let* ((device (disk-device disk))
 514                 (partitions (disk-partitions disk))
 515                 (partitions*
 516                  (filter-map
 517                   (lambda (partition)
 518                     (and (not (metadata-partition? partition))
 519                          (not (small-freespace-partition? device
 520                                                           partition))
 521                          partition))
 522                   partitions))
 523                 (descriptions (add-tree-symbols
 524                                partitions*
 525                                (partitions-descriptions partitions*
 526                                                         user-partitions)))
 527                 (partition-items (map cons partitions* descriptions)))
 528            (append
 529             `((,disk . ,(device-description device disk))
 530               ,@partition-items
 531               ,@(if (null? rest)
 532                     '()
 533                     '((skip . ""))))
 534             (loop rest)))))))
 535
 536   (define (remove-user-partition-by-partition user-partitions partition)
 537     "Return the USER-PARTITIONS list with the record with the given PARTITION
 538 object removed. If PARTITION is an extended partition, also remove all logical
 539 partitions from USER-PARTITIONS."
 540     (remove (lambda (p)
 541               (let ((cur-partition (user-partition-parted-object p)))
 542                 (or (equal? cur-partition partition)
 543                     (and (extended-partition? partition)
 544                          (logical-partition? cur-partition)))))
 545             user-partitions))
 546
 547   (define (remove-user-partition-by-disk user-partitions disk)
 548     "Return the USER-PARTITIONS list with the <user-partition> records located
 549 on given DISK removed."
 550     (remove (lambda (p)
 551               (let* ((partition (user-partition-parted-object p))
 552                      (cur-disk (partition-disk partition)))
 553                 (equal? cur-disk disk)))
 554             user-partitions))
 555
 556   (define (update-user-partitions user-partitions new-user-partition)
 557     "Update or insert NEW-USER-PARTITION record in USER-PARTITIONS list
 558 depending if one of the <user-partition> record in USER-PARTITIONS has the
 559 same PARTITION object as NEW-USER-PARTITION."
 560     (let* ((partition (user-partition-parted-object new-user-partition))
 561            (user-partitions*
 562             (remove-user-partition-by-partition user-partitions
 563                                                 partition)))
 564       (cons new-user-partition user-partitions*)))
 565
 566   (define (button-ok-action)
 567     "Commit the modifications to all DISKS and return #t."
 568     (for-each (lambda (disk)
 569                 (disk-commit disk))
 570               disks)
 571     #t)
 572
 573   (define (listbox-action listbox-item)
 574     "A disk or a partition has been selected. If it's a disk, ask for a label
 575 to create a new partition table. If it is a partition, propose the user to
 576 edit it."
 577     (let ((item (car listbox-item)))
 578       (cond
 579        ((disk? item)
 580         (let ((label (run-label-page (G_ "Back") (const #f))))
 581           (if label
 582               (let* ((device (disk-device item))
 583                      (new-disk (mklabel device label))
 584                      (commit-new-disk (disk-commit new-disk))
 585                      (other-disks (remove (lambda (disk)
 586                                             (equal? disk item))
 587                                           disks))
 588                      (new-user-partitions
 589                       (remove-user-partition-by-disk user-partitions item)))
 590                 (disk-destroy item)
 591                 `((disks . ,(cons new-disk other-disks))
 592                   (user-partitions . ,new-user-partitions)))
 593               `((disks . ,disks)
 594                 (user-partitions . ,user-partitions)))))
 595        ((partition? item)
 596         (let* ((partition item)
 597                (disk (partition-disk partition))
 598                (device (disk-device disk))
 599                (existing-user-partition
 600                 (find-user-partition-by-parted-object user-partitions
 601                                                       partition))
 602                (edit-user-partition
 603                 (or existing-user-partition
 604                     (partition->user-partition partition))))
 605           `((disks . ,disks)
 606             (user-partitions . ,user-partitions)
 607             (edit-user-partition . ,edit-user-partition)))))))
 608
 609   (define (hotkey-action key listbox-item)
 610     "The DELETE key has been pressed on a disk or a partition item."
 611     (let ((item (car listbox-item))
 612           (default-result
 613             `((disks . ,disks)
 614               (user-partitions . ,user-partitions))))
 615       (cond
 616        ((disk? item)
 617         (let* ((device (disk-device item))
 618                (file-name (device-path device))
 619                (info-text
 620                 (format #f (G_ "Are you sure you want to delete everything on disk ~a?")
 621                         file-name))
 622                (result (choice-window (G_ "Delete disk")
 623                                       (G_ "OK")
 624                                       (G_ "Exit")
 625                                       info-text)))
 626           (case result
 627             ((1)
 628              (disk-delete-all item)
 629              `((disks . ,disks)
 630                (user-partitions
 631                 . ,(remove-user-partition-by-disk user-partitions item))))
 632             (else
 633              default-result))))
 634        ((partition? item)
 635         (if (freespace-partition? item)
 636             (run-error-page (G_ "You cannot delete a free space area.")
 637                             (G_ "Delete partition"))
 638             (let* ((disk (partition-disk item))
 639                    (number-str (partition-print-number item))
 640                    (info-text
 641                     (format #f (G_ "Are you sure you want to delete partition ~a?")
 642                             number-str))
 643                    (result (choice-window (G_ "Delete partition")
 644                                           (G_ "OK")
 645                                           (G_ "Exit")
 646                                           info-text)))
 647               (case result
 648                 ((1)
 649                  (let ((new-user-partitions
 650                         (remove-user-partition-by-partition user-partitions
 651                                                             item)))
 652                    (disk-delete-partition disk item)
 653                    `((disks . ,disks)
 654                      (user-partitions . ,new-user-partitions))))
 655                 (else
 656                  default-result))))))))
 657
 658   (let* ((info-text (G_ "You can change a disk's partition table by \
 659 selecting it and pressing ENTER. You can also edit a partition by selecting it \
 660 and pressing ENTER, or remove it by pressing DELETE. To create a new \
 661 partition, select a free space area and press ENTER.
 662
 663 At least one partition must have its mounting point set to '/'."))
 664          (guided-info-text (format #f (G_ "This is the proposed \
 665 partitioning. It is still possible to edit it or to go back to install menu \
 666 by pressing the Exit button.~%~%")))
 667          (result
 668           (run-listbox-selection-page
 669            #:info-text (if guided?
 670                            (string-append guided-info-text info-text)
 671                            info-text)
 672
 673           #:title (if guided?
 674                       (G_ "Guided partitioning")
 675                       (G_ "Manual partitioning"))
 676           #:info-textbox-width 70
 677           #:listbox-items (disk-items)
 678           #:listbox-item->text cdr
 679           #:sort-listbox-items? #f
 680           #:skip-item-procedure? skip-item?
 681           #:allow-delete? #t
 682           #:button-text (G_ "OK")
 683           #:button-callback-procedure button-ok-action
 684           #:button2-text (G_ "Exit")
 685           #:button2-callback-procedure button-exit-action
 686           #:listbox-callback-procedure listbox-action
 687           #:hotkey-callback-procedure hotkey-action)))
 688     (if (eq? result #t)
 689         (let ((user-partitions-ok?
 690                (guard
 691                    (c ((no-root-mount-point? c)
 692                        (run-error-page
 693                         (G_ "No root mount point found.")
 694                         (G_ "Missing mount point"))
 695                        #f))
 696                  (check-user-partitions user-partitions))))
 697           (if user-partitions-ok?
 698               (begin
 699                 (for-each (cut disk-destroy <>) disks)
 700                 user-partitions)
 701               (run-disk-page disks user-partitions
 702                              #:guided? guided?)))
 703         (let* ((result-disks (assoc-ref result 'disks))
 704                (result-user-partitions (assoc-ref result
 705                                                   'user-partitions))
 706                (edit-user-partition (assoc-ref result
 707                                                'edit-user-partition))
 708                (can-create-partition?
 709                 (and edit-user-partition
 710                      (inform-can-create-partition? edit-user-partition)))
 711                (new-user-partition (and edit-user-partition
 712                                         can-create-partition?
 713                                         (run-partition-page
 714                                          edit-user-partition)))
 715                (new-user-partitions
 716                 (if new-user-partition
 717                     (update-user-partitions result-user-partitions
 718                                             new-user-partition)
 719                     result-user-partitions)))
 720           (run-disk-page result-disks new-user-partitions
 721                          #:guided? guided?)))))
 722
 723 (define (run-partioning-page)
 724   "Run a page asking the user for a partitioning method."
 725   (define (run-page devices)
 726     (let* ((items
 727             `((entire . ,(G_ "Guided - using the entire disk"))
 728               (entire-encrypted . ,(G_ "Guided - using the entire disk with encryption"))
 729               (manual . ,(G_ "Manual"))))
 730            (result (run-listbox-selection-page
 731                     #:info-text (G_ "Please select a partitioning method.")
 732                     #:title (G_ "Partitioning method")
 733                     #:listbox-items items
 734                     #:listbox-item->text cdr
 735                     #:button-text (G_ "Exit")
 736                     #:button-callback-procedure button-exit-action))
 737            (method (car result)))
 738       (cond
 739        ((or (eq? method 'entire)
 740             (eq? method 'entire-encrypted))
 741          (let* ((device (run-device-page devices))
 742                 (disk-type (disk-probe device))
 743                 (disk (if disk-type
 744                           (disk-new device)
 745                           (let* ((label (run-label-page
 746                                          (G_ "Exit")
 747                                          button-exit-action))
 748                                  (disk (mklabel device label)))
 749                             (disk-commit disk)
 750                             disk)))
 751                 (scheme (symbol-append method '- (run-scheme-page)))
 752                 (user-partitions (append
 753                                   (auto-partition disk #:scheme scheme)
 754                                   (create-special-user-partitions
 755                                    (disk-partitions disk)))))
 756            (run-disk-page (list disk) user-partitions
 757                           #:guided? #t)))
 758        ((eq? method 'manual)
 759          (let* ((disks (filter-map disk-new devices))
 760                 (user-partitions (append-map
 761                                   create-special-user-partitions
 762                                   (map disk-partitions disks)))
 763                 (result-user-partitions (run-disk-page disks
 764                                                        user-partitions)))
 765            result-user-partitions)))))
 766
 767   (init-parted)
 768   (let* ((non-install-devices (non-install-devices))
 769          (user-partitions (run-page non-install-devices))
 770          (user-partitions-with-pass (prompt-luks-passwords
 771                                      user-partitions))
 772          (form (draw-formatting-page)))
 773     ;; Make sure the disks are not in use before proceeding to formatting.
 774     (free-parted non-install-devices)
 775     (format-user-partitions user-partitions-with-pass)
 776     (destroy-form-and-pop form)
 777     user-partitions))