From cd6c5ddfc8a1a0a6f4085c8201fca20fd819bdfd Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Fri, 11 Dec 2020 10:37:06 +0100
Subject: guix system: 'init' copies, resets timestamps, and deduplicates at
once.
Partly fixes <https://bugs.gnu.org/44760>.
* guix/build/store-copy.scm (copy-store-item): New procedure.
(populate-store): Use it instead of the inline 'copy-recursively' call.
* guix/scripts/system.scm (copy-item): Likewise.
Pass #:reset-timestamps? and #:deduplicate? to 'register-path'.
---
guix/scripts/system.scm | 11 ++++++++---
1 file changed, 8 insertions(+), 3 deletions(-)
(limited to 'guix/scripts/system.scm')
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index db80e0be8f..c08929066b 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -30,6 +30,7 @@
#:use-module ((guix status) #:select (with-status-verbosity))
#:use-module (guix store)
#:autoload (guix store database) (register-path)
+ #:autoload (guix build store-copy) (copy-store-item)
#:use-module (guix describe)
#:use-module (guix grafts)
#:use-module (guix gexp)
@@ -147,8 +148,8 @@ REFERENCES as its set of references."
#:directories? #t))
(delete-file-recursively dest))
- (copy-recursively item dest
- #:log (%make-void-port "w"))
+ (copy-store-item item target
+ #:deduplicate? #t)
;; Register ITEM; as a side-effect, it resets timestamps, etc.
;; Explicitly use "TARGET/var/guix" as the state directory, to avoid
@@ -157,7 +158,11 @@ REFERENCES as its set of references."
(unless (register-path item
#:prefix target
#:state-directory state
- #:references references)
+ #:references references
+
+ ;; Those are taken care of by 'copy-store-item'.
+ #:reset-timestamps? #f
+ #:deduplicate? #f)
(leave (G_ "failed to register '~a' under '~a'~%")
item target))))
--
cgit v1.2.3
From 0682cc593688e7d9a435ca69f05320aa87df06d0 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Fri, 11 Dec 2020 12:03:25 +0100
Subject: database: Remove #:deduplicate? and #:reset-timestamps? from
'register-path'.
* guix/store/database.scm (register-path): Remove #:deduplicate?
and #:reset-timestamps?.
* guix/scripts/system.scm (copy-item): Adjust accordingly.
* tests/store-database.scm ("register-path")
("register-path, directory"): Call 'reset-timestamps'.
---
guix/scripts/system.scm | 6 +-----
guix/store/database.scm | 17 ++---------------
tests/store-database.scm | 5 +++--
3 files changed, 6 insertions(+), 22 deletions(-)
(limited to 'guix/scripts/system.scm')
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index c08929066b..0e543d9460 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -158,11 +158,7 @@ REFERENCES as its set of references."
(unless (register-path item
#:prefix target
#:state-directory state
- #:references references
-
- ;; Those are taken care of by 'copy-store-item'.
- #:reset-timestamps? #f
- #:deduplicate? #f)
+ #:references references)
(leave (G_ "failed to register '~a' under '~a'~%")
item target))))
diff --git a/guix/store/database.scm b/guix/store/database.scm
index 31ea9add78..c0010b72b9 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -384,16 +384,14 @@ is true."
(define* (register-path path
#:key (references '()) deriver prefix
- state-directory (deduplicate? #t)
- (reset-timestamps? #t)
+ state-directory
(schema (sql-schema)))
"Register PATH as a valid store file, with REFERENCES as its list of
references, and DERIVER as its deriver (.drv that led to it.) If PREFIX is
given, it must be the name of the directory containing the new store to
initialize; if STATE-DIRECTORY is given, it must be a string containing the
absolute file name to the state directory of the store being initialized.
-Return #t on success. As a side effect, reset timestamps on PATH, unless
-RESET-TIMESTAMPS? is false.
+Return #t on success.
Use with care as it directly modifies the store! This is primarily meant to
be used internally by the daemon's build hook.
@@ -404,17 +402,6 @@ by adding it as a temp-root."
(store-database-file #:prefix prefix
#:state-directory state-directory))
- (define real-file-name
- (string-append (or prefix "") path))
-
- (when deduplicate?
- (deduplicate real-file-name (nar-sha256 real-file-name)
- #:store (string-append (or prefix "")
- %store-directory)))
-
- (when reset-timestamps?
- (reset-timestamps real-file-name))
-
(parameterize ((sql-schema schema))
(with-database db-file db
(register-items db (list (store-info path deriver references))
diff --git a/tests/store-database.scm b/tests/store-database.scm
index 3b4ef43f6d..33fd6cfbad 100644
--- a/tests/store-database.scm
+++ b/tests/store-database.scm
@@ -34,8 +34,7 @@
(test-begin "store-database")
-(test-equal "register-path"
- '(1 1)
+(test-assert "register-path"
(let ((file (string-append (%store-prefix) "/" (make-string 32 #\f)
"-fake")))
(when (valid-path? %store file)
@@ -46,6 +45,7 @@
(drv (string-append file ".drv")))
(call-with-output-file file
(cut display "This is a fake store item.\n" <>))
+ (reset-timestamps file)
(register-path file
#:references (list ref)
#:deriver drv)
@@ -69,6 +69,7 @@
(mkdir-p (string-append file "/a"))
(call-with-output-file (string-append file "/a/b")
(const #t))
+ (reset-timestamps file)
(register-path file #:deriver drv)
(and (valid-path? %store file)
--
cgit v1.2.3
From 1574bd82bb36ee64574912c3e8855f94a73adc44 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Fri, 11 Dec 2020 12:36:52 +0100
Subject: system: 'init' does not recompute the hash of each store item.
Fixes <https://bugs.gnu.org/44760>.
Previously, the 'register-path' call would re-traverse ITEM to compute
its nar hash, even though that hash is already known in the initial
store. This patch also avoids repeated opening/closing of the
database.
* guix/store/database.scm (call-with-database): Export.
* guix/scripts/system.scm (copy-item): Add 'db' parameter. Call
'sqlite-register' instead of 'register-path'.
(copy-closure): Remove redundant call to 'references*'. Call
'call-with-database' and pass the database to 'copy-item'.
---
.dir-locals.el | 1 +
guix/scripts/system.scm | 59 +++++++++++++++++++++++++++----------------------
guix/store/database.scm | 1 +
3 files changed, 34 insertions(+), 27 deletions(-)
(limited to 'guix/scripts/system.scm')
diff --git a/.dir-locals.el b/.dir-locals.el
index 4eb27d8b1b..8f07a08eb5 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -121,6 +121,7 @@
(eval . (put 'let-system 'scheme-indent-function 1))
(eval . (put 'with-database 'scheme-indent-function 2))
+ (eval . (put 'call-with-database 'scheme-indent-function 1))
(eval . (put 'call-with-transaction 'scheme-indent-function 1))
(eval . (put 'with-statement 'scheme-indent-function 3))
(eval . (put 'call-with-retrying-transaction 'scheme-indent-function 1))
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 0e543d9460..5427f875ec 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -29,7 +29,9 @@
#:use-module (guix ui)
#:use-module ((guix status) #:select (with-status-verbosity))
#:use-module (guix store)
- #:autoload (guix store database) (register-path)
+ #:autoload (guix base16) (bytevector->base16-string)
+ #:autoload (guix store database)
+ (sqlite-register store-database-file call-with-database)
#:autoload (guix build store-copy) (copy-store-item)
#:use-module (guix describe)
#:use-module (guix grafts)
@@ -130,12 +132,11 @@ BODY..., and restore them."
(store-lift topologically-sorted))
-(define* (copy-item item references target
+(define* (copy-item item info target db
#:key (log-port (current-error-port)))
- "Copy ITEM to the store under root directory TARGET and register it with
-REFERENCES as its set of references."
- (let ((dest (string-append target item))
- (state (string-append target "/var/guix")))
+ "Copy ITEM to the store under root directory TARGET and populate DB with the
+given INFO, a <path-info> record."
+ (let ((dest (string-append target item)))
(format log-port "copying '~a'...~%" item)
;; Remove DEST if it exists to make sure that (1) we do not fail badly
@@ -151,41 +152,45 @@ REFERENCES as its set of references."
(copy-store-item item target
#:deduplicate? #t)
- ;; Register ITEM; as a side-effect, it resets timestamps, etc.
- ;; Explicitly use "TARGET/var/guix" as the state directory, to avoid
- ;; reproducing the user's current settings; see
- ;; <http://bugs.gnu.org/18049>.
- (unless (register-path item
- #:prefix target
- #:state-directory state
- #:references references)
- (leave (G_ "failed to register '~a' under '~a'~%")
- item target))))
+ (sqlite-register db
+ #:path item
+ #:references (path-info-references info)
+ #:deriver (path-info-deriver info)
+ #:hash (string-append
+ "sha256:"
+ (bytevector->base16-string (path-info-hash info)))
+ #:nar-size (path-info-nar-size info))))
(define* (copy-closure item target
#:key (log-port (current-error-port)))
"Copy ITEM and all its dependencies to the store under root directory
TARGET, and register them."
(mlet* %store-monad ((to-copy (topologically-sorted* (list item)))
- (refs (mapm %store-monad references* to-copy))
- (info (mapm %store-monad query-path-info*
- (delete-duplicates
- (append to-copy (concatenate refs)))))
+ (info (mapm %store-monad query-path-info* to-copy))
(size -> (reduce + 0 (map path-info-nar-size info))))
(define progress-bar
(progress-reporter/bar (length to-copy)
(format #f (G_ "copying to '~a'...")
target)))
+ (define state
+ (string-append target "/var/guix"))
+
(check-available-space size target)
- (call-with-progress-reporter progress-bar
- (lambda (report)
- (let ((void (%make-void-port "w")))
- (for-each (lambda (item refs)
- (copy-item item refs target #:log-port void)
- (report))
- to-copy refs))))
+ ;; Explicitly use "TARGET/var/guix" as the state directory to avoid
+ ;; reproducing the user's current settings; see
+ ;; <http://bugs.gnu.org/18049>.
+ (call-with-database (store-database-file #:prefix target
+ #:state-directory state)
+ (lambda (db)
+ (call-with-progress-reporter progress-bar
+ (lambda (report)
+ (let ((void (%make-void-port "w")))
+ (for-each (lambda (item info)
+ (copy-item item info target db #:log-port void)
+ (report))
+ to-copy info))))))
(return *unspecified*)))
diff --git a/guix/store/database.scm b/guix/store/database.scm
index c0010b72b9..9d5bc531bb 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -39,6 +39,7 @@
#:export (sql-schema
%default-database-file
store-database-file
+ call-with-database
with-database
path-id
sqlite-register
--
cgit v1.2.3
From f00e68ace070fd5240a4b5874e61c26f6e909b6c Mon Sep 17 00:00:00 2001
From: Miguel Ángel Arruga Vivas <rosen644835@gmail.com>
Date: Mon, 21 Dec 2020 13:02:01 +0100
Subject: system: Allow separated /boot and encrypted root.
* gnu/bootloader/grub.scm (grub-configuration-file): New parameter
store-crypto-devices.
[crypto-devices]: New helper function.
[builder]: Use crypto-devices.
* gnu/machine/ssh.scm (roll-back-managed-host): Use
boot-parameters-store-crypto-devices to provide its contents to the
bootloader configuration generation process.
* gnu/tests/install.scm (%encrypted-root-not-boot-os,
%encrypted-root-not-boot-os): New os declaration.
(%encrypted-root-not-boot-installation-script): New script, whose contents
were initially taken from %encrypted-root-installation-script.
(%test-encrypted-root-not-boot-os): New test.
* gnu/system.scm (define-module): Export
operating-system-bootoader-crypto-devices and
boot-parameters-store-crypto-devices.
(<boot-parameters>): Add field store-crypto-devices.
(read-boot-parameters): Parse store-crypto-devices field.
[uuid-sexp->uuid]: New helper function extracted from
device-sexp->device.
(operating-system-bootloader-crypto-devices): New function.
(operating-system-bootcfg): Use
operating-system-bootloader-crypto-devices to provide its contents to
the bootloader configuration generation process.
(operating-system-boot-parameters): Add store-crypto-devices to the
generated boot-parameters.
(operating-system-boot-parameters-file): Likewise to the file with
the serialized structure.
* guix/scripts/system.scm (reinstall-bootloader): Use
boot-parameters-store-crypto-devices to provide its contents to the
bootloader configuration generation process.
* tests/boot-parameters.scm (%default-store-crypto-devices): New
variable.
(%grub-boot-parameters, test-read-boot-parameters): Use
%default-store-crypto-devices.
(tests store-crypto-devices): New tests.
---
gnu/bootloader/grub.scm | 21 +++++++++-
gnu/machine/ssh.scm | 3 ++
gnu/system.scm | 59 ++++++++++++++++++++++++++-
gnu/tests/install.scm | 102 ++++++++++++++++++++++++++++++++++++++++++++++
guix/scripts/system.scm | 2 +
tests/boot-parameters.scm | 30 +++++++++++++-
6 files changed, 212 insertions(+), 5 deletions(-)
(limited to 'guix/scripts/system.scm')
diff --git a/gnu/bootloader/grub.scm b/gnu/bootloader/grub.scm
index af7b7561ff..29c81ae641 100644
--- a/gnu/bootloader/grub.scm
+++ b/gnu/bootloader/grub.scm
@@ -4,7 +4,7 @@
;;; Copyright © 2017 Leo Famulari <leo@famulari.name>
;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2019, 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
-;;; Copyright © 2019 Miguel Ángel Arruga Vivas <rosen644835@gmail.com>
+;;; Copyright © 2019, 2020 Miguel Ángel Arruga Vivas <rosen644835@gmail.com>
;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2020 Stefan <stefan-guix@vodafonemail.de>
;;;
@@ -359,11 +359,14 @@ code."
(locale #f)
(system (%current-system))
(old-entries '())
+ (store-crypto-devices '())
store-directory-prefix)
"Return the GRUB configuration file corresponding to CONFIG, a
<bootloader-configuration> object, and where the store is available at
STORE-FS, a <file-system> object. OLD-ENTRIES is taken to be a list of menu
entries corresponding to old generations of the system.
+STORE-CRYPTO-DEVICES contain the UUIDs of the encrypted units that must
+be unlocked to access the store contents.
STORE-DIRECTORY-PREFIX may be used to specify a store prefix, as is required
when booting a root file system on a Btrfs subvolume."
(define all-entries
@@ -411,6 +414,21 @@ menuentry ~s {
(string-join (map string-join '#$modules)
"\n module " 'prefix))))))
+ (define (crypto-devices)
+ (define (crypto-device->cryptomount dev)
+ (if (uuid? dev)
+ #~(format port "cryptomount -u ~a~%"
+ ;; cryptomount only accepts UUID without the hypen.
+ #$(string-delete #\- (uuid->string dev)))
+ ;; Other type of devices aren't implemented.
+ #~()))
+ (let ((devices (map crypto-device->cryptomount store-crypto-devices))
+ ;; XXX: Add luks2 when grub 2.06 is packaged.
+ (modules #~(format port "insmod luks~%")))
+ (if (null? devices)
+ devices
+ (cons modules devices))))
+
(define (sugar)
(let* ((entry (first all-entries))
(device (menu-entry-device entry))
@@ -474,6 +492,7 @@ keymap ~a~%" #$keymap))))
"# This file was generated from your Guix configuration. Any changes
# will be lost upon reconfiguration.
")
+ #$@(crypto-devices)
#$(sugar)
#$locale-config
#$keyboard-layout-config
diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index 1b748c8da7..08c653ba17 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -484,6 +484,8 @@ an environment type of 'managed-host."
(list (second boot-parameters))))
(locale -> (boot-parameters-locale
(second boot-parameters)))
+ (crypto-dev -> (boot-parameters-store-crypto-devices
+ (second boot-parameters)))
(store-dir -> (boot-parameters-store-directory-prefix
(second boot-parameters)))
(old-entries -> (map boot-parameters->menu-entry
@@ -496,6 +498,7 @@ an environment type of 'managed-host."
bootloader))
bootloader entries
#:locale locale
+ #:store-crypto-devices crypto-dev
#:store-directory-prefix store-dir
#:old-entries old-entries)))
(remote-result (machine-remote-eval machine remote-exp)))
diff --git a/gnu/system.scm b/gnu/system.scm
index fcf3310fa3..c284a18379 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -5,7 +5,7 @@
;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2019 Meiyo Peng <meiyo.peng@gmail.com>
-;;; Copyright © 2019 Miguel Ángel Arruga Vivas <rosen644835@gmail.com>
+;;; Copyright © 2019, 2020 Miguel Ángel Arruga Vivas <rosen644835@gmail.com>
;;; Copyright © 2020 Danny Milosavljevic <dannym@scratchpost.org>
;;; Copyright © 2020 Brice Waegeneire <brice@waegenei.re>
;;; Copyright © 2020 Florian Pelz <pelzflorian@pelzflorian.de>
@@ -112,6 +112,7 @@
operating-system-store-file-system
operating-system-user-mapped-devices
operating-system-boot-mapped-devices
+ operating-system-bootloader-crypto-devices
operating-system-activation-script
operating-system-user-accounts
operating-system-shepherd-service-names
@@ -147,6 +148,7 @@
boot-parameters-root-device
boot-parameters-bootloader-name
boot-parameters-bootloader-menu-entries
+ boot-parameters-store-crypto-devices
boot-parameters-store-device
boot-parameters-store-directory-prefix
boot-parameters-store-mount-point
@@ -305,6 +307,8 @@ directly by the user."
(store-device boot-parameters-store-device)
(store-mount-point boot-parameters-store-mount-point)
(store-directory-prefix boot-parameters-store-directory-prefix)
+ (store-crypto-devices boot-parameters-store-crypto-devices
+ (default '()))
(locale boot-parameters-locale)
(kernel boot-parameters-kernel)
(kernel-arguments boot-parameters-kernel-arguments)
@@ -338,6 +342,13 @@ file system labels."
(if (string-prefix? "/" device)
device
(file-system-label device))))))
+ (define uuid-sexp->uuid
+ (match-lambda
+ (('uuid (? symbol? type) (? bytevector? bv))
+ (bytevector->uuid bv type))
+ (x
+ (warning (G_ "unrecognized uuid ~a at '~a'~%") x (port-filename port))
+ #f)))
(match (read port)
(('boot-parameters ('version 0)
@@ -411,6 +422,23 @@ file system labels."
;; No store found, old format.
#f)))
+ (store-crypto-devices
+ (match (assq 'store rest)
+ (('store . store-data)
+ (match (assq 'crypto-devices store-data)
+ (('crypto-devices (devices ...))
+ (map uuid-sexp->uuid devices))
+ (('crypto-devices dev)
+ (warning (G_ "unrecognized crypto-devices ~S at '~a'~%")
+ dev (port-filename port))
+ '())
+ (_
+ ;; No crypto-devices found.
+ '())))
+ (_
+ ;; No store found, old format.
+ '())))
+
(store-mount-point
(match (assq 'store rest)
(('store ('device _) ('mount-point mount-point) _ ...)
@@ -525,6 +553,26 @@ from the initrd."
(any file-system-needed-for-boot? users)))
devices)))
+(define (operating-system-bootloader-crypto-devices os)
+ "Return the subset of mapped devices that the bootloader must open.
+Only devices specified by uuid are supported."
+ (define (valid-crypto-device? dev)
+ (or (uuid? dev)
+ (begin
+ (warning (G_ "\
+mapped-device '~a' may not be mounted by the bootloader.~%")
+ dev)
+ #f)))
+ (filter-map (match-lambda
+ ((and (= mapped-device-type type)
+ (= mapped-device-source source))
+ (and (eq? luks-device-mapping type)
+ (valid-crypto-device? source)
+ source))
+ (_ #f))
+ ;; XXX: Ordering is important, we trust the returned one.
+ (operating-system-boot-mapped-devices os)))
+
(define (device-mapping-services os)
"Return the list of device-mapping services for OS as a list."
(map device-mapping-service
@@ -1261,6 +1309,7 @@ a list of <menu-entry>, to populate the \"old entries\" menu."
(root-fs (operating-system-root-file-system os))
(root-device (file-system-device root-fs))
(locale (operating-system-locale os))
+ (crypto-devices (operating-system-bootloader-crypto-devices os))
(params (operating-system-boot-parameters
os root-device
#:system-kernel-arguments? #t))
@@ -1274,6 +1323,7 @@ a list of <menu-entry>, to populate the \"old entries\" menu."
(generate-config-file bootloader-conf (list entry)
#:old-entries old-entries
#:locale locale
+ #:store-crypto-devices crypto-devices
#:store-directory-prefix
(btrfs-store-subvolume-file-name file-systems))))
@@ -1313,6 +1363,7 @@ such as '--root' and '--load' to <boot-parameters>."
(operating-system-initrd-file os)))
(store (operating-system-store-file-system os))
(file-systems (operating-system-file-systems os))
+ (crypto-devices (operating-system-bootloader-crypto-devices os))
(locale (operating-system-locale os))
(bootloader (bootloader-configuration-bootloader
(operating-system-bootloader os)))
@@ -1335,6 +1386,7 @@ such as '--root' and '--load' to <boot-parameters>."
(locale locale)
(store-device (ensure-not-/dev (file-system-device store)))
(store-directory-prefix (btrfs-store-subvolume-file-name file-systems))
+ (store-crypto-devices crypto-devices)
(store-mount-point (file-system-mount-point store)))))
(define (device->sexp device)
@@ -1393,7 +1445,10 @@ being stored into the \"parameters\" file)."
(mount-point #$(boot-parameters-store-mount-point
params))
(directory-prefix
- #$(boot-parameters-store-directory-prefix params))))
+ #$(boot-parameters-store-directory-prefix params))
+ (crypto-devices
+ #$(map device->sexp
+ (boot-parameters-store-crypto-devices params)))))
#:set-load-path? #f)))
(define-gexp-compiler (operating-system-compiler (os <operating-system>)
diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm
index 71caa3a493..bf94e97c2a 100644
--- a/gnu/tests/install.scm
+++ b/gnu/tests/install.scm
@@ -63,6 +63,7 @@
%test-separate-home-os
%test-raid-root-os
%test-encrypted-root-os
+ %test-encrypted-root-not-boot-os
%test-btrfs-root-os
%test-btrfs-root-on-subvolume-os
%test-jfs-root-os
@@ -883,6 +884,107 @@ reboot\n")
(run-basic-test %lvm-separate-home-os
`(,@command) "lvm-separate-home-os")))))
+
+;;;
+;;; LUKS-encrypted root file system and /boot in a non-encrypted partition.
+;;;
+
+(define-os-with-source (%encrypted-root-not-boot-os
+ %encrypted-root-not-boot-os-source)
+ ;; The OS we want to install.
+ (use-modules (gnu) (gnu tests) (srfi srfi-1))
+
+ (operating-system
+ (host-name "bootroot")
+ (timezone "Europe/Madrid")
+ (locale "en_US.UTF-8")
+
+ (bootloader (bootloader-configuration
+ (bootloader grub-bootloader)
+ (target "/dev/vdb")))
+
+ (mapped-devices (list (mapped-device
+ (source
+ (uuid "12345678-1234-1234-1234-123456789abc"))
+ (target "root")
+ (type luks-device-mapping))))
+ (file-systems (cons* (file-system
+ (device (file-system-label "my-boot"))
+ (mount-point "/boot")
+ (type "ext4"))
+ (file-system
+ (device "/dev/mapper/root")
+ (mount-point "/")
+ (type "ext4"))
+ %base-file-systems))
+ (users (cons (user-account
+ (name "alice")
+ (group "users")
+ (supplementary-groups '("wheel" "audio" "video")))
+ %base-user-accounts))
+ (services (cons (service marionette-service-type
+ (marionette-configuration
+ (imported-modules '((gnu services herd)
+ (guix combinators)))))
+ %base-services))))
+
+(define %encrypted-root-not-boot-installation-script
+ ;; Shell script for an installation with boot not encrypted but root
+ ;; encrypted.
+ (format #f "\
+. /etc/profile
+set -e -x
+guix --version
+
+export GUIX_BUILD_OPTIONS=--no-grafts
+ls -l /run/current-system/gc-roots
+parted --script /dev/vdb mklabel gpt \\
+ mkpart primary ext2 1M 3M \\
+ mkpart primary ext2 3M 50M \\
+ mkpart primary ext2 50M 1.6G \\
+ set 1 boot on \\
+ set 1 bios_grub on
+echo -n \"~a\" | cryptsetup luksFormat --uuid=\"~a\" -q /dev/vdb3 -
+echo -n \"~a\" | cryptsetup open --type luks --key-file - /dev/vdb3 root
+mkfs.ext4 -L my-root /dev/mapper/root
+mkfs.ext4 -L my-boot /dev/vdb2
+mount LABEL=my-root /mnt
+mkdir /mnt/boot
+mount LABEL=my-boot /mnt/boot
+echo \"Checking mounts\"
+mount
+herd start cow-store /mnt
+mkdir /mnt/etc
+cp /etc/target-config.scm /mnt/etc/config.scm
+guix system build /mnt/etc/config.scm
+guix system init /mnt/etc/config.scm /mnt --no-substitutes
+sync
+echo \"Debugging info\"
+blkid
+cat /mnt/boot/grub/grub.cfg
+reboot\n"
+ %luks-passphrase "12345678-1234-1234-1234-123456789abc"
+ %luks-passphrase))
+
+(define %test-encrypted-root-not-boot-os
+ (system-test
+ (name "encrypted-root-not-boot-os")
+ (description
+ "Test the manual installation on an OS with / in an encrypted partition
+but /boot on a different, non-encrypted partition. This test is expensive in
+terms of CPU and storage usage since we need to build (current-guix) and then
+store a couple of full system images.")
+ (value
+ (mlet* %store-monad
+ ((image (run-install %encrypted-root-not-boot-os
+ %encrypted-root-not-boot-os-source
+ #:script
+ %encrypted-root-not-boot-installation-script))
+ (command (qemu-command/writable-image image)))
+ (run-basic-test %encrypted-root-not-boot-os command
+ "encrypted-root-not-boot-os"
+ #:initialization enter-luks-passphrase)))))
+
;;;
;;; Btrfs root file system.
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 5427f875ec..0dcf2b3afe 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -391,6 +391,7 @@ STORE is an open connection to the store."
(params (first (profile-boot-parameters %system-profile
(list number))))
(locale (boot-parameters-locale params))
+ (store-crypto-devices (boot-parameters-store-crypto-devices params))
(store-directory-prefix
(boot-parameters-store-directory-prefix params))
(old-generations
@@ -406,6 +407,7 @@ STORE is an open connection to the store."
((bootloader-configuration-file-generator bootloader)
bootloader-config entries
#:locale locale
+ #:store-crypto-devices store-crypto-devices
#:store-directory-prefix store-directory-prefix
#:old-entries old-entries)))
(drvs -> (list bootcfg)))
diff --git a/tests/boot-parameters.scm b/tests/boot-parameters.scm
index a00b227551..3deae564c4 100644
--- a/tests/boot-parameters.scm
+++ b/tests/boot-parameters.scm
@@ -50,6 +50,9 @@
(define %default-store-directory-prefix
(string-append "/" %default-btrfs-subvolume))
(define %default-store-mount-point (%store-prefix))
+(define %default-store-crypto-devices
+ (list (uuid "00000000-1111-2222-3333-444444444444")
+ (uuid "55555555-6666-7777-8888-999999999999")))
(define %default-multiboot-modules '())
(define %default-locale "es_ES.utf8")
(define %root-path "/")
@@ -67,6 +70,7 @@
(locale %default-locale)
(store-device %default-store-device)
(store-directory-prefix %default-store-directory-prefix)
+ (store-crypto-devices %default-store-crypto-devices)
(store-mount-point %default-store-mount-point)))
(define %default-operating-system
@@ -110,6 +114,8 @@
(with-store #t)
(store-device
(quote-uuid %default-store-device))
+ (store-crypto-devices
+ (map quote-uuid %default-store-crypto-devices))
(store-directory-prefix %default-store-directory-prefix)
(store-mount-point %default-store-mount-point))
(define (generate-boot-parameters)
@@ -125,12 +131,14 @@
(sexp-or-nothing " (kernel-arguments ~S)" kernel-arguments)
(sexp-or-nothing " (initrd ~S)" initrd)
(if with-store
- (format #false " (store~a~a~a)"
+ (format #false " (store~a~a~a~a)"
(sexp-or-nothing " (device ~S)" store-device)
(sexp-or-nothing " (mount-point ~S)"
store-mount-point)
(sexp-or-nothing " (directory-prefix ~S)"
- store-directory-prefix))
+ store-directory-prefix)
+ (sexp-or-nothing " (crypto-devices ~S)"
+ store-crypto-devices))
"")
(sexp-or-nothing " (locale ~S)" locale)
(sexp-or-nothing " (bootloader-name ~a)" bootloader-name)
@@ -158,6 +166,7 @@
(test-read-boot-parameters #:with-store #false)
(test-read-boot-parameters #:store-device #false)
(test-read-boot-parameters #:store-device 'false)
+ (test-read-boot-parameters #:store-crypto-devices #false)
(test-read-boot-parameters #:store-mount-point #false)
(test-read-boot-parameters #:store-directory-prefix #false)
(test-read-boot-parameters #:multiboot-modules #false)
@@ -254,6 +263,23 @@
(boot-parameters-store-mount-point
(test-read-boot-parameters #:with-store #false)))
+(test-equal "read, store-crypto-devices, default"
+ '()
+ (boot-parameters-store-crypto-devices
+ (test-read-boot-parameters #:store-crypto-devices #false)))
+
+;; XXX: <warning: unrecognized crypto-devices #f at '#f'>
+(test-equal "read, store-crypto-devices, false"
+ '()
+ (boot-parameters-store-crypto-devices
+ (test-read-boot-parameters #:store-crypto-devices 'false)))
+
+;; XXX: <warning: unrecognized crypto-device "bad" at '#f'>
+(test-equal "read, store-crypto-devices, string"
+ '()
+ (boot-parameters-store-crypto-devices
+ (test-read-boot-parameters #:store-crypto-devices "bad")))
+
;; For whitebox testing
(define operating-system-boot-parameters
(@@ (gnu system) operating-system-boot-parameters))
--
cgit v1.2.3