mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 21:38:07 -05:00
installer: partionment: Add encryption support.
* gnu/installer.scm (set-installer-path): Add cryptsetup. * gnu/installer/newt/partition.scm (prompt-luks-passwords): New procedure, (run-partioning-page): Add the possibility to set encryption to "On" on a partition and choose a label, add a new partition scheme: "Guided - using the entire disk with encryption", prompt for encryption passwords before proceeding to formating. * gnu/installer/parted.scm (<user-partition>)[crypt-label], [crypt-password]: New fields, (partition-description): add the encryption label, (user-partition-description): add an encryption field, (auto-partition): add two partitioning schemes: entire-crypted-root and entire-crypted-root-home, (call-with-luks-key-file): new procedure, (user-partition-upper-path): new procedure, (luks-format-and-open): new procedure, (luks-close): new procedure, (format-user-partitions): format and open luks partitions before creating file-system. (mount-user-partitions): use the path returned by user-partition-upper-path, (umount-user-partitions): close the luks partitions, (user-partition->file-system): set device field to label for luks partitions and to uuid for the rest, (user-partition->mapped-device): new procedure, (user-partitions->configuration): add mapped-devices field.
This commit is contained in:
Mathieu Othacehe
Ludovic Courtès
parent
71cd8a5870
commit
bf304dbcea
3 changed files with 195 additions and 54 deletions
|
|
@ -28,6 +28,7 @@ (define-module (gnu installer)
|
|||
#: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 @@ (define set-installer-path
|
|||
#~(let* ((inputs
|
||||
'#$(append (list bash ;start subshells
|
||||
connman ;call connmanctl
|
||||
cryptsetup
|
||||
dosfstools ;mkfs.fat
|
||||
e2fsprogs ;mkfs.ext4
|
||||
kbd ;chvt
|
||||
|
|
|
|||
|
|
@ -138,6 +138,25 @@ (define (inform-can-create-partition? user-partition)
|
|||
#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 @@ (define (listbox-action listbox-item)
|
|||
(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 @@ (define (run-partioning-page)
|
|||
(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 @@ (define (run-page devices)
|
|||
#: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 @@ (define (run-page devices)
|
|||
(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 @@ (define (run-page devices)
|
|||
(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))
|
||||
|
|
|
|||
|
|
@ -22,13 +22,16 @@ (define-module (gnu installer parted)
|
|||
#: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 @@ (define-module (gnu installer parted)
|
|||
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 @@ (define-record-type* <user-partition>
|
|||
(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 @@ (define (partition-print-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))
|
||||
(if (and string (not (string=? string "")))
|
||||
(string-pad-right string length)
|
||||
""))
|
||||
|
||||
(let* ((disk (partition-disk partition))
|
||||
(device (disk-device disk))
|
||||
|
|
@ -452,6 +463,8 @@ (define (maybe-string-pad string length)
|
|||
(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 @@ (define (maybe-string-pad string length)
|
|||
,(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 @@ (define (user-partition-description user-partition)
|
|||
(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 @@ (define (user-partition-description user-partition)
|
|||
(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 @@ (define (force-user-partitions-formating user-partitions)
|
|||
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 @@ (define* (auto-partition disk
|
|||
(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 @@ (define (create-swap-partition partition)
|
|||
(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 @@ (define (format-user-partitions user-partitions)
|
|||
(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 @@ (define (mount-user-partitions user-partitions)
|
|||
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 @@ (define (umount-user-partitions user-partitions)
|
|||
(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 @@ (define (user-partition->file-system user-partition)
|
|||
(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 @@ (define (user-partitions->file-systems user-partitions)
|
|||
(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 @@ (define (bootloader-configuration user-partitions)
|
|||
(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)))))
|
||||
|
|
|
|||
Loading…
Reference in a new issue