diff options
| -rw-r--r-- | gnu/installer.scm | 2 | ||||
| -rw-r--r-- | gnu/installer/newt/partition.scm | 45 | ||||
| -rw-r--r-- | gnu/installer/parted.scm | 202 |
3 files changed, 195 insertions, 54 deletions
diff --git a/gnu/installer.scm b/gnu/installer.scm index 2f01d39d1a..fd66359cbe 100644 --- a/gnu/installer.scm +++ b/gnu/installer.scm @@ -28,6 +28,7 @@ #:use-module (gnu packages base) #:use-module (gnu packages bash) #:use-module (gnu packages connman) + #:use-module (gnu packages cryptsetup) #:use-module (gnu packages disk) #:use-module (gnu packages guile) #:autoload (gnu packages gnupg) (guile-gcrypt) @@ -272,6 +273,7 @@ selected keymap." #~(let* ((inputs '#$(append (list bash ;start subshells connman ;call connmanctl + cryptsetup dosfstools ;mkfs.fat e2fsprogs ;mkfs.ext4 kbd ;chvt diff --git a/gnu/installer/newt/partition.scm b/gnu/installer/newt/partition.scm index 6aa8bfb598..f4d1735dda 100644 --- a/gnu/installer/newt/partition.scm +++ b/gnu/installer/newt/partition.scm @@ -138,6 +138,25 @@ an inform the user with an appropriate error-page and return #f." #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)) + (path (user-partition-path user-part)) + (password-page + (lambda () + (run-input-page + (format #f (G_ "Please enter the password for the \ +encryption of partition ~a (label: ~a).") path crypt-label) + (G_ "Password required"))))) + (if crypt-label + (user-partition + (inherit user-part) + (crypt-password (password-page))) + user-part))) + user-partitions)) + (define* (run-partition-page target-user-partition #:key (default-item #f)) @@ -244,6 +263,18 @@ by USER-PART, if it is applicable for the partition type." (mount-point (if new-esp? (default-esp-mount-point) ""))))) + ((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-formating? #t) + (crypt-label new-label)))) ((need-formating?) (user-partition (inherit target-user-partition) @@ -668,6 +699,7 @@ by pressing the Exit button.~%~%"))) (define (run-page devices) (let* ((items '((entire . "Guided - using the entire disk") + (entire-crypted . "Guided - using the entire disk with encryption") (manual . "Manual"))) (result (run-listbox-selection-page #:info-text (G_ "Please select a partitioning method.") @@ -677,8 +709,9 @@ by pressing the Exit button.~%~%"))) #:button-text (G_ "Exit") #:button-callback-procedure button-exit-action)) (method (car result))) - (case method - ((entire) + (cond + ((or (eq? method 'entire) + (eq? method 'entire-crypted)) (let* ((device (run-device-page devices)) (disk-type (disk-probe device)) (disk (if disk-type @@ -696,7 +729,7 @@ by pressing the Exit button.~%~%"))) (disk-partitions disk))))) (run-disk-page (list disk) user-partitions #:guided? #t))) - ((manual) + ((eq? method 'manual) (let* ((disks (map disk-new devices)) (user-partitions (append-map create-special-user-partitions @@ -708,11 +741,13 @@ by pressing the Exit button.~%~%"))) (init-parted) (let* ((non-install-devices (non-install-devices)) (user-partitions (run-page non-install-devices)) + (user-partitions-with-pass (prompt-luks-passwords + user-partitions)) (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) + (run-error-page (format #f "~a" user-partitions-with-pass) "user-partitions") - (format-user-partitions user-partitions) + (format-user-partitions user-partitions-with-pass) (destroy-form-and-pop form) user-partitions)) diff --git a/gnu/installer/parted.scm b/gnu/installer/parted.scm index b0fe672131..c56da60550 100644 --- a/gnu/installer/parted.scm +++ b/gnu/installer/parted.scm @@ -22,13 +22,16 @@ #:use-module (gnu installer newt page) #:use-module (gnu system uuid) #:use-module ((gnu build file-systems) - #:select (read-partition-uuid)) + #:select (read-partition-uuid + find-partition-by-luks-uuid)) #:use-module (guix build syscalls) #:use-module (guix build utils) #:use-module (guix records) + #:use-module (guix utils) #:use-module (guix i18n) #:use-module (parted) #:use-module (ice-9 match) + #:use-module (rnrs io ports) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) @@ -41,6 +44,8 @@ user-partition-type user-partition-path user-partition-disk-path + user-partition-crypt-label + user-partition-crypt-password user-partition-fs-type user-partition-bootable? user-partition-esp? @@ -128,6 +133,10 @@ (default #f)) (disk-path user-partition-disk-path (default #f)) + (crypt-label user-partition-crypt-label + (default #f)) + (crypt-password user-partition-crypt-password + (default #f)) (fs-type user-partition-fs-type (default 'ext4)) (bootable? user-partition-bootable? @@ -427,7 +436,9 @@ DEVICE." (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)) + (if (and string (not (string=? string ""))) + (string-pad-right string length) + "")) (let* ((disk (partition-disk partition)) (device (disk-device disk)) @@ -452,6 +463,8 @@ right. If STRING is #f use an empty string." (fs-type (partition-fs-type partition)) (fs-type-name (and fs-type (filesystem-type-name fs-type))) + (crypt-label (and user-partition + (user-partition-crypt-label user-partition))) (flags (and (not (freespace-partition? partition)) (partition-print-flags partition))) (mount-point (and user-partition @@ -464,6 +477,7 @@ right. If STRING is #f use an empty string." ,(or fs-type-name "") ,(or flags "") ,(or mount-point "") + ,(or crypt-label "") ,(maybe-string-pad name 30)))) (define (partitions-descriptions partitions user-partitions) @@ -525,6 +539,7 @@ determined by MAX-LENGTH-COLUMN procedure." (bootable? (user-partition-bootable? user-partition)) (esp? (user-partition-esp? user-partition)) (need-formating? (user-partition-need-formating? user-partition)) + (crypt-label (user-partition-crypt-label user-partition)) (size (user-partition-size user-partition)) (mount-point (user-partition-mount-point user-partition))) `(,@(if has-name? @@ -555,6 +570,15 @@ determined by MAX-LENGTH-COLUMN procedure." (partition-length partition))))) `((size . ,(string-append "Size : " size-formatted)))) '()) + ,@(if (or (eq? type 'extended) + (eq? fs-type 'swap)) + '() + `((crypt-label + . ,(string-append + "Encryption: " + (if crypt-label + (format #f "Yes (label ~a)" crypt-label) + "No"))))) ,@(if (or (freespace-partition? partition) (eq? fs-type 'swap)) '() @@ -854,7 +878,8 @@ USER-PARTITIONS list and return the updated list." user-partitions)) (define* (auto-partition disk - #:key (scheme 'entire-root)) + #: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 @@ -913,46 +938,57 @@ swap partition, a root partition and a home partition." (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")))))) + (cond + ((or (eq? scheme 'entire-root) + (eq? scheme 'entire-crypted-root)) + (let ((crypted? (eq? scheme 'entire-crypted-root))) + `(,@(if start-partition + `(,start-partition) + '()) + ,@(if crypted? + '() + `(,(user-partition + (fs-type 'swap) + (size swap-size)))) + ,(user-partition + (fs-type 'ext4) + (bootable? has-extended?) + (crypt-label (and crypted? "cryptroot")) + (size "100%") + (mount-point "/"))))) + ((or (eq? scheme 'entire-root-home) + (eq? scheme 'entire-crypted-root-home)) + (let ((crypted? (eq? scheme 'entire-crypted-root-home))) + `(,@(if start-partition + `(,start-partition) + '()) + ,(user-partition + (fs-type 'ext4) + (bootable? has-extended?) + (crypt-label (and crypted? "cryptroot")) + (size "33%") + (mount-point "/")) + ,@(if has-extended? + `(,(user-partition + (type 'extended) + (size "100%"))) + '()) + ,@(if crypted? + '() + `(,(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) + (crypt-label (and crypted? "crypthome")) + (size "100%") + (mount-point "/home"))))))) (new-partitions* (force-user-partitions-formating new-partitions))) (create-adjacent-partitions disk @@ -1013,6 +1049,40 @@ bit bucket." (with-null-output-ports (invoke "mkswap" "-f" partition))) +(define (call-with-luks-key-file password proc) + "Write PASSWORD in a temporary file and pass it to PROC as argument." + (call-with-temporary-output-file + (lambda (file port) + (put-string port password) + (close port) + (proc file)))) + +(define (user-partition-upper-path user-partition) + "Return the path of the virtual block device corresponding to USER-PARTITION +if it is encrypted, or the plain path otherwise." + (let ((crypt-label (user-partition-crypt-label user-partition)) + (path (user-partition-path user-partition))) + (if crypt-label + (string-append "/dev/mapper/" crypt-label) + path))) + +(define (luks-format-and-open user-partition) + "Format and open the crypted partition pointed by USER-PARTITION." + (let* ((path (user-partition-path user-partition)) + (label (user-partition-crypt-label user-partition)) + (password (user-partition-crypt-password user-partition))) + (call-with-luks-key-file + password + (lambda (key-file) + (system* "cryptsetup" "-q" "luksFormat" path key-file) + (system* "cryptsetup" "open" "--type" "luks" + "--key-file" key-file path label))))) + +(define (luks-close user-partition) + "Close the crypted partition pointed by USER-PARTITION." + (let ((label (user-partition-crypt-label user-partition))) + (system* "cryptsetup" "close" label))) + (define (format-user-partitions user-partitions) "Format the <user-partition> records in USER-PARTITIONS list with NEED-FORMATING? field set to #t." @@ -1021,8 +1091,12 @@ NEED-FORMATING? field set to #t." (let* ((need-formating? (user-partition-need-formating? user-partition)) (type (user-partition-type user-partition)) - (path (user-partition-path user-partition)) + (crypt-label (user-partition-crypt-label user-partition)) + (path (user-partition-upper-path user-partition)) (fs-type (user-partition-fs-type user-partition))) + (when crypt-label + (luks-format-and-open user-partition)) + (case fs-type ((ext4) (and need-formating? @@ -1061,9 +1135,11 @@ respective mount-points." mount-point)) (fs-type (user-partition-fs-type user-partition)) + (crypt-label + (user-partition-crypt-label user-partition)) (mount-type (user-fs-type->mount-type fs-type)) - (path (user-partition-path user-partition))) + (path (user-partition-upper-path user-partition))) (mkdir-p target) (mount path target mount-type))) sorted-partitions))) @@ -1075,10 +1151,14 @@ respective mount-points." (for-each (lambda (user-partition) (let* ((mount-point (user-partition-mount-point user-partition)) + (crypt-label + (user-partition-crypt-label user-partition)) (target (string-append (%installer-target-dir) mount-point))) - (umount target))) + (umount target) + (when crypt-label + (luks-close user-partition)))) (reverse sorted-partitions)))) (define (find-swap-user-partitions user-partitions) @@ -1119,14 +1199,21 @@ the FS-TYPE field set to 'swap, return the empty list if none found." (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)) + (crypt-label (user-partition-crypt-label user-partition)) (mount-type (user-fs-type->mount-type fs-type)) (path (user-partition-path user-partition)) + (upper-path (user-partition-upper-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)))) + (device ,@(if crypt-label + `(,upper-path) + `((uuid ,uuid (quote ,fs-type))))) + (type ,mount-type) + ,@(if crypt-label + '((dependencies mapped-devices)) + '())))) (define (user-partitions->file-systems user-partitions) "Convert the given USER-PARTITIONS list of <user-partition> records into a @@ -1139,6 +1226,16 @@ list of <file-system> records." (user-partition->file-system user-partition)))) user-partitions)) +(define (user-partition->mapped-device user-partition) + "Convert the given USER-PARTITION record into a MAPPED-DEVICE record +from (gnu system mapped-devices) and return it." + (let ((label (user-partition-crypt-label user-partition)) + (path (user-partition-path user-partition))) + `(mapped-device + (source (uuid ,(uuid->string (read-partition-uuid path)))) + (target ,label) + (type luks-device-mapping)))) + (define (bootloader-configuration user-partitions) "Return the bootloader configuration field for USER-PARTITIONS." (let* ((root-partition @@ -1159,11 +1256,18 @@ list of <file-system> records." (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))) + (swap-devices (map user-partition-path swap-user-partitions)) + (crypted-partitions + (filter user-partition-crypt-label user-partitions))) `(,@(if (null? swap-devices) '() `((swap-devices (list ,@swap-devices)))) (bootloader ,@(bootloader-configuration user-partitions)) + ,@(if (null? crypted-partitions) + '() + `((mapped-devices + (list ,@(map user-partition->mapped-device + crypted-partitions))))) (file-systems (cons* ,@(user-partitions->file-systems user-partitions) %base-file-systems))))) |