diff options
Diffstat (limited to 'gnu/installer')
| -rw-r--r-- | gnu/installer/newt.scm | 5 | ||||
| -rw-r--r-- | gnu/installer/newt/partition.scm | 706 | ||||
| -rw-r--r-- | gnu/installer/parted.scm | 1210 | ||||
| -rw-r--r-- | gnu/installer/record.scm | 3 |
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)) |