installer: Add partitioning support.

* gnu/installer.scm (installer-steps): Add partitioning step.
* gnu/installer/newt.scm (newt-installer): Add partition-page field.
* gnu/installer/newt/partition.scm: New file.
* gnu/installer/parted.scm: New file.
* gnu/installer/record (installer): New partition-page field.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add new files.
* po/guix/POTFILES.in: Add new files.

4 files changed, 1924 insertions, 0 deletions

diff --git a/gnu/installer/newt.scm b/gnu/installer/newt.scm
index 3192e55b86..9d9212173d 100644
--- a/gnu/installer/newt.scm
+++ b/gnu/installer/newt.scm
@@ -25,6 +25,7 @@
   #:use-module (gnu installer newt locale)
   #:use-module (gnu installer newt menu)
   #:use-module (gnu installer newt network)
+  #:use-module (gnu installer newt partition)
   #:use-module (gnu installer newt services)
   #:use-module (gnu installer newt timezone)
   #:use-module (gnu installer newt user)
@@ -81,6 +82,9 @@
 (define (user-page)
   (run-user-page))
 
+(define (partition-page)
+  (run-partioning-page))
+
 (define (services-page)
   (run-services-page))
 
@@ -98,5 +102,6 @@
    (timezone-page timezone-page)
    (hostname-page hostname-page)
    (user-page user-page)
+   (partition-page partition-page)
    (services-page services-page)
    (welcome-page welcome-page)))
diff --git a/gnu/installer/newt/partition.scm b/gnu/installer/newt/partition.scm
new file mode 100644
index 0000000000..806337a9cb
--- /dev/null
+++ b/gnu/installer/newt/partition.scm
@@ -0,0 +1,706 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt partition)
+  #:use-module (gnu installer parted)
+  #:use-module (gnu installer steps)
+  #:use-module (gnu installer utils)
+  #:use-module (gnu installer newt page)
+  #:use-module (gnu installer newt utils)
+  #:use-module (guix i18n)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (newt)
+  #:use-module (parted)
+  #:export (run-partioning-page))
+
+(define (button-cancel-action)
+  "Raise the &installer-step-abort condition."
+  (raise
+   (condition
+    (&installer-step-abort))))
+
+(define (run-scheme-page)
+  "Run a page asking the user for a partitioning scheme."
+  (let* ((items
+          '((root . "Everything is one partition")
+            (root-home . "Separate /home partition")))
+         (result (run-listbox-selection-page
+                  #:info-text (G_ "Please select a partitioning scheme.")
+                  #:title (G_ "Partition scheme")
+                  #:listbox-items items
+                  #:listbox-item->text cdr
+                  #:button-text (G_ "Cancel")
+                  #:button-callback-procedure button-cancel-action)))
+    (car result)))
+
+(define (draw-formating-page)
+  "Draw a page to indicate partitions are being formated."
+  (draw-info-page
+   (format #f (G_ "Partition formating is in progress, please wait."))
+   (G_ "Preparing partitions")))
+
+(define (run-device-page devices)
+  "Run a page asking the user to select a device among those in the given
+DEVICES list."
+  (define (device-items)
+    (map (lambda (device)
+           `(,device . ,(device-description device)))
+         devices))
+
+  (let* ((result (run-listbox-selection-page
+                  #:info-text (G_ "Please select a disk.")
+                  #:title (G_ "Disk")
+                  #:listbox-items (device-items)
+                  #:listbox-item->text cdr
+                  #:button-text (G_ "Cancel")
+                  #:button-callback-procedure button-cancel-action))
+         (device (car result)))
+    device))
+
+(define (run-label-page button-callback)
+  "Run a page asking the user to select a partition table label."
+  (run-listbox-selection-page
+   #:info-text (G_ "Select a new partition table type. \
+Be careful, all data on the disk will be lost.")
+   #:title (G_ "Partition table")
+   #:listbox-items '("msdos" "gpt")
+   #:listbox-item->text identity
+   #:button-text (G_ "Cancel")
+   #:button-callback-procedure button-callback))
+
+(define (run-type-page partition)
+  "Run a page asking the user to select a partition type."
+  (let* ((disk (partition-disk partition))
+         (partitions (disk-partitions disk))
+         (other-extended-partitions?
+          (any extended-partition? partitions))
+         (items
+          `(normal ,@(if other-extended-partitions?
+                         '()
+                         '(extended)))))
+    (run-listbox-selection-page
+     #:info-text (G_ "Please select a partition type")
+     #:title (G_ "Partition type")
+     #:listbox-items items
+     #:listbox-item->text symbol->string
+     #:sort-listbox-items? #f
+     #:button-text (G_ "Cancel")
+     #:button-callback-procedure button-cancel-action)))
+
+(define (run-fs-type-page)
+  "Run a page asking the user to select a file-system type."
+  (run-listbox-selection-page
+   #:info-text (G_ "Please select the file-system type for this partition")
+   #:title (G_ "File-system type")
+   #:listbox-items '(ext4 btrfs fat32 swap)
+   #:listbox-item->text user-fs-type-name
+   #:sort-listbox-items? #f
+   #:button-text (G_ "Cancel")
+   #:button-callback-procedure button-cancel-action))
+
+(define (inform-can-create-partition? user-partition)
+  "Return #t if it is possible to create USER-PARTITION. This is determined by
+calling CAN-CREATE-PARTITION? procedure. If an exception is raised, catch it
+an inform the user with an appropriate error-page and return #f."
+  (guard (c ((max-primary-exceeded? c)
+            (run-error-page
+             (G_ "Primary partitions count exceeded")
+             (G_ "Creation error"))
+            #f)
+           ((extended-creation-error? c)
+            (run-error-page
+             (G_ "Extended partition creation error")
+             (G_ "Creation error"))
+            #f)
+           ((logical-creation-error? c)
+            (run-error-page
+             (G_ "Logical partition creation error")
+             (G_ "Creation error"))
+            #f))
+    (can-create-partition? user-partition)))
+
+(define* (run-partition-page target-user-partition
+                             #:key
+                             (default-item #f))
+  "Run a page allowing the user to edit the given TARGET-USER-PARTITION
+record. If the argument DEFAULT-ITEM is passed, use it to select the current
+listbox item. This is used to avoid the focus to switch back to the first
+listbox entry while calling this procedure recursively."
+
+  (define (numeric-size device size)
+    "Parse the given SIZE on DEVICE and return it."
+    (call-with-values
+        (lambda ()
+          (unit-parse size device))
+      (lambda (value range)
+        value)))
+
+  (define (numeric-size-range device size)
+    "Parse the given SIZE on DEVICE and return the associated RANGE."
+    (call-with-values
+        (lambda ()
+          (unit-parse size device))
+      (lambda (value range)
+        range)))
+
+  (define* (fill-user-partition-geom user-part
+                                     #:key
+                                     device (size #f) start end)
+    "Return the given USER-PART with the START, END and SIZE fields set to the
+eponym arguments. Use UNIT-FORMAT-CUSTOM to format START and END arguments as
+sectors on DEVICE."
+    (user-partition
+     (inherit user-part)
+     (size size)
+     (start (unit-format-custom device start UNIT-SECTOR))
+     (end (unit-format-custom device end UNIT-SECTOR))))
+
+  (define (apply-user-partition-changes user-part)
+    "Set the name, file-system type and boot flag on the partition specified
+by USER-PART, if it is applicable for the partition type."
+    (let* ((partition (user-partition-parted-object user-part))
+           (disk (partition-disk partition))
+           (disk-type (disk-disk-type disk))
+           (device (disk-device disk))
+           (has-name? (disk-type-check-feature
+                       disk-type
+                       DISK-TYPE-FEATURE-PARTITION-NAME))
+           (name (user-partition-name user-part))
+           (fs-type (filesystem-type-get
+                     (user-fs-type-name
+                      (user-partition-fs-type user-part))))
+           (bootable? (user-partition-bootable? user-part))
+           (esp? (user-partition-esp? user-part))
+           (flag-bootable?
+            (partition-is-flag-available? partition PARTITION-FLAG-BOOT))
+           (flag-esp?
+            (partition-is-flag-available? partition PARTITION-FLAG-ESP)))
+      (when (and has-name? name)
+        (partition-set-name partition name))
+      (partition-set-system partition fs-type)
+      (when flag-bootable?
+        (partition-set-flag partition
+                            PARTITION-FLAG-BOOT
+                            (if bootable? 1 0)))
+      (when flag-esp?
+        (partition-set-flag partition
+                            PARTITION-FLAG-ESP
+                            (if esp? 1 0)))
+      #t))
+
+  (define (listbox-action listbox-item)
+    (let* ((item (car listbox-item))
+           (partition (user-partition-parted-object
+                       target-user-partition))
+           (disk (partition-disk partition))
+           (device (disk-device disk)))
+      (list
+       item
+       (case item
+         ((name)
+          (let* ((old-name (user-partition-name target-user-partition))
+                 (name
+                  (run-input-page (G_ "Please enter the partition gpt name.")
+                                  (G_ "Partition name")
+                                  #:default-text old-name)))
+            (user-partition
+             (inherit target-user-partition)
+             (name name))))
+         ((type)
+          (let ((new-type (run-type-page partition)))
+            (user-partition
+             (inherit target-user-partition)
+             (type new-type))))
+         ((bootable)
+          (user-partition
+           (inherit target-user-partition)
+           (bootable? (not (user-partition-bootable?
+                            target-user-partition)))))
+         ((esp?)
+          (let ((new-esp? (not (user-partition-esp?
+                                target-user-partition))))
+            (user-partition
+             (inherit target-user-partition)
+             (esp? new-esp?)
+             (mount-point (if new-esp?
+                              (default-esp-mount-point)
+                              "")))))
+         ((need-formating?)
+          (user-partition
+           (inherit target-user-partition)
+           (need-formating?
+            (not (user-partition-need-formating?
+                  target-user-partition)))))
+         ((size)
+          (let* ((old-size (user-partition-size target-user-partition))
+                 (max-size-value (partition-length partition))
+                 (max-size (unit-format device max-size-value))
+                 (start (partition-start partition))
+                 (size (run-input-page
+                        (format #f (G_ "Please enter the size of the partition.\
+ The maximum size is ~a.") max-size)
+                        (G_ "Partition size")
+                        #:default-text (or old-size max-size)))
+                 (size-percentage (read-percentage size))
+                 (size-value (if size-percentage
+                                 (nearest-exact-integer
+                                  (/ (* max-size-value size-percentage)
+                                     100))
+                                 (numeric-size device size)))
+                 (end (and size-value
+                           (+ start size-value)))
+                 (size-range (numeric-size-range device size))
+                 (size-range-ok? (and size-range
+                                      (< (+ start
+                                            (geometry-start size-range))
+                                         (partition-end partition)))))
+            (cond
+             ((and size-percentage (> size-percentage 100))
+              (run-error-page
+               (G_ "The percentage can not be superior to 100.")
+               (G_ "Size error"))
+              target-user-partition)
+             ((not size-value)
+              (run-error-page
+               (G_ "The requested size is incorrectly formatted, or too large.")
+               (G_ "Size error"))
+              target-user-partition)
+             ((not (or size-percentage size-range-ok?))
+              (run-error-page
+               (G_ "The request size is superior to the maximum size.")
+               (G_ "Size error"))
+              target-user-partition)
+             (else
+              (fill-user-partition-geom target-user-partition
+                                        #:device device
+                                        #:size size
+                                        #:start start
+                                        #:end end)))))
+         ((fs-type)
+          (let ((fs-type (run-fs-type-page)))
+            (user-partition
+             (inherit target-user-partition)
+             (fs-type fs-type))))
+         ((mount-point)
+          (let* ((old-mount (or (user-partition-mount-point
+                                 target-user-partition)
+                                ""))
+                 (mount
+                  (run-input-page
+                   (G_ "Please enter the desired mounting point for this \
+partition. Leave this field empty if you don't want to set a mounting point.")
+                   (G_ "Mounting point")
+                   #:default-text old-mount
+                   #:allow-empty-input? #t)))
+            (user-partition
+             (inherit target-user-partition)
+             (mount-point (and (not (string=? mount ""))
+                               mount)))))))))
+
+  (define (button-action)
+    (let* ((partition (user-partition-parted-object
+                       target-user-partition))
+           (prev-part (partition-prev partition))
+           (disk (partition-disk partition))
+           (device (disk-device disk))
+           (creation? (freespace-partition? partition))
+           (start (partition-start partition))
+           (end (partition-end partition))
+           (new-user-partition
+            (if (user-partition-start target-user-partition)
+                target-user-partition
+                (fill-user-partition-geom target-user-partition
+                                          #:device device
+                                          #:start start
+                                          #:end end))))
+      ;; It the backend PARTITION has free-space type, it means we are
+      ;; creating a new partition, otherwise, we are editing an already
+      ;; existing PARTITION.
+      (if creation?
+          (let* ((ok-create-partition?
+                  (inform-can-create-partition? new-user-partition))
+                 (new-partition
+                  (and ok-create-partition?
+                       (mkpart disk
+                               new-user-partition
+                               #:previous-partition prev-part))))
+            (and new-partition
+                 (user-partition
+                  (inherit new-user-partition)
+                  (need-formating? #t)
+                  (path (partition-get-path new-partition))
+                  (disk-path (device-path device))
+                  (parted-object new-partition))))
+          (and (apply-user-partition-changes new-user-partition)
+               new-user-partition))))
+
+  (let* ((items (user-partition-description target-user-partition))
+         (partition (user-partition-parted-object
+                     target-user-partition))
+         (disk (partition-disk partition))
+         (device (disk-device disk))
+         (path (device-path device))
+         (number-str (partition-print-number partition))
+         (type (user-partition-type target-user-partition))
+         (type-str (symbol->string type))
+         (start (unit-format device (partition-start partition)))
+         (creation? (freespace-partition? partition))
+         (default-item (and default-item
+                            (find (lambda (item)
+                                    (eq? (car item) default-item))
+                                  items)))
+         (result
+          (run-listbox-selection-page
+           #:info-text
+           (if creation?
+               (G_ (format #f "Creating ~a partition starting at ~a of ~a."
+                           type-str start path))
+               (G_ (format #f "You are currently editing partition ~a."
+                           number-str)))
+           #:title (if creation?
+                       (G_ "Partition creation")
+                       (G_ "Partition edit"))
+           #:listbox-items items
+           #:listbox-item->text cdr
+           #:sort-listbox-items? #f
+           #:listbox-default-item default-item
+           #:button-text (G_ "Ok")
+           #:listbox-callback-procedure listbox-action
+           #:button-callback-procedure button-action)))
+    (match result
+      ((item new-user-partition)
+       (run-partition-page new-user-partition
+                           #:default-item item))
+      (else result))))
+
+(define* (run-disk-page disks
+                        #:optional (user-partitions '()))
+  "Run a page allowing to edit the partition tables of the given DISKS. If
+specified, USER-PARTITIONS is a list of <user-partition> records associated to
+the partitions on DISKS."
+
+  (define (other-logical-partitions? partitions)
+    "Return #t if at least one of the partition in PARTITIONS list is a
+logical partition, return #f otherwise."
+    (any logical-partition? partitions))
+
+  (define (other-non-logical-partitions? partitions)
+    "Return #t is at least one of the partitions in PARTITIONS list is not a
+logical partition, return #f otherwise."
+    (let ((non-logical-partitions
+           (remove logical-partition? partitions)))
+      (or (any normal-partition? non-logical-partitions)
+          (any freespace-partition? non-logical-partitions))))
+
+  (define (add-tree-symbols partitions descriptions)
+    "Concatenate tree symbols to the given DESCRIPTIONS list and return
+it. The PARTITIONS list is the list of partitions described in
+DESCRIPTIONS. The tree symbols are used to indicate the partition's disk and
+for logical partitions, the extended partition which includes them."
+    (match descriptions
+      (() '())
+      ((description . rest-descriptions)
+       (match partitions
+         ((partition . rest-partitions)
+          (if (null? rest-descriptions)
+              (list (if (logical-partition? partition)
+                        (string-append " ┗━ " description)
+                        (string-append "┗━  " description)))
+              (cons (cond
+                     ((extended-partition? partition)
+                      (if (other-non-logical-partitions? rest-partitions)
+                          (string-append "┣┳  " description)
+                          (string-append "┗┳  " description)))
+                     ((logical-partition? partition)
+                      (if (other-logical-partitions? rest-partitions)
+                          (if (other-non-logical-partitions? rest-partitions)
+                              (string-append "┃┣━ " description)
+                              (string-append " ┣━ " description))
+                          (if (other-non-logical-partitions? rest-partitions)
+                              (string-append "┃┗━ " description)
+                              (string-append " ┗━ " description))))
+                     (else
+                      (string-append "┣━  " description)))
+                    (add-tree-symbols rest-partitions
+                                      rest-descriptions))))))))
+
+  (define (skip-item? item)
+    (eq? (car item) 'skip))
+
+  (define (disk-items)
+    "Return the list of strings describing DISKS."
+    (let loop ((disks disks))
+      (match disks
+        (() '())
+        ((disk . rest)
+         (let* ((device (disk-device disk))
+                (partitions (disk-partitions disk))
+                (partitions*
+                 (filter-map
+                  (lambda (partition)
+                    (and (not (metadata-partition? partition))
+                         (not (small-freespace-partition? device
+                                                          partition))
+                         partition))
+                  partitions))
+                (descriptions (add-tree-symbols
+                               partitions*
+                               (partitions-descriptions partitions*
+                                                        user-partitions)))
+                (partition-items (map cons partitions* descriptions)))
+           (append
+            `((,disk . ,(device-description device disk))
+              ,@partition-items
+              ,@(if (null? rest)
+                    '()
+                    '((skip . ""))))
+            (loop rest)))))))
+
+  (define (remove-user-partition-by-partition user-partitions partition)
+    "Return the USER-PARTITIONS list with the record with the given PARTITION
+object removed. If PARTITION is an extended partition, also remove all logical
+partitions from USER-PARTITIONS."
+    (remove (lambda (p)
+              (let ((cur-partition (user-partition-parted-object p)))
+                (or (equal? cur-partition partition)
+                    (and (extended-partition? partition)
+                         (logical-partition? cur-partition)))))
+            user-partitions))
+
+  (define (remove-user-partition-by-disk user-partitions disk)
+    "Return the USER-PARTITIONS list with the <user-partition> records located
+on given DISK removed."
+    (remove (lambda (p)
+              (let* ((partition (user-partition-parted-object p))
+                     (cur-disk (partition-disk partition)))
+                (equal? cur-disk disk)))
+            user-partitions))
+
+  (define (update-user-partitions user-partitions new-user-partition)
+    "Update or insert NEW-USER-PARTITION record in USER-PARTITIONS list
+depending if one of the <user-partition> record in USER-PARTITIONS has the
+same PARTITION object as NEW-USER-PARTITION."
+    (let* ((partition (user-partition-parted-object new-user-partition))
+           (user-partitions*
+            (remove-user-partition-by-partition user-partitions
+                                                partition)))
+      (cons new-user-partition user-partitions*)))
+
+  (define (button-ok-action)
+    "Commit the modifications to all DISKS and return #t."
+    (for-each (lambda (disk)
+                (disk-commit disk))
+              disks)
+    #t)
+
+  (define (listbox-action listbox-item)
+    "A disk or a partition has been selected. If it's a disk, ask for a label
+to create a new partition table. If it is a partition, propose the user to
+edit it."
+    (let ((item (car listbox-item)))
+      (cond
+       ((disk? item)
+        (let ((label (run-label-page (const #f))))
+          (if label
+              (let* ((device (disk-device item))
+                     (new-disk (mklabel device label))
+                     (commit-new-disk (disk-commit new-disk))
+                     (other-disks (remove (lambda (disk)
+                                            (equal? disk item))
+                                          disks))
+                     (new-user-partitions
+                      (remove-user-partition-by-disk user-partitions item)))
+                (disk-destroy item)
+                `((disks . ,(cons new-disk other-disks))
+                  (user-partitions . ,new-user-partitions)))
+              `((disks . ,disks)
+                (user-partitions . ,user-partitions)))))
+       ((partition? item)
+        (let* ((partition item)
+               (disk (partition-disk partition))
+               (device (disk-device disk))
+               (existing-user-partition
+                (find-user-partition-by-parted-object user-partitions
+                                                      partition))
+               (edit-user-partition
+                (or existing-user-partition
+                    (partition->user-partition partition))))
+          `((disks . ,disks)
+            (user-partitions . ,user-partitions)
+            (edit-user-partition . ,edit-user-partition)))))))
+
+  (define (hotkey-action key listbox-item)
+    "The DELETE key has been pressed on a disk or a partition item."
+    (let ((item (car listbox-item))
+          (default-result
+            `((disks . ,disks)
+              (user-partitions . ,user-partitions))))
+      (cond
+       ((disk? item)
+        (let* ((device (disk-device item))
+               (path (device-path device))
+               (info-text
+                (format #f (G_ "Are you sure you want to delete everything on disk ~a?")
+                        path))
+               (result (choice-window (G_ "Delete disk")
+                                      (G_ "Ok")
+                                      (G_ "Cancel")
+                                      info-text)))
+          (case result
+            ((1)
+             (disk-delete-all item)
+             `((disks . ,disks)
+               (user-partitions
+                . ,(remove-user-partition-by-disk user-partitions item))))
+            (else
+             default-result))))
+       ((partition? item)
+        (if (freespace-partition? item)
+            (run-error-page (G_ "You cannot delete a free space area.")
+                            (G_ "Delete partition"))
+            (let* ((disk (partition-disk item))
+                   (number-str (partition-print-number item))
+                   (info-text
+                    (format #f (G_ "Are you sure you want to delete partition ~a?")
+                            number-str))
+                   (result (choice-window (G_ "Delete partition")
+                                          (G_ "Ok")
+                                          (G_ "Cancel")
+                                          info-text)))
+              (case result
+                ((1)
+                 (let ((new-user-partitions
+                        (remove-user-partition-by-partition user-partitions
+                                                            item)))
+                   (disk-delete-partition disk item)
+                   `((disks . ,disks)
+                     (user-partitions . ,new-user-partitions))))
+                (else
+                 default-result))))))))
+
+  (let ((result
+         (run-listbox-selection-page
+
+          #:info-text (G_ "You can change a disk's partition table by \
+selecting it and pressing ENTER. You can also edit a partition by selecting it \
+and pressing ENTER, or remove it by pressing DELETE. To create a new \
+partition, select a free space area and press ENTER.
+
+At least one partition must have its mounting point set to '/'.")
+
+          #:title (G_ "Manual partitioning")
+          #:info-textbox-width 70
+          #:listbox-items (disk-items)
+          #:listbox-item->text cdr
+          #:sort-listbox-items? #f
+          #:skip-item-procedure? skip-item?
+          #:allow-delete? #t
+          #:button-text (G_ "Ok")
+          #:button-callback-procedure button-ok-action
+          #:button2-text (G_ "Cancel")
+          #:button2-callback-procedure button-cancel-action
+          #:listbox-callback-procedure listbox-action
+          #:hotkey-callback-procedure hotkey-action)))
+    (if (eq? result #t)
+        (let ((user-partitions-ok?
+               (guard
+                   (c ((no-root-mount-point? c)
+                       (run-error-page
+                        (G_ "No root mount point found")
+                        (G_ "Missing mount point"))
+                       #f))
+                 (check-user-partitions user-partitions))))
+          (if user-partitions-ok?
+              (begin
+                (for-each (cut disk-destroy <>) disks)
+                user-partitions)
+              (run-disk-page disks user-partitions)))
+        (let* ((result-disks (assoc-ref result 'disks))
+               (result-user-partitions (assoc-ref result
+                                                  'user-partitions))
+               (edit-user-partition (assoc-ref result
+                                               'edit-user-partition))
+               (can-create-partition?
+                (and edit-user-partition
+                     (inform-can-create-partition? edit-user-partition)))
+               (new-user-partition (and edit-user-partition
+                                        can-create-partition?
+                                        (run-partition-page
+                                         edit-user-partition)))
+               (new-user-partitions
+                (if new-user-partition
+                    (update-user-partitions result-user-partitions
+                                            new-user-partition)
+                    result-user-partitions)))
+          (run-disk-page result-disks new-user-partitions)))))
+
+(define (run-partioning-page)
+  "Run a page asking the user for a partitioning method."
+  (define (run-page devices)
+    (let* ((items
+            '((entire . "Guided - using the entire disk")
+              (manual . "Manual")))
+           (result (run-listbox-selection-page
+                    #:info-text (G_ "Please select a partitioning method.")
+                    #:title (G_ "Partitioning method")
+                    #:listbox-items items
+                    #:listbox-item->text cdr
+                    #:button-text (G_ "Cancel")
+                    #:button-callback-procedure button-cancel-action))
+           (method (car result)))
+      (case method
+        ((entire)
+         (let* ((device (run-device-page devices))
+                (disk-type (disk-probe device))
+                (disk (if disk-type
+                          (disk-new device)
+                          (let* ((label (run-label-page
+                                         button-cancel-action))
+                                 (disk (mklabel device label)))
+                            (disk-commit disk)
+                            disk)))
+                (scheme (symbol-append method '- (run-scheme-page)))
+                (user-partitions (append
+                                  (auto-partition disk #:scheme scheme)
+                                  (create-special-user-partitions
+                                   (disk-partitions disk)))))
+           (run-disk-page (list disk) user-partitions)))
+        ((manual)
+         (let* ((disks (map disk-new devices))
+                (user-partitions (append-map
+                                  create-special-user-partitions
+                                  (map disk-partitions disks)))
+                (result-user-partitions (run-disk-page disks
+                                                       user-partitions)))
+           result-user-partitions)))))
+
+  (init-parted)
+  (let* ((non-install-devices (non-install-devices))
+         (user-partitions (run-page non-install-devices))
+         (form (draw-formating-page)))
+    ;; Make sure the disks are not in use before proceeding to formating.
+    (free-parted non-install-devices)
+    (run-error-page (format #f "~a" user-partitions)
+                    "user-partitions")
+    (format-user-partitions user-partitions)
+    (destroy-form-and-pop form)
+    user-partitions))
diff --git a/gnu/installer/parted.scm b/gnu/installer/parted.scm
new file mode 100644
index 0000000000..3fe938124f
--- /dev/null
+++ b/gnu/installer/parted.scm
@@ -0,0 +1,1210 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer parted)
+  #:use-module (gnu installer steps)
+  #:use-module (gnu installer utils)
+  #:use-module (gnu installer newt page)
+  #:use-module (gnu system uuid)
+  #:use-module ((gnu build file-systems)
+                #:select (read-partition-uuid))
+  #:use-module (guix build syscalls)
+  #:use-module (guix build utils)
+  #:use-module (guix records)
+  #:use-module (guix i18n)
+  #:use-module (parted)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:export (<user-partition>
+            user-partition
+            make-user-partition
+            user-partition?
+            user-partition-name
+            user-partition-type
+            user-partition-path
+            user-partition-disk-path
+            user-partition-fs-type
+            user-partition-bootable?
+            user-partition-esp?
+            user-partition-bios-grub?
+            user-partition-size
+            user-partition-start
+            user-partition-end
+            user-partition-mount-point
+            user-partition-need-formating?
+            user-partition-parted-object
+
+            find-esp-partition
+            data-partition?
+            metadata-partition?
+            freespace-partition?
+            small-freespace-partition?
+            normal-partition?
+            extended-partition?
+            logical-partition?
+            esp-partition?
+            boot-partition?
+            default-esp-mount-point
+
+            with-delay-device-in-use?
+            force-device-sync
+            non-install-devices
+            partition-user-type
+            user-fs-type-name
+            partition-filesystem-user-type
+            partition-get-flags
+            partition->user-partition
+            create-special-user-partitions
+            find-user-partition-by-parted-object
+
+            device-description
+            partition-end-formatted
+            partition-print-number
+            partition-description
+            partitions-descriptions
+            user-partition-description
+
+            &max-primary-exceeded
+            max-primary-exceeded?
+            &extended-creation-error
+            extended-creation-error?
+            &logical-creation-error
+            logical-creation-error?
+
+            can-create-partition?
+            mklabel
+            mkpart
+            rmpart
+
+            create-adjacent-partitions
+            auto-partition
+
+            &no-root-mount-point
+            no-root-mount-point?
+
+            check-user-partitions
+            set-user-partitions-path
+            format-user-partitions
+            mount-user-partitions
+            umount-user-partitions
+            with-mounted-partitions
+            user-partitions->file-systems
+            user-partitions->configuration
+
+            init-parted
+            free-parted))
+
+
+;;;
+;;; Partition record.
+;;;
+
+(define-record-type* <user-partition>
+  user-partition make-user-partition
+  user-partition?
+  (name                 user-partition-name ;string
+                        (default #f))
+  (type                 user-partition-type
+                        (default 'normal)) ; 'normal | 'logical | 'extended
+  (path                 user-partition-path
+                        (default #f))
+  (disk-path            user-partition-disk-path
+                        (default #f))
+  (fs-type              user-partition-fs-type
+                        (default 'ext4))
+  (bootable?            user-partition-bootable?
+                        (default #f))
+  (esp?                 user-partition-esp?
+                        (default #f))
+  (bios-grub?           user-partition-bios-grub?
+                        (default #f))
+  (size                 user-partition-size
+                        (default #f))
+  (start                user-partition-start ;start as string (e.g. '11MB')
+                        (default #f))
+  (end                  user-partition-end ;same as start
+                        (default #f))
+  (mount-point          user-partition-mount-point ;string
+                        (default #f))
+  (need-formating?      user-partition-need-formating? ; boolean
+                        (default #f))
+  (parted-object        user-partition-parted-object ; <partition> from parted
+                        (default #f)))
+
+
+;;
+;; Utilities.
+;;
+
+(define (find-esp-partition partitions)
+  "Find and return the ESP partition among PARTITIONS."
+  (find esp-partition? partitions))
+
+(define (data-partition? partition)
+  "Return #t if PARTITION is a partition dedicated to data (by opposition to
+freespace, metadata and protected partition types), return #f otherwise."
+  (let ((type (partition-type partition)))
+    (not (any (lambda (flag)
+                (member flag type))
+              '(free-space metadata protected)))))
+
+(define (metadata-partition? partition)
+  "Return #t if PARTITION is a metadata partition, #f otherwise."
+  (let ((type (partition-type partition)))
+    (member 'metadata type)))
+
+(define (freespace-partition? partition)
+  "Return #t if PARTITION is a free-space partition, #f otherwise."
+  (let ((type (partition-type partition)))
+    (member 'free-space type)))
+
+(define* (small-freespace-partition? device
+                                     partition
+                                     #:key (max-size MEBIBYTE-SIZE))
+  "Return #t is PARTITION is a free-space partition with less a size strictly
+inferior to MAX-SIZE, #f otherwise."
+  (let ((size (partition-length partition))
+        (max-sector-size (/ max-size
+                            (device-sector-size device))))
+    (< size max-sector-size)))
+
+(define (normal-partition? partition)
+  "return #t if partition is a normal partition, #f otherwise."
+  (let ((type (partition-type partition)))
+    (member 'normal type)))
+
+(define (extended-partition? partition)
+  "return #t if partition is an extended partition, #f otherwise."
+  (let ((type (partition-type partition)))
+    (member 'extended type)))
+
+(define (logical-partition? partition)
+  "Return #t if PARTITION is a logical partition, #f otherwise."
+  (let ((type (partition-type partition)))
+    (member 'logical type)))
+
+(define (partition-user-type partition)
+  "Return the type of PARTITION, to be stored in the TYPE field of
+<user-partition> record. It can be 'normal, 'extended or 'logical."
+  (cond ((normal-partition? partition)
+         'normal)
+        ((extended-partition? partition)
+         'extended)
+        ((logical-partition? partition)
+         'logical)
+        (else #f)))
+
+(define (esp-partition? partition)
+  "Return #t if partition has the ESP flag, return #f otherwise."
+  (let* ((disk (partition-disk partition))
+         (disk-type (disk-disk-type disk))
+         (has-extended? (disk-type-check-feature
+                         disk-type
+                         DISK-TYPE-FEATURE-EXTENDED)))
+    (and (data-partition? partition)
+         (not has-extended?)
+         (partition-is-flag-available? partition PARTITION-FLAG-ESP)
+         (partition-get-flag partition PARTITION-FLAG-ESP))))
+
+(define (boot-partition? partition)
+  "Return #t if partition has the boot flag, return #f otherwise."
+  (and (data-partition? partition)
+       (partition-is-flag-available? partition PARTITION-FLAG-BOOT)
+       (partition-get-flag partition PARTITION-FLAG-BOOT)))
+
+
+;; The default mount point for ESP partitions.
+(define default-esp-mount-point
+  (make-parameter "/boot/efi"))
+
+(define (efi-installation?)
+  "Return #t if an EFI installation should be performed, #f otherwise."
+  (file-exists? "/sys/firmware/efi"))
+
+(define (user-fs-type-name fs-type)
+  "Return the name of FS-TYPE as specified by libparted."
+  (case fs-type
+    ((ext4)  "ext4")
+    ((btrfs) "btrfs")
+    ((fat32) "fat32")
+    ((swap)  "linux-swap")))
+
+(define (user-fs-type->mount-type fs-type)
+  "Return the mount type of FS-TYPE."
+  (case fs-type
+    ((ext4)  "ext4")
+    ((btrfs) "btrfs")
+    ((fat32) "vfat")))
+
+(define (partition-filesystem-user-type partition)
+  "Return the filesystem type of PARTITION, to be stored in the FS-TYPE field
+of <user-partition> record."
+  (let ((fs-type (partition-fs-type partition)))
+    (and fs-type
+         (let ((name (filesystem-type-name fs-type)))
+           (cond
+            ((string=? name "ext4") 'ext4)
+            ((string=? name "btrfs") 'btrfs)
+            ((string=? name "fat32") 'fat32)
+            ((or (string=? name "swsusp")
+                 (string=? name "linux-swap(v0)")
+                 (string=? name "linux-swap(v1)"))
+             'swap)
+            (else
+             (error (format #f "Unhandled ~a fs-type~%" name))))))))
+
+(define (partition-get-flags partition)
+  "Return the list of flags supported by the given PARTITION."
+  (filter-map (lambda (flag)
+                (and (partition-get-flag partition flag)
+                     flag))
+              (partition-flags partition)))
+
+(define (partition->user-partition partition)
+  "Convert PARTITION into a <user-partition> record and return it."
+  (let* ((disk (partition-disk partition))
+         (device (disk-device disk))
+         (disk-type (disk-disk-type disk))
+         (has-name? (disk-type-check-feature
+                     disk-type
+                     DISK-TYPE-FEATURE-PARTITION-NAME))
+         (name (and has-name?
+                    (data-partition? partition)
+                    (partition-get-name partition))))
+    (user-partition
+     (name (and (and name
+                     (not (string=? name "")))
+                name))
+     (type (or (partition-user-type partition)
+               'normal))
+     (path (partition-get-path partition))
+     (disk-path (device-path device))
+     (fs-type (or (partition-filesystem-user-type partition)
+                  'ext4))
+     (mount-point (and (esp-partition? partition)
+                       (default-esp-mount-point)))
+     (bootable? (boot-partition? partition))
+     (esp? (esp-partition? partition))
+     (parted-object partition))))
+
+(define (create-special-user-partitions partitions)
+  "Return a list with a <user-partition> record describing the ESP partition
+found in PARTITIONS, if any."
+  (filter-map (lambda (partition)
+                (and (esp-partition? partition)
+                     (partition->user-partition partition)))
+              partitions))
+
+(define (find-user-partition-by-parted-object user-partitions
+                                              partition)
+  "Find and return the <user-partition> record in USER-PARTITIONS list which
+PARTED-OBJECT field equals PARTITION, return #f if not found."
+  (find (lambda (user-partition)
+          (equal? (user-partition-parted-object user-partition)
+                  partition))
+        user-partitions))
+
+
+;;
+;; Devices
+;;
+
+(define (with-delay-device-in-use? path)
+  "Call DEVICE-IN-USE? with a few retries, as the first re-read will often
+fail. See rereadpt function in wipefs.c of util-linux for an explanation."
+  (let loop ((try 4))
+    (usleep 250000)
+    (let ((in-use? (device-in-use? path)))
+      (if (and in-use? (> try 0))
+          (loop (- try 1))
+          in-use?))))
+
+(define* (force-device-sync device)
+  "Force a flushing of the given DEVICE."
+  (device-open device)
+  (device-sync device)
+  (device-close device))
+
+(define (non-install-devices)
+  "Return all the available devices, except the busy one, allegedly the
+install device. DEVICE-IS-BUSY? is a parted call, checking if the device is
+mounted. The install image uses an overlayfs so the install device does not
+appear as mounted and won't be considered as busy. So use also DEVICE-IN-USE?
+from (guix build syscalls) module, who will try to re-read the device's
+partition table to determine whether or not it is already used (like sfdisk
+from util-linux)."
+  (remove (lambda (device)
+            (let ((path (device-path device)))
+              (or (device-is-busy? device)
+                  (with-delay-device-in-use? path))))
+          (devices)))
+
+
+;;
+;; Disk and partition printing.
+;;
+
+(define* (device-description device #:optional disk)
+  "Return a string describing the given DEVICE."
+  (let* ((type (device-type device))
+         (path (device-path device))
+         (model (device-model device))
+         (type-str (device-type->string type))
+         (disk-type (if disk
+                        (disk-disk-type disk)
+                        (disk-probe device)))
+         (length (device-length device))
+         (sector-size (device-sector-size device))
+         (end (unit-format-custom-byte device
+                                       (* length sector-size)
+                                       UNIT-GIGABYTE)))
+    (string-join
+     `(,@(if (string=? model "")
+             `(,type-str)
+             `(,model ,(string-append "(" type-str ")")))
+       ,path
+       ,end
+       ,@(if disk-type
+             `(,(disk-type-name disk-type))
+             '()))
+     " ")))
+
+(define (partition-end-formatted device partition)
+  "Return as a string the end of PARTITION with the relevant unit."
+  (unit-format-byte
+   device
+   (-
+    (* (+ (partition-end partition) 1)
+       (device-sector-size device))
+    1)))
+
+(define (partition-print-number partition)
+  "Convert the given partition NUMBER to string."
+  (let ((number (partition-number partition)))
+    (number->string number)))
+
+(define (partition-description partition user-partition)
+  "Return a string describing the given PARTITION, located on the DISK of
+DEVICE."
+
+  (define (partition-print-type partition)
+    "Return the type of PARTITION as a string."
+    (if (freespace-partition? partition)
+        (G_ "Free space")
+        (let ((type (partition-type partition)))
+          (match type
+            ((type-symbol)
+             (symbol->string type-symbol))))))
+
+  (define (partition-print-flags partition)
+    "Return the flags of PARTITION as a string of comma separated flags."
+    (string-join
+     (filter-map
+      (lambda (flag)
+        (and (partition-get-flag partition flag)
+             (partition-flag-get-name flag)))
+      (partition-flags partition))
+     ","))
+
+  (define (maybe-string-pad string length)
+    "Returned a string formatted by padding STRING of LENGTH characters to the
+right. If STRING is #f use an empty string."
+    (string-pad-right (or string "") length))
+
+  (let* ((disk (partition-disk partition))
+         (device (disk-device disk))
+         (disk-type (disk-disk-type disk))
+         (has-name? (disk-type-check-feature
+                     disk-type
+                     DISK-TYPE-FEATURE-PARTITION-NAME))
+         (has-extended? (disk-type-check-feature
+                         disk-type
+                         DISK-TYPE-FEATURE-EXTENDED))
+         (part-type (partition-print-type partition))
+         (number (and (not (freespace-partition? partition))
+                      (partition-print-number partition)))
+         (name (and has-name?
+                    (if (freespace-partition? partition)
+                        (G_ "Free space")
+                        (partition-get-name partition))))
+         (start (unit-format device
+                             (partition-start partition)))
+         (end (partition-end-formatted device partition))
+         (size (unit-format device (partition-length partition)))
+         (fs-type (partition-fs-type partition))
+         (fs-type-name (and fs-type
+                            (filesystem-type-name fs-type)))
+         (flags (and (not (freespace-partition? partition))
+                     (partition-print-flags partition)))
+         (mount-point (and user-partition
+                           (user-partition-mount-point user-partition))))
+    `(,(or number "")
+      ,@(if has-extended?
+            (list part-type)
+            '())
+      ,size
+      ,(or fs-type-name "")
+      ,(or flags "")
+      ,(or mount-point "")
+      ,(maybe-string-pad name 30))))
+
+(define (partitions-descriptions partitions user-partitions)
+  "Return a list of strings describing all the partitions found on
+DEVICE. METADATA partitions are not described. The strings are padded to the
+right so that they can be displayed as a table."
+
+  (define (max-length-column lists column-index)
+    "Return the maximum length of the string at position COLUMN-INDEX in the
+list of string lists LISTS."
+    (apply max
+           (map (lambda (list)
+                  (string-length
+                   (list-ref list column-index)))
+                lists)))
+
+  (define (pad-descriptions descriptions)
+    "Return a padded version of the list of string lists DESCRIPTIONS. The
+strings are padded to the length of the longer string in a same column, as
+determined by MAX-LENGTH-COLUMN procedure."
+    (let* ((description-length (length (car descriptions)))
+           (paddings (map (lambda (index)
+                            (max-length-column descriptions index))
+                          (iota description-length))))
+      (map (lambda (description)
+             (map string-pad-right description paddings))
+           descriptions)))
+
+  (let* ((descriptions
+          (map
+           (lambda (partition)
+             (let ((user-partition
+                    (find-user-partition-by-parted-object user-partitions
+                                                          partition)))
+               (partition-description partition user-partition)))
+           partitions))
+         (padded-descriptions (if (null? partitions)
+                                  '()
+                                  (pad-descriptions descriptions))))
+    (map (cut string-join <> " ") padded-descriptions)))
+
+(define (user-partition-description user-partition)
+  "Return a string describing the given USER-PARTITION record."
+  (let* ((partition (user-partition-parted-object user-partition))
+         (disk (partition-disk partition))
+         (disk-type (disk-disk-type disk))
+         (device (disk-device disk))
+         (has-name? (disk-type-check-feature
+                     disk-type
+                     DISK-TYPE-FEATURE-PARTITION-NAME))
+         (has-extended? (disk-type-check-feature
+                         disk-type
+                         DISK-TYPE-FEATURE-EXTENDED))
+         (name (user-partition-name user-partition))
+         (type (user-partition-type user-partition))
+         (type-name (symbol->string type))
+         (fs-type (user-partition-fs-type user-partition))
+         (fs-type-name (user-fs-type-name fs-type))
+         (bootable? (user-partition-bootable? user-partition))
+         (esp? (user-partition-esp? user-partition))
+         (need-formating? (user-partition-need-formating? user-partition))
+         (size (user-partition-size user-partition))
+         (mount-point (user-partition-mount-point user-partition)))
+    `(,@(if has-name?
+            `((name . ,(string-append "Name: " (or name "None"))))
+            '())
+      ,@(if (and has-extended?
+                 (freespace-partition? partition)
+                 (not (eq? type 'logical)))
+            `((type . ,(string-append "Type: " type-name)))
+            '())
+      ,@(if (eq? type 'extended)
+            '()
+            `((fs-type . ,(string-append "Filesystem type: " fs-type-name))))
+      ,@(if (or (eq? type 'extended)
+                (eq? fs-type 'swap)
+                (not has-extended?))
+            '()
+            `((bootable . ,(string-append "Bootable flag: "
+                                          (if bootable? "On" "Off")))))
+      ,@(if (and (not has-extended?)
+                 (not (eq? fs-type 'swap)))
+            `((esp? . ,(string-append "ESP flag: "
+                                      (if esp? "On" "Off"))))
+            '())
+      ,@(if (freespace-partition? partition)
+            (let ((size-formatted
+                   (or size (unit-format device
+                                         (partition-length partition)))))
+              `((size . ,(string-append "Size : " size-formatted))))
+            '())
+      ,@(if (or (freespace-partition? partition)
+                (eq? fs-type 'swap))
+            '()
+            `((need-formating?
+               . ,(string-append "Format the partition? : "
+                                 (if need-formating? "Yes" "No")))))
+      ,@(if (or (eq? type 'extended)
+                (eq? fs-type 'swap))
+            '()
+            `((mount-point
+               . ,(string-append "Mount point : "
+                                 (or mount-point
+                                     (and esp? (default-esp-mount-point))
+                                     "None"))))))))
+
+
+;;
+;; Partition table creation.
+;;
+
+(define (mklabel device type-name)
+  "Create a partition table on DEVICE. TYPE-NAME is the type of the partition
+table, \"msdos\" or \"gpt\"."
+  (let ((type (disk-type-get type-name)))
+    (disk-new-fresh device type)))
+
+
+;;
+;; Partition creation.
+;;
+
+;; The maximum count of primary partitions is exceeded.
+(define-condition-type &max-primary-exceeded &condition
+  max-primary-exceeded?)
+
+;; It is not possible to create an extended partition.
+(define-condition-type &extended-creation-error &condition
+  extended-creation-error?)
+
+;; It is not possible to create a logical partition.
+(define-condition-type &logical-creation-error &condition
+  logical-creation-error?)
+
+(define (can-create-primary? disk)
+  "Return #t if it is possible to create a primary partition on DISK, return
+#f otherwise."
+  (let ((max-primary (disk-get-max-primary-partition-count disk)))
+    (find (lambda (number)
+            (not (disk-get-partition disk number)))
+          (iota max-primary 1))))
+
+(define (can-create-extended? disk)
+  "Return #t if it is possible to create an extended partition on DISK, return
+#f otherwise."
+  (let* ((disk-type (disk-disk-type disk))
+         (has-extended? (disk-type-check-feature
+                         disk-type
+                         DISK-TYPE-FEATURE-EXTENDED)))
+    (and (can-create-primary? disk)
+         has-extended?
+         (not (disk-extended-partition disk)))))
+
+(define (can-create-logical? disk)
+  "Return #t is it is possible to create a logical partition on DISK, return
+#f otherwise."
+  (let* ((disk-type (disk-disk-type disk))
+         (has-extended? (disk-type-check-feature
+                         disk-type
+                         DISK-TYPE-FEATURE-EXTENDED)))
+    (and has-extended?
+         (disk-extended-partition disk))))
+
+(define (can-create-partition? user-part)
+  "Return #t if it is possible to create the given USER-PART record, return #f
+otherwise."
+  (let* ((type (user-partition-type user-part))
+         (partition (user-partition-parted-object user-part))
+         (disk (partition-disk partition)))
+    (case type
+      ((normal)
+       (or (can-create-primary? disk)
+           (raise
+            (condition (&max-primary-exceeded)))))
+      ((extended)
+       (or (can-create-extended? disk)
+           (raise
+            (condition (&extended-creation-error)))))
+      ((logical)
+       (or (can-create-logical? disk)
+           (raise
+            (condition (&logical-creation-error))))))))
+
+(define* (mkpart disk user-partition
+                 #:key (previous-partition #f))
+  "Create the given USER-PARTITION on DISK. The PREVIOUS-PARTITION argument as
+to be set to the partition preceeding USER-PARTITION if any."
+
+  (define (parse-start-end start end)
+    "Parse start and end strings as positions on DEVICE expressed with a unit,
+like '100GB' or '12.2KiB'. Return a list of 4 elements, the start sector, its
+range (1 unit large area centered on start sector), the end sector and its
+range."
+    (let ((device (disk-device disk)))
+      (call-with-values
+          (lambda ()
+            (unit-parse start device))
+        (lambda (start-sector start-range)
+          (call-with-values
+              (lambda ()
+                (unit-parse end device))
+            (lambda (end-sector end-range)
+              (list start-sector start-range
+                    end-sector end-range)))))))
+
+  (define* (extend-ranges! start-range end-range
+                           #:key (offset 0))
+    "Try to extend START-RANGE by 1 MEBIBYTE to the right and END-RANGE by 1
+MEBIBYTE to the left. This way, if the disk is aligned on 2048 sectors of
+512KB (like frequently), we will have a chance for the
+'optimal-align-constraint' to succeed. Do not extend ranges if that would
+cause them to cross."
+    (let* ((device (disk-device disk))
+           (start-range-end (geometry-end start-range))
+           (end-range-start (geometry-start end-range))
+           (mebibyte-sector-size (/ MEBIBYTE-SIZE
+                                    (device-sector-size device)))
+           (new-start-range-end
+            (+ start-range-end mebibyte-sector-size offset))
+           (new-end-range-start
+            (- end-range-start mebibyte-sector-size offset)))
+      (when (< new-start-range-end new-end-range-start)
+        (geometry-set-end start-range new-start-range-end)
+        (geometry-set-start end-range new-end-range-start))))
+
+  (match (parse-start-end (user-partition-start user-partition)
+                          (user-partition-end user-partition))
+    ((start-sector start-range end-sector end-range)
+     (let* ((prev-end (if previous-partition
+                          (partition-end previous-partition)
+                          0))
+            (start-distance (- start-sector prev-end))
+            (type (user-partition-type user-partition))
+            ;; There should be at least 2 unallocated sectors in front of each
+            ;; logical partition, otherwise parted will fail badly:
+            ;; https://gparted.org/h2-fix-msdos-pt.php#apply-action-fail.
+            (start-offset (if previous-partition
+                              (- 3 start-distance)
+                              0))
+            (start-sector* (if (and (eq? type 'logical)
+                                    (< start-distance 3))
+                               (+ start-sector start-offset)
+                               start-sector)))
+       ;; This is a hackery but parted almost always fails to create optimally
+       ;; aligned partitions (unless specifiying percentages) because, the
+       ;; default range of 1MB centered on the start sector is not enough when
+       ;; the optimal alignment is 2048 sectors of 512KB.
+       (extend-ranges! start-range end-range #:offset start-offset)
+
+       (let* ((device (disk-device disk))
+              (disk-type (disk-disk-type disk))
+              (length (device-length device))
+              (name (user-partition-name user-partition))
+              (filesystem-type
+               (filesystem-type-get
+                (user-fs-type-name
+                 (user-partition-fs-type user-partition))))
+              (flags `(,@(if (user-partition-bootable? user-partition)
+                             `(,PARTITION-FLAG-BOOT)
+                             '())
+                       ,@(if (user-partition-esp? user-partition)
+                             `(,PARTITION-FLAG-ESP)
+                             '())
+                       ,@(if (user-partition-bios-grub? user-partition)
+                             `(,PARTITION-FLAG-BIOS-GRUB)
+                             '())))
+              (has-name? (disk-type-check-feature
+                          disk-type
+                          DISK-TYPE-FEATURE-PARTITION-NAME))
+              (partition-type (partition-type->int type))
+              (partition (partition-new disk
+                                        #:type partition-type
+                                        #:filesystem-type filesystem-type
+                                        #:start start-sector*
+                                        #:end end-sector))
+              (user-constraint (constraint-new
+                                #:start-align 'any
+                                #:end-align 'any
+                                #:start-range start-range
+                                #:end-range end-range
+                                #:min-size 1
+                                #:max-size length))
+              (dev-constraint
+               (device-get-optimal-aligned-constraint device))
+              (final-constraint (constraint-intersect user-constraint
+                                                      dev-constraint))
+              (no-constraint (constraint-any device))
+              ;; Try to create a partition with an optimal alignment
+              ;; constraint. If it fails, fallback to creating a partition with
+              ;; no specific constraint.
+              (partition-ok?
+               (or (disk-add-partition disk partition final-constraint)
+                   (disk-add-partition disk partition no-constraint))))
+         ;; Set the partition name if supported.
+         (when (and partition-ok? has-name? name)
+           (partition-set-name partition name))
+
+         ;; Set flags is required.
+         (for-each (lambda (flag)
+                     (and (partition-is-flag-available? partition flag)
+                          (partition-set-flag partition flag 1)))
+                   flags)
+
+         (and partition-ok?
+              (partition-set-system partition filesystem-type)
+              partition))))))
+
+
+;;
+;; Partition destruction.
+;;
+
+(define (rmpart disk number)
+  "Remove the partition with the given NUMBER on DISK."
+  (let ((partition (disk-get-partition disk number)))
+    (disk-remove-partition disk partition)))
+
+
+;;
+;; Auto partitionning.
+;;
+
+(define* (create-adjacent-partitions disk partitions
+                                     #:key (last-partition-end 0))
+  "Create the given PARTITIONS on DISK. LAST-PARTITION-END is the sector from
+which we want to start creating partitions. The START and END of each created
+partition are computed from its SIZE value and the position of the last
+partition."
+  (let ((device (disk-device disk)))
+    (let loop ((partitions partitions)
+               (remaining-space (- (device-length device)
+                                   last-partition-end))
+               (start last-partition-end))
+      (match partitions
+        (() '())
+        ((partition . rest)
+         (let* ((size (user-partition-size partition))
+                (percentage-size (and (string? size)
+                                      (read-percentage size)))
+                (sector-size (device-sector-size device))
+                (partition-size (if percentage-size
+                                    (exact->inexact
+                                     (* (/ percentage-size 100)
+                                        remaining-space))
+                                    size))
+                (end-partition (min (- (device-length device) 1)
+                                    (nearest-exact-integer
+                                     (+ start partition-size 1))))
+                (name (user-partition-name partition))
+                (type (user-partition-type partition))
+                (fs-type (user-partition-fs-type partition))
+                (start-formatted (unit-format-custom device
+                                                     start
+                                                     UNIT-SECTOR))
+                (end-formatted (unit-format-custom device
+                                                   end-partition
+                                                   UNIT-SECTOR))
+                (new-user-partition (user-partition
+                                     (inherit partition)
+                                     (start start-formatted)
+                                     (end end-formatted)))
+                (new-partition
+                 (mkpart disk new-user-partition)))
+           (if new-partition
+               (cons (user-partition
+                      (inherit new-user-partition)
+                      (path (partition-get-path new-partition))
+                      (disk-path (device-path device))
+                      (parted-object new-partition))
+                     (loop rest
+                           (if (eq? type 'extended)
+                               remaining-space
+                               (- remaining-space
+                                  (partition-length new-partition)))
+                           (if (eq? type 'extended)
+                               (+ start 1)
+                               (+ (partition-end new-partition) 1))))
+               (error
+                (format #f "Unable to create partition ~a~%" name)))))))))
+
+(define (force-user-partitions-formating user-partitions)
+  "Set the NEED-FORMATING? fields to #t on all <user-partition> records of
+USER-PARTITIONS list and return the updated list."
+  (map (lambda (p)
+         (user-partition
+          (inherit p)
+          (need-formating? #t)))
+       user-partitions))
+
+(define* (auto-partition disk
+                         #:key (scheme 'entire-root))
+  "Automatically create partitions on DISK. All the previous
+partitions (except the ESP on a GPT disk, if present) are wiped. SCHEME is the
+desired partitioning scheme. It can be 'entire-root or
+'entire-root-home. 'entire-root will create a swap partition and a root
+partition occupying all the remaining space. 'entire-root-home will create a
+swap partition, a root partition and a home partition."
+  (let* ((device (disk-device disk))
+         (disk-type (disk-disk-type disk))
+         (has-extended? (disk-type-check-feature
+                         disk-type
+                         DISK-TYPE-FEATURE-EXTENDED))
+         (partitions (filter data-partition? (disk-partitions disk)))
+         (esp-partition (find-esp-partition partitions))
+         ;; According to
+         ;; https://wiki.archlinux.org/index.php/EFI_system_partition, the ESP
+         ;; size should be at least 550MiB.
+         (new-esp-size (nearest-exact-integer
+                        (/ (* 550 MEBIBYTE-SIZE)
+                           (device-sector-size device))))
+         (end-esp-partition (and esp-partition
+                                 (partition-end esp-partition)))
+         (non-boot-partitions (remove esp-partition? partitions))
+         (bios-grub-size (/ (* 3 MEBIBYTE-SIZE)
+                            (device-sector-size device)))
+         (five-percent-disk (nearest-exact-integer
+                             (* 0.05 (device-length device))))
+         (default-swap-size (nearest-exact-integer
+                             (/ (* 4 GIGABYTE-SIZE)
+                                (device-sector-size device))))
+         ;; Use a 4GB size for the swap if it represents less than 5% of the
+         ;; disk space. Otherwise, set the swap size to 5% of the disk space.
+         (swap-size (min default-swap-size five-percent-disk)))
+
+    (if has-extended?
+        ;; msdos - remove everything.
+        (disk-delete-all disk)
+        ;; gpt - remove everything but esp if it exists.
+        (for-each
+         (lambda (partition)
+           (and (data-partition? partition)
+                (disk-remove-partition disk partition)))
+         non-boot-partitions))
+
+    (let* ((start-partition
+            (and (not has-extended?)
+                 (not esp-partition)
+                 (if (efi-installation?)
+                     (user-partition
+                      (fs-type 'fat32)
+                      (esp? #t)
+                      (size new-esp-size)
+                      (mount-point (default-esp-mount-point)))
+                     (user-partition
+                      (fs-type 'ext4)
+                      (bootable? #t)
+                      (bios-grub? #t)
+                      (size bios-grub-size)))))
+           (new-partitions
+            (case scheme
+              ((entire-root)
+               `(,@(if start-partition
+                       `(,start-partition)
+                       '())
+                 ,(user-partition
+                   (fs-type 'swap)
+                   (size swap-size))
+                 ,(user-partition
+                   (fs-type 'ext4)
+                   (bootable? has-extended?)
+                   (size "100%")
+                   (mount-point "/"))))
+              ((entire-root-home)
+               `(,@(if start-partition
+                       `(,start-partition)
+                       '())
+                 ,(user-partition
+                   (fs-type 'ext4)
+                   (bootable? has-extended?)
+                   (size "33%")
+                   (mount-point "/"))
+                 ,@(if has-extended?
+                       `(,(user-partition
+                           (type 'extended)
+                           (size "100%")))
+                       '())
+                 ,(user-partition
+                   (type (if has-extended?
+                             'logical
+                             'normal))
+                   (fs-type 'swap)
+                   (size swap-size))
+                 ,(user-partition
+                   (type (if has-extended?
+                             'logical
+                             'normal))
+                   (fs-type 'ext4)
+                   (size "100%")
+                   (mount-point "/home"))))))
+           (new-partitions* (force-user-partitions-formating
+                             new-partitions)))
+      (create-adjacent-partitions disk
+                                  new-partitions*
+                                  #:last-partition-end
+                                  (or end-esp-partition 0)))))
+
+
+;;
+;; Convert user-partitions.
+;;
+
+;; No root mount point found.
+(define-condition-type &no-root-mount-point &condition
+  no-root-mount-point?)
+
+(define (check-user-partitions user-partitions)
+  "Return #t if the USER-PARTITIONS lists contains one <user-partition> record
+with a mount-point set to '/', raise &no-root-mount-point condition
+otherwise."
+  (let ((mount-points
+         (map user-partition-mount-point user-partitions)))
+    (or (member "/" mount-points)
+        (raise
+         (condition (&no-root-mount-point))))))
+
+(define (set-user-partitions-path user-partitions)
+  "Set the partition path of <user-partition> records in USER-PARTITIONS list
+and return the updated list."
+  (map (lambda (p)
+         (let* ((partition (user-partition-parted-object p))
+                (path (partition-get-path partition)))
+           (user-partition
+            (inherit p)
+            (path path))))
+       user-partitions))
+
+(define-syntax-rule (with-null-output-ports exp ...)
+  "Evaluate EXP with both the output port and the error port pointing to the
+bit bucket."
+  (with-output-to-port (%make-void-port "w")
+    (lambda ()
+      (with-error-to-port (%make-void-port "w")
+        (lambda () exp ...)))))
+
+(define (create-ext4-file-system partition)
+  "Create an ext4 file-system for PARTITION path."
+  (with-null-output-ports
+   (invoke "mkfs.ext4" "-F" partition)))
+
+(define (create-fat32-file-system partition)
+  "Create an ext4 file-system for PARTITION path."
+  (with-null-output-ports
+   (invoke "mkfs.fat" "-F32" partition)))
+
+(define (create-swap-partition partition)
+  "Set up swap area on PARTITION path."
+  (with-null-output-ports
+   (invoke "mkswap" "-f" partition)))
+
+(define (start-swaping partition)
+  "Start swaping on PARTITION path."
+  (with-null-output-ports
+   (invoke "swapon" partition)))
+
+(define (stop-swaping partition)
+  "Stop swaping on PARTITION path."
+  (with-null-output-ports
+   (invoke "swapoff" partition)))
+
+(define (format-user-partitions user-partitions)
+  "Format the <user-partition> records in USER-PARTITIONS list with
+NEED-FORMATING? field set to #t."
+  (for-each
+   (lambda (user-partition)
+     (let* ((need-formating?
+             (user-partition-need-formating? user-partition))
+            (type (user-partition-type user-partition))
+            (path (user-partition-path user-partition))
+            (fs-type (user-partition-fs-type user-partition)))
+       (case fs-type
+         ((ext4)
+          (and need-formating?
+               (not (eq? type 'extended))
+               (create-ext4-file-system path)))
+         ((fat32)
+          (and need-formating?
+               (not (eq? type 'extended))
+               (create-fat32-file-system path)))
+         ((swap)
+          (create-swap-partition path))
+         (else
+          ;; TODO: Add support for other file-system types.
+          #t))))
+   user-partitions))
+
+(define (sort-partitions user-partitions)
+  "Sort USER-PARTITIONS by mount-points, so that the more nested mount-point
+comes last. This is useful to mount/umount partitions in a coherent order."
+  (sort user-partitions
+        (lambda (a b)
+          (let ((mount-point-a (user-partition-mount-point a))
+                (mount-point-b (user-partition-mount-point b)))
+            (string-prefix? mount-point-a mount-point-b)))))
+
+(define (mount-user-partitions user-partitions)
+  "Mount the <user-partition> records in USER-PARTITIONS list on their
+respective mount-points. Also start swaping on <user-partition> records with
+FS-TYPE equal to 'swap."
+  (let* ((mount-partitions (filter user-partition-mount-point user-partitions))
+         (sorted-partitions (sort-partitions mount-partitions)))
+    (for-each (lambda (user-partition)
+                (let* ((mount-point
+                        (user-partition-mount-point user-partition))
+                       (target
+                        (string-append (%installer-target-dir)
+                                       mount-point))
+                       (fs-type
+                        (user-partition-fs-type user-partition))
+                       (mount-type
+                        (user-fs-type->mount-type fs-type))
+                       (path (user-partition-path user-partition)))
+                  (case fs-type
+                    ((swap)
+                     (start-swaping path))
+                    (else
+                     (mkdir-p target)
+                     (mount path target mount-type)))))
+              sorted-partitions)))
+
+(define (umount-user-partitions user-partitions)
+  "Unmount all the <user-partition> records in USER-PARTITIONS list. Also stop
+swaping on <user-partition> with FS-TYPE set to 'swap."
+  (let* ((mount-partitions (filter user-partition-mount-point user-partitions))
+         (sorted-partitions (sort-partitions mount-partitions)))
+    (for-each (lambda (user-partition)
+                (let* ((mount-point
+                        (user-partition-mount-point user-partition))
+                       (fs-type
+                        (user-partition-fs-type user-partition))
+                       (path (user-partition-path user-partition))
+                       (target
+                        (string-append (%installer-target-dir)
+                                       mount-point)))
+                  (case fs-type
+                    ((swap)
+                     (stop-swaping path))
+                    (else
+                     (umount target)))))
+              (reverse sorted-partitions))))
+
+(define-syntax-rule (with-mounted-partitions user-partitions exp ...)
+  "Mount USER-PARTITIONS within the dynamic extent of EXP."
+  (dynamic-wind
+    (lambda ()
+      (mount-user-partitions user-partitions))
+    (lambda ()
+      exp ...)
+    (lambda ()
+      (umount-user-partitions user-partitions)
+      #f)))
+
+(define (user-partition->file-system user-partition)
+  "Convert the given USER-PARTITION record in a FILE-SYSTEM record from
+(gnu system file-systems) module and return it."
+  (let* ((mount-point (user-partition-mount-point user-partition))
+         (fs-type (user-partition-fs-type user-partition))
+         (mount-type (user-fs-type->mount-type fs-type))
+         (path (user-partition-path user-partition))
+         (uuid (uuid->string (read-partition-uuid path)
+                             fs-type)))
+    `(file-system
+       (mount-point ,mount-point)
+       (device (uuid ,uuid (quote ,fs-type)))
+       (type ,mount-type))))
+
+(define (user-partitions->file-systems user-partitions)
+  "Convert the given USER-PARTITIONS list of <user-partition> records into a
+list of <file-system> records."
+  (filter-map
+   (lambda (user-partition)
+     (let ((mount-point
+            (user-partition-mount-point user-partition)))
+       (and mount-point
+            (user-partition->file-system user-partition))))
+   user-partitions))
+
+(define (find-swap-user-partitions user-partitions)
+  "Return the subset of <user-partition> records in USER-PARTITIONS list with
+the FS-TYPE field set to 'swap, return the empty list if none found."
+  (filter (lambda (user-partition)
+          (let ((fs-type (user-partition-fs-type user-partition)))
+            (eq? fs-type 'swap)))
+        user-partitions))
+
+(define (bootloader-configuration user-partitions)
+  "Return the bootloader configuration field for USER-PARTITIONS."
+  (let* ((root-partition
+          (find (lambda (user-partition)
+                  (let ((mount-point
+                         (user-partition-mount-point user-partition)))
+                    (and mount-point
+                         (string=? mount-point "/"))))
+                user-partitions))
+         (root-partition-disk (user-partition-disk-path root-partition)))
+    `((bootloader-configuration
+       ,@(if (efi-installation?)
+             `((bootloader grub-efi-bootloader)
+               (target ,(default-esp-mount-point)))
+             `((bootloader grub-bootloader)
+               (target ,root-partition-disk)))))))
+
+(define (user-partitions->configuration user-partitions)
+  "Return the configuration field for USER-PARTITIONS."
+  (let* ((swap-user-partitions (find-swap-user-partitions user-partitions))
+         (swap-devices (map user-partition-path swap-user-partitions)))
+    `(,@(if (null? swap-devices)
+            '()
+            `((swap-devices (list ,@swap-devices))))
+      (bootloader ,@(bootloader-configuration user-partitions))
+      (file-systems (cons*
+                     ,@(user-partitions->file-systems user-partitions)
+                     %base-file-systems)))))
+
+
+;;
+;; Initialization.
+;;
+
+(define (init-parted)
+  "Initialize libparted support."
+  (probe-all-devices)
+  (exception-set-handler (lambda (exception)
+                           EXCEPTION-OPTION-UNHANDLED)))
+
+(define (free-parted devices)
+  "Deallocate memory used for DEVICES in parted, force sync them and wait for
+the devices not to be used before returning."
+  ;; XXX: Formating and further operations on disk partition table may fail
+  ;; because the partition table changes are not synced, or because the device
+  ;; is still in use, even if parted should have finished editing
+  ;; partitions. This is not well understood, but syncing devices and waiting
+  ;; them to stop returning EBUSY to BLKRRPART ioctl seems to be enough. The
+  ;; same kind of issue is described here:
+  ;; https://mail.gnome.org/archives/commits-list/2013-March/msg18423.html.
+  (let ((device-paths (map device-path devices)))
+    (for-each force-device-sync devices)
+    (free-all-devices)
+    (for-each (lambda (path)
+                (let ((in-use? (with-delay-device-in-use? path)))
+                  (and in-use?
+                       (error
+                        (format #f (G_ "Device ~a is still in use.")
+                                path)))))
+              device-paths)))
diff --git a/gnu/installer/record.scm b/gnu/installer/record.scm
index 3ef0a101d3..edf73b6215 100644
--- a/gnu/installer/record.scm
+++ b/gnu/installer/record.scm
@@ -35,6 +35,7 @@
             installer-timezone-page
             installer-hostname-page
             installer-user-page
+            installer-partition-page
             installer-services-page
             installer-welcome-page))
 
@@ -76,6 +77,8 @@
   ;; procedure void -> void
   (user-page installer-user-page)
   ;; procedure void -> void
+  (partition-page installer-partition-page)
+  ;; procedure void -> void
   (services-page installer-services-page)
   ;; procedure (logo) -> void
   (welcome-page installer-welcome-page))