summaryrefslogtreecommitdiff
path: root/gnu
diff options
context:
space:
mode:
Diffstat (limited to 'gnu')
-rw-r--r--gnu/installer.scm2
-rw-r--r--gnu/installer/newt/partition.scm45
-rw-r--r--gnu/installer/parted.scm202
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)))))