;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
#:use-module (parted)
#:export (run-partioning-page))
-(define (button-cancel-action)
+(define (button-exit-action)
"Raise the &installer-step-abort condition."
(raise
(condition
(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")))
+ `((root . ,(G_ "Everything is one partition"))
+ (root-home . ,(G_ "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)))
+ #:listbox-height 4
+ #:sort-listbox-items? #f ;keep the 'root' option first
+ #:button-text (G_ "Exit")
+ #:button-callback-procedure button-exit-action)))
(car result)))
-(define (draw-formating-page)
- "Draw a page to indicate partitions are being formated."
+(define (draw-formatting-page)
+ "Draw a page asking for confirmation, and then indicating that partitions
+are being formatted."
+ (run-confirmation-page (G_ "We are about to format your hard disk. All \
+its data will be lost. Do you wish to continue?")
+ (G_ "Format disk?")
+ #:exit-button-procedure button-exit-action)
(draw-info-page
- (format #f (G_ "Partition formating is in progress, please wait."))
+ (format #f (G_ "Partition formatting is in progress, please wait."))
(G_ "Preparing partitions")))
(define (run-device-page devices)
#:title (G_ "Disk")
#:listbox-items (device-items)
#:listbox-item->text cdr
- #:button-text (G_ "Cancel")
- #:button-callback-procedure button-cancel-action))
+ #:listbox-height 10
+ #:button-text (G_ "Exit")
+ #:button-callback-procedure button-exit-action))
(device (car result)))
device))
-(define (run-label-page button-callback)
+(define (run-label-page button-text 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. \
#:title (G_ "Partition table")
#:listbox-items '("msdos" "gpt")
#:listbox-item->text identity
- #:button-text (G_ "Cancel")
+ #:button-text button-text
#:button-callback-procedure button-callback))
(define (run-type-page partition)
'()
'(extended)))))
(run-listbox-selection-page
- #:info-text (G_ "Please select a partition type")
+ #: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)))
+ #:button-text (G_ "Exit")
+ #:button-callback-procedure button-exit-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")
+ #:info-text (G_ "Please select the file-system type for this partition.")
#:title (G_ "File-system type")
- #:listbox-items '(ext4 btrfs fat32 swap)
+ #:listbox-items '(ext4 btrfs fat16 fat32 swap)
#:listbox-item->text user-fs-type-name
#:sort-listbox-items? #f
- #:button-text (G_ "Cancel")
- #:button-callback-procedure button-cancel-action))
+ #:button-text (G_ "Exit")
+ #:button-callback-procedure button-exit-action))
(define (inform-can-create-partition? user-partition)
"Return #t if it is possible to create USER-PARTITION. This is determined by
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_ "Primary partitions count exceeded.")
(G_ "Creation error"))
#f)
((extended-creation-error? c)
(run-error-page
- (G_ "Extended partition creation error")
+ (G_ "Extended partition creation error.")
(G_ "Creation error"))
#f)
((logical-creation-error? c)
(run-error-page
- (G_ "Logical partition creation error")
+ (G_ "Logical partition creation error.")
(G_ "Creation error"))
#f))
(can-create-partition? user-partition)))
+(define (prompt-luks-passwords user-partitions)
+ "Prompt for the luks passwords of the encrypted partitions in
+USER-PARTITIONS list. Return this list with password fields filled-in."
+ (map (lambda (user-part)
+ (let* ((crypt-label (user-partition-crypt-label user-part))
+ (file-name (user-partition-file-name user-part))
+ (password-page
+ (lambda ()
+ (run-input-page
+ (format #f (G_ "Please enter the password for the \
+encryption of partition ~a (label: ~a).") file-name crypt-label)
+ (G_ "Password required")
+ #:input-hide-checkbox? #t)))
+ (password-confirm-page
+ (lambda ()
+ (run-input-page
+ (format #f (G_ "Please confirm the password for the \
+encryption of partition ~a (label: ~a).") file-name crypt-label)
+ (G_ "Password confirmation required")
+ #:input-hide-checkbox? #t))))
+ (if crypt-label
+ (let loop ()
+ (let ((password (password-page))
+ (confirmation (password-confirm-page)))
+ (if (string=? password confirmation)
+ (user-partition
+ (inherit user-part)
+ (crypt-password password))
+ (begin
+ (run-error-page
+ (G_ "Password mismatch, please try again.")
+ (G_ "Password error"))
+ (loop)))))
+ user-part)))
+ user-partitions))
+
(define* (run-partition-page target-user-partition
#:key
(default-item #f))
(mount-point (if new-esp?
(default-esp-mount-point)
"")))))
- ((need-formating?)
+ ((crypt-label)
+ (let* ((label (user-partition-crypt-label
+ target-user-partition))
+ (new-label
+ (and (not label)
+ (run-input-page
+ (G_ "Please enter the encrypted label")
+ (G_ "Encryption label")))))
+ (user-partition
+ (inherit target-user-partition)
+ (need-formatting? #t)
+ (crypt-label new-label))))
+ ((need-formatting?)
(user-partition
(inherit target-user-partition)
- (need-formating?
- (not (user-partition-need-formating?
+ (need-formatting?
+ (not (user-partition-need-formatting?
target-user-partition)))))
((size)
(let* ((old-size (user-partition-size target-user-partition))
(and new-partition
(user-partition
(inherit new-user-partition)
- (need-formating? #t)
- (path (partition-get-path new-partition))
- (disk-path (device-path device))
+ (need-formatting? #t)
+ (file-name (partition-get-path new-partition))
+ (disk-file-name (device-path device))
(parted-object new-partition))))
(and (apply-user-partition-changes new-user-partition)
new-user-partition))))
target-user-partition))
(disk (partition-disk partition))
(device (disk-device disk))
- (path (device-path device))
+ (file-name (device-path device))
(number-str (partition-print-number partition))
(type (user-partition-type target-user-partition))
(type-str (symbol->string type))
(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)))
+ (format #f (G_ "Creating ~a partition starting at ~a of ~a.")
+ type-str start file-name)
+ (format #f (G_ "You are currently editing partition ~a.")
+ number-str))
#:title (if creation?
(G_ "Partition creation")
(G_ "Partition edit"))
#:listbox-item->text cdr
#:sort-listbox-items? #f
#:listbox-default-item default-item
- #:button-text (G_ "Ok")
+ #:button-text (G_ "OK")
#:listbox-callback-procedure listbox-action
#:button-callback-procedure button-action)))
(match result
(else result))))
(define* (run-disk-page disks
- #:optional (user-partitions '()))
+ #:optional (user-partitions '())
+ #:key (guided? #f))
"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."
(let ((item (car listbox-item)))
(cond
((disk? item)
- (let ((label (run-label-page (const #f))))
+ (let ((label (run-label-page (G_ "Back") (const #f))))
(if label
(let* ((device (disk-device item))
(new-disk (mklabel device label))
(cond
((disk? item)
(let* ((device (disk-device item))
- (path (device-path device))
+ (file-name (device-path device))
(info-text
(format #f (G_ "Are you sure you want to delete everything on disk ~a?")
- path))
+ file-name))
(result (choice-window (G_ "Delete disk")
- (G_ "Ok")
- (G_ "Cancel")
+ (G_ "OK")
+ (G_ "Exit")
info-text)))
(case result
((1)
(format #f (G_ "Are you sure you want to delete partition ~a?")
number-str))
(result (choice-window (G_ "Delete partition")
- (G_ "Ok")
- (G_ "Cancel")
+ (G_ "OK")
+ (G_ "Exit")
info-text)))
(case result
((1)
(else
default-result))))))))
- (let ((result
- (run-listbox-selection-page
-
- #:info-text (G_ "You can change a disk's partition table by \
+ (let* ((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
+At least one partition must have its mounting point set to '/'."))
+ (guided-info-text (format #f (G_ "This is the proposed \
+partitioning. It is still possible to edit it or to go back to install menu \
+by pressing the Exit button.~%~%")))
+ (result
+ (run-listbox-selection-page
+ #:info-text (if guided?
+ (string-append guided-info-text info-text)
+ info-text)
+
+ #:title (if guided?
+ (G_ "Guided partitioning")
+ (G_ "Manual partitioning"))
+ #:info-textbox-width 76 ;we need a lot of room for INFO-TEXT
+ #:listbox-height 12
#: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-text (G_ "OK")
#:button-callback-procedure button-ok-action
- #:button2-text (G_ "Cancel")
- #:button2-callback-procedure button-cancel-action
+ #:button2-text (G_ "Exit")
+ #:button2-callback-procedure button-exit-action
#:listbox-callback-procedure listbox-action
#:hotkey-callback-procedure hotkey-action)))
(if (eq? result #t)
(guard
(c ((no-root-mount-point? c)
(run-error-page
- (G_ "No root mount point found")
+ (G_ "No root mount point found.")
(G_ "Missing mount point"))
#f))
(check-user-partitions user-partitions))))
(begin
(for-each (cut disk-destroy <>) disks)
user-partitions)
- (run-disk-page disks user-partitions)))
+ (run-disk-page disks user-partitions
+ #:guided? guided?)))
(let* ((result-disks (assoc-ref result 'disks))
(result-user-partitions (assoc-ref result
'user-partitions))
(update-user-partitions result-user-partitions
new-user-partition)
result-user-partitions)))
- (run-disk-page result-disks new-user-partitions)))))
+ (run-disk-page result-disks new-user-partitions
+ #:guided? guided?)))))
(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")))
+ `((entire . ,(G_ "Guided - using the entire disk"))
+ (entire-encrypted . ,(G_ "Guided - using the entire disk with encryption"))
+ (manual . ,(G_ "Manual"))))
(result (run-listbox-selection-page
#:info-text (G_ "Please select a partitioning method.")
#:title (G_ "Partitioning method")
+ #:listbox-height (+ (length items) 2)
#:listbox-items items
#:listbox-item->text cdr
- #:button-text (G_ "Cancel")
- #:button-callback-procedure button-cancel-action))
+ #:sort-listbox-items? #f
+ #:button-text (G_ "Exit")
+ #:button-callback-procedure button-exit-action))
(method (car result)))
- (case method
- ((entire)
+ (cond
+ ((or (eq? method 'entire)
+ (eq? method 'entire-encrypted))
(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))
+ (G_ "Exit")
+ button-exit-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 (auto-partition! disk #:scheme scheme)))
+ (run-disk-page (list disk) user-partitions
+ #:guided? #t)))
+ ((eq? method 'manual)
+ (let* ((disks (filter-map disk-new devices))
(user-partitions (append-map
create-special-user-partitions
(map disk-partitions disks)))
(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.
+ (user-partitions-with-pass (prompt-luks-passwords
+ user-partitions))
+ (form (draw-formatting-page)))
+ ;; Make sure the disks are not in use before proceeding to formatting.
(free-parted non-install-devices)
- (run-error-page (format #f "~a" user-partitions)
- "user-partitions")
- (format-user-partitions user-partitions)
+ (format-user-partitions user-partitions-with-pass)
(destroy-form-and-pop form)
user-partitions))
HCoop / jackhill / guix / guix.git / blobdiff