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.

2 files changed, 193 insertions, 54 deletions

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)))))