diff --git a/gnu/system.scm b/gnu/system.scm index 768ca9c..da41ba6 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -210,6 +210,16 @@ as 'needed-for-boot'." (string=? (file-system-device fs) target))) file-systems))) +(define (file-system-mapped-device file-system devices) + "Return the mapped-device among DEVICES that backs FILE-SYSTEM, or #f." + (and (eq? 'device (file-system-title file-system)) + (string-prefix? "/dev/mapper/" (file-system-device file-system)) + (let ((name (string-drop (file-system-device file-system) + (string-length "/dev/mapper/")))) + (find (lambda (md) + (string=? (mapped-device-target md) name)) + devices)))) + (define (operating-system-user-mapped-devices os) "Return the subset of mapped devices that can be installed in user-land--i.e., those not needed during boot." @@ -674,6 +684,15 @@ listed in OS. The C library expects to find it under "Return the file system that contains the store of OS." (store-file-system (operating-system-file-systems os))) +(define (grub-config-for-store-file-system os) + (let ((md (file-system-mapped-device (operating-system-store-file-system os) + (operating-system-mapped-devices os)))) + (if md + (let* ((type (mapped-device-type md)) + (grub (mapped-device-kind-grub type))) + (grub (mapped-device-source md) (mapped-device-target md))) + '()))) + (define* (operating-system-grub.cfg os #:optional (old-entries '())) "Return the GRUB configuration file for OS. Use OLD-ENTRIES to populate the \"old entries\" menu." @@ -694,7 +713,8 @@ listed in OS. The C library expects to find it under #~(string-append "--load=" #$system "/boot") (operating-system-kernel-arguments os))) - (initrd #~(string-append #$system "/initrd")))))) + (initrd #~(string-append #$system "/initrd")) + (extra-lines (grub-config-for-store-file-system os)))))) (grub-configuration-file (operating-system-bootloader os) store-fs entries #:old-entries old-entries))) diff --git a/gnu/system/examples/bare-bones.tmpl b/gnu/system/examples/bare-bones.tmpl index 87e8d1e..b85593d 100644 --- a/gnu/system/examples/bare-bones.tmpl +++ b/gnu/system/examples/bare-bones.tmpl @@ -13,9 +13,13 @@ ;; Assuming /dev/sdX is the target hard disk, and "my-root" is ;; the label of the target root file system. (bootloader (grub-configuration (device "/dev/sdX"))) + (mapped-devices (list (mapped-device + (source (uuid "cb67fc72-0d54-4c88-9d4b-b225f30b0f44")) + (target "foo") + (type luks-device-mapping)))) (file-systems (cons (file-system - (device "my-root") - (title 'label) + (device "/dev/mapper/foo") + (title 'device) (mount-point "/") (type "ext4")) %base-file-systems)) diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm index 45b46ca..60cc044 100644 --- a/gnu/system/grub.scm +++ b/gnu/system/grub.scm @@ -114,7 +114,9 @@ (linux menu-entry-linux) (linux-arguments menu-entry-linux-arguments (default '())) ; list of string-valued gexps - (initrd menu-entry-initrd)) ; file name of the initrd as a gexp + (initrd menu-entry-initrd) ; file name of the initrd as a gexp + (extra-lines menu-entry-extra-lines ; list of string-valued gexps + (default '()))) ;;; @@ -253,13 +255,14 @@ corresponding to old generations of the system." (define entry->gexp (match-lambda - (($ label linux arguments initrd) - #~(format port "menuentry ~s { + (($ label linux arguments initrd extra-lines) + #~(format port "menuentry ~s {~{~% ~a~} ~a linux ~a/~a ~a initrd ~a }~%" #$label + (list #$@extra-lines) #$(grub-root-search store-fs #~(string-append #$linux "/" #$linux-image-name)) @@ -268,22 +271,25 @@ corresponding to old generations of the system." (mlet %store-monad ((sugar (eye-candy config store-fs system #~port))) (define builder - #~(call-with-output-file #$output - (lambda (port) - #$sugar - (format port " + #~(begin + (use-modules (ice-9 format)) + + (call-with-output-file #$output + (lambda (port) + #$sugar + (format port " set default=~a set timeout=~a~%" - #$(grub-configuration-default-entry config) - #$(grub-configuration-timeout config)) - #$@(map entry->gexp all-entries) + #$(grub-configuration-default-entry config) + #$(grub-configuration-timeout config)) + #$@(map entry->gexp all-entries) - #$@(if (pair? old-entries) - #~((format port " + #$@(if (pair? old-entries) + #~((format port " submenu \"GNU system, old configurations...\" {~%") - #$@(map entry->gexp old-entries) - (format port "}~%")) - #~())))) + #$@(map entry->gexp old-entries) + (format port "}~%")) + #~()))))) (gexp->derivation "grub.cfg" builder))) diff --git a/gnu/system/mapped-devices.scm b/gnu/system/mapped-devices.scm index 450b473..ddb6c8d 100644 --- a/gnu/system/mapped-devices.scm +++ b/gnu/system/mapped-devices.scm @@ -22,7 +22,11 @@ #:use-module (gnu services) #:use-module (gnu services shepherd) #:autoload (gnu packages cryptsetup) (cryptsetup) + #:autoload (gnu build file-systems) (uuid->string) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:use-module (rnrs bytevectors) #:use-module (ice-9 match) #:export (mapped-device mapped-device? @@ -34,6 +38,7 @@ mapped-device-kind? mapped-device-kind-open mapped-device-kind-close + mapped-device-kind-grub device-mapping-service-type device-mapping-service @@ -59,7 +64,9 @@ mapped-device-kind? (open mapped-device-kind-open) ;source target -> gexp (close mapped-device-kind-close ;source target -> gexp - (default (const #~(const #f))))) + (default (const #~(const #f)))) + (grub mapped-device-kind-grub ;source target -> gexp list + (default #f))) ;| #f ;;; @@ -121,10 +128,21 @@ #~(zero? (system* (string-append #$cryptsetup "/sbin/cryptsetup") "close" #$target))) +(define (grub-luks-device source target) + (if (bytevector? source) + (list "insmod luks" + (string-append "cryptomount -u " (uuid->string source))) + (raise + (condition + (&message + (message (format #f "LUKS mapped-device source must be a UUID: ~s" + source))))))) + (define luks-device-mapping ;; The type of LUKS mapped devices. (mapped-device-kind (open open-luks-device) - (close close-luks-device))) + (close close-luks-device) + (grub grub-luks-device))) ;;; mapped-devices.scm ends here