mirror/guix
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/guix.git synced 2025-01-19 05:57:04 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions

installer: partionment: Add encryption support.

Browse source 
* 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 2018-12-07 14:04:25 +09:00 committed by Ludovic Courtès
parent 71cd8a5870
commit bf304dbcea
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
3 changed files with 195 additions and 54 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
gnu/installer.scm
View file

@ -28,6 +28,7 @@ (define-module (gnu installer)
#:use-module (gnu packages base) #:use-module (gnu packages base)
#:use-module (gnu packages bash) #:use-module (gnu packages bash)
#:use-module (gnu packages connman) #:use-module (gnu packages connman)
#:use-module (gnu packages cryptsetup)
#:use-module (gnu packages disk) #:use-module (gnu packages disk)
#:use-module (gnu packages guile) #:use-module (gnu packages guile)
#:autoload (gnu packages gnupg) (guile-gcrypt) #:autoload (gnu packages gnupg) (guile-gcrypt)
@ -272,6 +273,7 @@ (define set-installer-path
#~(let* ((inputs #~(let* ((inputs
'#$(append (list bash ;start subshells '#$(append (list bash ;start subshells
connman ;call connmanctl connman ;call connmanctl
cryptsetup
dosfstools ;mkfs.fat dosfstools ;mkfs.fat
e2fsprogs ;mkfs.ext4 e2fsprogs ;mkfs.ext4
kbd ;chvt kbd ;chvt

45
gnu/installer/newt/partition.scm
View file

@ -138,6 +138,25 @@ (define (inform-can-create-partition? user-partition)
#f)) #f))
(can-create-partition? user-partition))) (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 (define* (run-partition-page target-user-partition
#:key #:key
(default-item #f)) (default-item #f))
@ -244,6 +263,18 @@ (define (listbox-action listbox-item)
(mount-point (if new-esp? (mount-point (if new-esp?
(default-esp-mount-point) (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?) ((need-formating?)
(user-partition (user-partition
(inherit target-user-partition) (inherit target-user-partition)
@ -668,6 +699,7 @@ (define (run-partioning-page)
(define (run-page devices) (define (run-page devices)
(let* ((items (let* ((items
'((entire . "Guided - using the entire disk") '((entire . "Guided - using the entire disk")
(entire-crypted . "Guided - using the entire disk with encryption")
(manual . "Manual"))) (manual . "Manual")))
(result (run-listbox-selection-page (result (run-listbox-selection-page
#:info-text (G_ "Please select a partitioning method.") #:info-text (G_ "Please select a partitioning method.")
@ -677,8 +709,9 @@ (define (run-page devices)
#:button-text (G_ "Exit") #:button-text (G_ "Exit")
#:button-callback-procedure button-exit-action)) #:button-callback-procedure button-exit-action))
(method (car result))) (method (car result)))
(case method (cond
((entire) ((or (eq? method 'entire)
(eq? method 'entire-crypted))
(let* ((device (run-device-page devices)) (let* ((device (run-device-page devices))
(disk-type (disk-probe device)) (disk-type (disk-probe device))
(disk (if disk-type (disk (if disk-type
@ -696,7 +729,7 @@ (define (run-page devices)
(disk-partitions disk))))) (disk-partitions disk)))))
(run-disk-page (list disk) user-partitions (run-disk-page (list disk) user-partitions
#:guided? #t))) #:guided? #t)))
((manual) ((eq? method 'manual)
(let* ((disks (map disk-new devices)) (let* ((disks (map disk-new devices))
(user-partitions (append-map (user-partitions (append-map
create-special-user-partitions create-special-user-partitions
@ -708,11 +741,13 @@ (define (run-page devices)
(init-parted) (init-parted)
(let* ((non-install-devices (non-install-devices)) (let* ((non-install-devices (non-install-devices))
(user-partitions (run-page non-install-devices)) (user-partitions (run-page non-install-devices))
(user-partitions-with-pass (prompt-luks-passwords
user-partitions))
(form (draw-formating-page))) (form (draw-formating-page)))
;; Make sure the disks are not in use before proceeding to formating. ;; Make sure the disks are not in use before proceeding to formating.
(free-parted non-install-devices) (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") "user-partitions")
(format-user-partitions user-partitions) (format-user-partitions user-partitions-with-pass)
(destroy-form-and-pop form) (destroy-form-and-pop form)
user-partitions)) user-partitions))

202
gnu/installer/parted.scm
View file

@ -22,13 +22,16 @@ (define-module (gnu installer parted)
#:use-module (gnu installer newt page) #:use-module (gnu installer newt page)
#:use-module (gnu system uuid) #:use-module (gnu system uuid)
#:use-module ((gnu build file-systems) #: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 syscalls)
#:use-module (guix build utils) #:use-module (guix build utils)
#:use-module (guix records) #:use-module (guix records)
#:use-module (guix utils)
#:use-module (guix i18n) #:use-module (guix i18n)
#:use-module (parted) #:use-module (parted)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (rnrs io ports)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (srfi srfi-34) #:use-module (srfi srfi-34)
@ -41,6 +44,8 @@ (define-module (gnu installer parted)
user-partition-type user-partition-type
user-partition-path user-partition-path
user-partition-disk-path user-partition-disk-path
user-partition-crypt-label
user-partition-crypt-password
user-partition-fs-type user-partition-fs-type
user-partition-bootable? user-partition-bootable?
user-partition-esp? user-partition-esp?
@ -128,6 +133,10 @@ (define-record-type* <user-partition>
(default #f)) (default #f))
(disk-path user-partition-disk-path (disk-path user-partition-disk-path
(default #f)) (default #f))
(crypt-label user-partition-crypt-label
(default #f))
(crypt-password user-partition-crypt-password
(default #f))
(fs-type user-partition-fs-type (fs-type user-partition-fs-type
(default 'ext4)) (default 'ext4))
(bootable? user-partition-bootable? (bootable? user-partition-bootable?
@ -427,7 +436,9 @@ (define (partition-print-flags partition)
(define (maybe-string-pad string length) (define (maybe-string-pad string length)
"Returned a string formatted by padding STRING of LENGTH characters to the "Returned a string formatted by padding STRING of LENGTH characters to the
right. If STRING is #f use an empty string." 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)) (let* ((disk (partition-disk partition))
(device (disk-device disk)) (device (disk-device disk))
@ -452,6 +463,8 @@ (define (maybe-string-pad string length)
(fs-type (partition-fs-type partition)) (fs-type (partition-fs-type partition))
(fs-type-name (and fs-type (fs-type-name (and fs-type
(filesystem-type-name fs-type))) (filesystem-type-name fs-type)))
(crypt-label (and user-partition
(user-partition-crypt-label user-partition)))
(flags (and (not (freespace-partition? partition)) (flags (and (not (freespace-partition? partition))
(partition-print-flags partition))) (partition-print-flags partition)))
(mount-point (and user-partition (mount-point (and user-partition
@ -464,6 +477,7 @@ (define (maybe-string-pad string length)
,(or fs-type-name "") ,(or fs-type-name "")
,(or flags "") ,(or flags "")
,(or mount-point "") ,(or mount-point "")
,(or crypt-label "")
,(maybe-string-pad name 30)))) ,(maybe-string-pad name 30))))
(define (partitions-descriptions partitions user-partitions) (define (partitions-descriptions partitions user-partitions)
@ -525,6 +539,7 @@ (define (user-partition-description user-partition)
(bootable? (user-partition-bootable? user-partition)) (bootable? (user-partition-bootable? user-partition))
(esp? (user-partition-esp? user-partition)) (esp? (user-partition-esp? user-partition))
(need-formating? (user-partition-need-formating? user-partition)) (need-formating? (user-partition-need-formating? user-partition))
(crypt-label (user-partition-crypt-label user-partition))
(size (user-partition-size user-partition)) (size (user-partition-size user-partition))
(mount-point (user-partition-mount-point user-partition))) (mount-point (user-partition-mount-point user-partition)))
`(,@(if has-name? `(,@(if has-name?
@ -555,6 +570,15 @@ (define (user-partition-description user-partition)
(partition-length partition))))) (partition-length partition)))))
`((size . ,(string-append "Size : " size-formatted)))) `((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) ,@(if (or (freespace-partition? partition)
(eq? fs-type 'swap)) (eq? fs-type 'swap))
'() '()
@ -854,7 +878,8 @@ (define (force-user-partitions-formating user-partitions)
user-partitions)) user-partitions))
(define* (auto-partition disk (define* (auto-partition disk
#:key (scheme 'entire-root)) #:key
(scheme 'entire-root))
"Automatically create partitions on DISK. All the previous "Automatically create partitions on DISK. All the previous
partitions (except the ESP on a GPT disk, if present) are wiped. SCHEME is the partitions (except the ESP on a GPT disk, if present) are wiped. SCHEME is the
desired partitioning scheme. It can be 'entire-root or desired partitioning scheme. It can be 'entire-root or
@ -913,46 +938,57 @@ (define* (auto-partition disk
(bios-grub? #t) (bios-grub? #t)
(size bios-grub-size))))) (size bios-grub-size)))))
(new-partitions (new-partitions
(case scheme (cond
((entire-root) ((or (eq? scheme 'entire-root)
`(,@(if start-partition (eq? scheme 'entire-crypted-root))
`(,start-partition) (let ((crypted? (eq? scheme 'entire-crypted-root)))
'()) `(,@(if start-partition
,(user-partition `(,start-partition)
(fs-type 'swap) '())
(size swap-size)) ,@(if crypted?
,(user-partition '()
(fs-type 'ext4) `(,(user-partition
(bootable? has-extended?) (fs-type 'swap)
(size "100%") (size swap-size))))
(mount-point "/")))) ,(user-partition
((entire-root-home) (fs-type 'ext4)
`(,@(if start-partition (bootable? has-extended?)
`(,start-partition) (crypt-label (and crypted? "cryptroot"))
'()) (size "100%")
,(user-partition (mount-point "/")))))
(fs-type 'ext4) ((or (eq? scheme 'entire-root-home)
(bootable? has-extended?) (eq? scheme 'entire-crypted-root-home))
(size "33%") (let ((crypted? (eq? scheme 'entire-crypted-root-home)))
(mount-point "/")) `(,@(if start-partition
,@(if has-extended? `(,start-partition)
`(,(user-partition '())
(type 'extended) ,(user-partition
(size "100%"))) (fs-type 'ext4)
'()) (bootable? has-extended?)
,(user-partition (crypt-label (and crypted? "cryptroot"))
(type (if has-extended? (size "33%")
'logical (mount-point "/"))
'normal)) ,@(if has-extended?
(fs-type 'swap) `(,(user-partition
(size swap-size)) (type 'extended)
,(user-partition (size "100%")))
(type (if has-extended? '())
'logical ,@(if crypted?
'normal)) '()
(fs-type 'ext4) `(,(user-partition
(size "100%") (type (if has-extended?
(mount-point "/home")))))) '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* (force-user-partitions-formating
new-partitions))) new-partitions)))
(create-adjacent-partitions disk (create-adjacent-partitions disk
@ -1013,6 +1049,40 @@ (define (create-swap-partition partition)
(with-null-output-ports (with-null-output-ports
(invoke "mkswap" "-f" partition))) (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) (define (format-user-partitions user-partitions)
"Format the <user-partition> records in USER-PARTITIONS list with "Format the <user-partition> records in USER-PARTITIONS list with
NEED-FORMATING? field set to #t." NEED-FORMATING? field set to #t."
@ -1021,8 +1091,12 @@ (define (format-user-partitions user-partitions)
(let* ((need-formating? (let* ((need-formating?
(user-partition-need-formating? user-partition)) (user-partition-need-formating? user-partition))
(type (user-partition-type 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))) (fs-type (user-partition-fs-type user-partition)))
(when crypt-label
(luks-format-and-open user-partition))
(case fs-type (case fs-type
((ext4) ((ext4)
(and need-formating? (and need-formating?
@ -1061,9 +1135,11 @@ (define (mount-user-partitions user-partitions)
mount-point)) mount-point))
(fs-type (fs-type
(user-partition-fs-type user-partition)) (user-partition-fs-type user-partition))
(crypt-label
(user-partition-crypt-label user-partition))
(mount-type (mount-type
(user-fs-type->mount-type fs-type)) (user-fs-type->mount-type fs-type))
(path (user-partition-path user-partition))) (path (user-partition-upper-path user-partition)))
(mkdir-p target) (mkdir-p target)
(mount path target mount-type))) (mount path target mount-type)))
sorted-partitions))) sorted-partitions)))
@ -1075,10 +1151,14 @@ (define (umount-user-partitions user-partitions)
(for-each (lambda (user-partition) (for-each (lambda (user-partition)
(let* ((mount-point (let* ((mount-point
(user-partition-mount-point user-partition)) (user-partition-mount-point user-partition))
(crypt-label
(user-partition-crypt-label user-partition))
(target (target
(string-append (%installer-target-dir) (string-append (%installer-target-dir)
mount-point))) mount-point)))
(umount target))) (umount target)
(when crypt-label
(luks-close user-partition))))
(reverse sorted-partitions)))) (reverse sorted-partitions))))
(define (find-swap-user-partitions user-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." (gnu system file-systems) module and return it."
(let* ((mount-point (user-partition-mount-point user-partition)) (let* ((mount-point (user-partition-mount-point user-partition))
(fs-type (user-partition-fs-type 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)) (mount-type (user-fs-type->mount-type fs-type))
(path (user-partition-path user-partition)) (path (user-partition-path user-partition))
(upper-path (user-partition-upper-path user-partition))
(uuid (uuid->string (read-partition-uuid path) (uuid (uuid->string (read-partition-uuid path)
fs-type))) fs-type)))
`(file-system `(file-system
(mount-point ,mount-point) (mount-point ,mount-point)
(device (uuid ,uuid (quote ,fs-type))) (device ,@(if crypt-label
(type ,mount-type)))) `(,upper-path)
`((uuid ,uuid (quote ,fs-type)))))
(type ,mount-type)
,@(if crypt-label
'((dependencies mapped-devices))
'()))))
(define (user-partitions->file-systems user-partitions) (define (user-partitions->file-systems user-partitions)
"Convert the given USER-PARTITIONS list of <user-partition> records into a "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-partition->file-system user-partition))))
user-partitions)) 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) (define (bootloader-configuration user-partitions)
"Return the bootloader configuration field for USER-PARTITIONS." "Return the bootloader configuration field for USER-PARTITIONS."
(let* ((root-partition (let* ((root-partition
@ -1159,11 +1256,18 @@ (define (bootloader-configuration user-partitions)
(define (user-partitions->configuration user-partitions) (define (user-partitions->configuration user-partitions)
"Return the configuration field for USER-PARTITIONS." "Return the configuration field for USER-PARTITIONS."
(let* ((swap-user-partitions (find-swap-user-partitions 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) `(,@(if (null? swap-devices)
'() '()
`((swap-devices (list ,@swap-devices)))) `((swap-devices (list ,@swap-devices))))
(bootloader ,@(bootloader-configuration user-partitions)) (bootloader ,@(bootloader-configuration user-partitions))
,@(if (null? crypted-partitions)
'()
`((mapped-devices
(list ,@(map user-partition->mapped-device
crypted-partitions)))))
(file-systems (cons* (file-systems (cons*
,@(user-partitions->file-systems user-partitions) ,@(user-partitions->file-systems user-partitions)
%base-file-systems))))) %base-file-systems)))))