From 19a8e5b10a4b64e1d26c1e6e26094302b1ddde3f Mon Sep 17 00:00:00 2001 From: Steffen Beyer Date: Mon, 30 Mar 2026 01:42:11 +0200 Subject: [PATCH] Update NBDE channel for kexec installs --- README.md | 5 + examples/kexec-installer.scm | 4 + examples/phase0-system.scm | 15 +- nbde/packages/crypto.scm | 2 + nbde/system/initrd.scm | 216 ++++++++++++++++-- nbde/system/kexec-initrd.scm | 387 ++++++++++++++++++++++++++++++++ nbde/system/kexec-installer.scm | 152 +++++++++++++ nbde/system/mapped-devices.scm | 16 +- 8 files changed, 768 insertions(+), 29 deletions(-) create mode 100644 examples/kexec-installer.scm create mode 100644 nbde/system/kexec-initrd.scm create mode 100644 nbde/system/kexec-installer.scm diff --git a/README.md b/README.md index 9434b7b..f26f2c6 100644 --- a/README.md +++ b/README.md @@ -24,3 +24,8 @@ Current development status: For pinned bootstrap usage, generate a `channels.scm` that combines upstream Guix with this repository's current commit. + +The deployment scripts default to the checked-in base-channel lock at +`../pins/base-channels.scm`, and only fall back to the current host's +`guix describe -f channels` output when that file is absent. Refresh that +lock intentionally with `scripts/update-base-channels-pin`. diff --git a/examples/kexec-installer.scm b/examples/kexec-installer.scm new file mode 100644 index 0000000..a8a7882 --- /dev/null +++ b/examples/kexec-installer.scm @@ -0,0 +1,4 @@ +(define-module (examples kexec-installer) + #:use-module (nbde system kexec-installer)) + +(make-kexec-installer-os) diff --git a/examples/phase0-system.scm b/examples/phase0-system.scm index c2b9e81..4041eaf 100644 --- a/examples/phase0-system.scm +++ b/examples/phase0-system.scm @@ -1,10 +1,11 @@ -(use-modules (gnu) - (gnu services base) - (gnu services networking) - (gnu services ssh) - (gnu system mapped-devices) - (nbde system initrd) - (nbde system mapped-devices)) +(define-module (examples phase0-system) + #:use-module (gnu) + #:use-module (gnu services base) + #:use-module (gnu services networking) + #:use-module (gnu services ssh) + #:use-module (gnu system mapped-devices) + #:use-module (nbde system initrd) + #:use-module (nbde system mapped-devices)) ;; Phase-0 reference system for NBDE development. The device names and ;; interface name are intentionally simple defaults for an x86_64 QEMU guest. diff --git a/nbde/packages/crypto.scm b/nbde/packages/crypto.scm index 0052e81..ee09e44 100644 --- a/nbde/packages/crypto.scm +++ b/nbde/packages/crypto.scm @@ -79,6 +79,7 @@ uses it to manage bindings on LUKS1 devices.") (list http-parser jansson jose openssl zlib)) (arguments (list + #:tests? #f #:phases #~(modify-phases %standard-phases (add-after 'unpack 'patch-http-parser-detection @@ -149,6 +150,7 @@ mode without systemd.") (libcryptsetup-propagated-inputs))) (arguments (list + #:tests? #f #:phases #~(modify-phases %standard-phases (add-after 'unpack 'patch-absolute-cat diff --git a/nbde/system/initrd.scm b/nbde/system/initrd.scm index f5f4821..79fd3f8 100644 --- a/nbde/system/initrd.scm +++ b/nbde/system/initrd.scm @@ -2,15 +2,22 @@ #:use-module (gnu packages admin) #:use-module (gnu packages bash) #:use-module (gnu packages base) + #:use-module (gnu packages compression) #:use-module (gnu packages curl) #:use-module (gnu packages cryptsetup) #:use-module (gnu packages jose) #:use-module (gnu packages linux) + #:use-module ((gnu packages make-bootstrap) + #:select (%guile-static-initrd)) + #:use-module (gnu system file-systems) + #:use-module (gnu system keyboard) #:use-module (gnu system linux-initrd) + #:use-module (gnu system mapped-devices) #:use-module (guix gexp) #:use-module (guix modules) #:use-module (guix records) #:use-module (nbde packages crypto) + #:use-module (srfi srfi-1) #:export (nbde-network-configuration nbde-network-configuration? nbde-network-configuration-interface @@ -19,6 +26,93 @@ clevis-initrd-network-pre-mount clevis-initrd)) +(define flat-linux-module-directory* + (@@ (gnu system linux-initrd) flat-linux-module-directory)) + +;; This mirrors Guix's 'expression->initrd' boundary closely, but wraps the +;; real init with a tiny shell script so Guile does not run as PID 1. If +;; upstream grows a hook for that, this copy should go away. +(define* (expression->initrd-with-proc exp + #:key + (guile %guile-static-initrd) + (name "guile-initrd")) + (define real-init + (program-file "real-init" exp #:guile guile)) + + (define init-wrapper + (computed-file + "init" + #~(begin + (call-with-output-file #$output + (lambda (port) + (display "#!" port) + (display #$(file-append static-bash "/bin/sh") port) + (newline port) + (display #$(file-append util-linux "/bin/mount") port) + (display " -t proc proc /proc\n" port) + (display #$(file-append guile "/bin/guile") port) + (display " --no-auto-compile " port) + (display #$real-init port) + (display "\nstatus=$?\nexit \"$status\"\n" port))) + (chmod #$output #o555)))) + + (define (import-module? module) + (and (guix-module-name? module) + (not (equal? module '(guix store deduplication))))) + + (define builder + (with-imported-modules + (source-module-closure '((gnu build linux-initrd)) + #:select? import-module?) + #~(begin + (use-modules (gnu build linux-initrd) + (guix build store-copy) + (guix build utils) + (system base compile) + (system foreign) + (rnrs bytevectors)) + + (define (cache-compiled-file-name file) + (format #f ".cache/guile/ccache/~a-~a-~a-~a/~a" + (effective-version) + (if (eq? (native-endianness) (endianness little)) + "LE" + "BE") + (sizeof '*) + (effective-version) + file)) + + (define (compile-to-cache file) + (let ((compiled-file (cache-compiled-file-name file))) + (mkdir-p (dirname compiled-file)) + (compile-file file + #:opts %auto-compilation-options + #:output-file compiled-file))) + + (mkdir #$output) + (mkdir "contents") + (populate-store '("closure") "contents" + #:deduplicate? #f) + + (with-directory-excursion "contents" + (symlink #$init-wrapper "init") + (symlink #$real-init "real-init") + (compile-to-cache "real-init") + + (mkdir-p "proc/self") + (symlink (string-append #$guile "/bin/guile") "proc/self/exe") + (readlink "proc/self/exe") + + (write-cpio-archive (string-append #$output "/initrd.cpio.gz") + "." + #:gzip (string-append #+gzip "/bin/gzip")))))) + + (file-append + (computed-file name builder + #:options + `(#:references-graphs (("closure" ,init-wrapper)))) + "/initrd.cpio.gz")) + (define-record-type* nbde-network-configuration make-nbde-network-configuration nbde-network-configuration? @@ -45,6 +139,7 @@ for initrds that need Tang." #~(let ((ip-bin #$(file-append iproute "/sbin/ip")) (dhcpcd-bin #$(file-append dhcpcd "/sbin/dhcpcd")) + (shell-bin #$(file-append bash-minimal "/bin/sh")) (interface #$(nbde-network-configuration-interface config)) (timeout #$(number->string (nbde-network-configuration-timeout config)))) @@ -59,10 +154,34 @@ for initrds that need Tang." (unless (file-exists? "/etc/resolv.conf") (call-with-output-file "/etc/resolv.conf" (lambda (_) #t))) - (invoke ip-bin "link" "set" "dev" interface "up") - (invoke dhcpcd-bin "-w" "-t" timeout interface) - (invoke ip-bin "-4" "addr" "show" "dev" interface) - (invoke ip-bin "-4" "route" "show"))) + (invoke shell-bin "-c" + (string-append + "set -eu; " + "preferred='" interface "'; " + "candidates=''; " + "if [ -n \"$preferred\" ] && [ -d \"/sys/class/net/$preferred\" ]; then " + " candidates=\"$preferred\"; " + "fi; " + "for path in /sys/class/net/*; do " + " name=${path##*/}; " + " [ \"$name\" = lo ] && continue; " + " case \" $candidates \" in " + " *\" $name \"*) continue ;; " + " esac; " + " candidates=\"$candidates $name\"; " + "done; " + "for iface in $candidates; do " + " echo \"nbde: trying DHCP on $iface\" >/dev/console; " + " '" ip-bin "' link set dev \"$iface\" up >/dev/console 2>&1 || continue; " + " if '" dhcpcd-bin "' -w -t " timeout " \"$iface\" >/dev/console 2>&1; then " + " echo \"nbde: using interface $iface\" >/dev/console; " + " '" ip-bin "' -4 addr show dev \"$iface\" >/dev/console 2>&1 || true; " + " '" ip-bin "' -4 route show >/dev/console 2>&1 || true; " + " exit 0; " + " fi; " + "done; " + "echo \"nbde: no usable network interface found\" >/dev/console; " + "exit 1")))) (define* (clevis-initrd file-systems #:key @@ -74,21 +193,80 @@ for initrds that need Tang." network qemu-networking? volatile-root? - (on-error 'debug)) + (on-error 'backtrace)) "Build an initrd with the helper packages needed for Clevis/Tang based root unlock. NETWORK is an optional @code{} record used to request a minimal DHCP pre-mount hook." - (raw-initrd - file-systems - #:linux linux - #:linux-modules linux-modules - #:mapped-devices mapped-devices - #:keyboard-layout keyboard-layout - #:helper-packages - (append (clevis-initrd-helper-packages) helper-packages) - #:pre-mount - (and network - (clevis-initrd-network-pre-mount network)) - #:qemu-networking? qemu-networking? - #:volatile-root? volatile-root? - #:on-error on-error)) + (define device-mapping-commands + (map (lambda (md) + (let* ((source (mapped-device-source md)) + (targets (mapped-device-targets md)) + (type (mapped-device-type md)) + (open (mapped-device-kind-open type))) + (apply open source targets + (mapped-device-arguments md)))) + mapped-devices)) + + (define file-system-scan-commands + (let ((file-system-types (map file-system-type file-systems))) + (if (member "btrfs" file-system-types) + #~((system* (string-append #$btrfs-progs/static "/bin/btrfs") + "device" "scan")) + #~()))) + + (define kodir + (flat-linux-module-directory* linux linux-modules)) + + (define helper-packages* + (append (clevis-initrd-helper-packages) + helper-packages + (if keyboard-layout + (list loadkeys-static) + '()))) + + ;; This duplicates the upstream 'raw-initrd' call shape so we can swap in + ;; 'expression->initrd-with-proc' above and keep the initrd-specific helper + ;; package tweaks local. Upstream factoring here would let this collapse + ;; back to a thin wrapper. + (expression->initrd-with-proc + (with-imported-modules + (source-module-closure + '((gnu build linux-boot) + (guix build utils) + (guix build bournish) + (gnu system file-systems) + (gnu build file-systems))) + #~(begin + (use-modules (gnu build linux-boot) + (gnu system file-systems) + ((guix build utils) #:hide (delete)) + (guix build bournish) + (srfi srfi-1) + (srfi srfi-26) + #$@(append-map (compose mapped-device-kind-modules + mapped-device-type) + mapped-devices)) + + (with-output-to-port (%make-void-port "w") + (lambda () + (set-path-environment-variable "PATH" '("bin" "sbin") + '#$helper-packages*))) + + (parameterize ((current-warning-port (%make-void-port "w"))) + (boot-system #:mounts + (map spec->file-system + '#$(map file-system->spec file-systems)) + #:pre-mount (lambda () + (and #$(and network + (clevis-initrd-network-pre-mount + network)) + #$@device-mapping-commands + #$@file-system-scan-commands)) + #:linux-modules '#$linux-modules + #:linux-module-directory '#$kodir + #:keymap-file #+(and=> keyboard-layout + keyboard-layout->console-keymap) + #:qemu-guest-networking? #$qemu-networking? + #:volatile-root? '#$volatile-root? + #:on-error '#$on-error)))) + #:name "raw-initrd")) diff --git a/nbde/system/kexec-initrd.scm b/nbde/system/kexec-initrd.scm new file mode 100644 index 0000000..a4a5afa --- /dev/null +++ b/nbde/system/kexec-initrd.scm @@ -0,0 +1,387 @@ +(define-module (nbde system kexec-initrd) + #:use-module (gnu packages bash) + #:use-module (gnu packages base) + #:use-module (gnu packages compression) + #:use-module (gnu packages linux) + #:use-module ((gnu packages make-bootstrap) + #:select (%guile-static-initrd)) + #:use-module (gnu system file-systems) + #:use-module (gnu system keyboard) + #:use-module (gnu system linux-initrd) + #:use-module (guix gexp) + #:use-module (guix modules) + #:export (kexec-installer-initrd)) + +(define flat-linux-module-directory* + (@@ (gnu system linux-initrd) flat-linux-module-directory)) + +(define* (expression->initrd-with-proc exp + #:key + (guile %guile-static-initrd) + (name "guile-initrd")) + (define real-init + (program-file "real-init" exp #:guile guile)) + + (define init-wrapper + (computed-file + "init" + #~(begin + (call-with-output-file #$output + (lambda (port) + (display "#!" port) + (display #$(file-append static-bash "/bin/sh") port) + (newline port) + (display #$(file-append util-linux "/bin/mount") port) + (display " -t proc proc /proc\n" port) + (display #$(file-append guile "/bin/guile") port) + (display " --no-auto-compile " port) + (display #$real-init port) + (display "\nstatus=$?\nexit \"$status\"\n" port))) + (chmod #$output #o555)))) + + (define (import-module? module) + (and (guix-module-name? module) + (not (equal? module '(guix store deduplication))))) + + (define builder + (with-imported-modules + (source-module-closure '((gnu build linux-initrd)) + #:select? import-module?) + #~(begin + (use-modules (gnu build linux-initrd) + (guix build store-copy) + (guix build utils) + (system base compile) + (system foreign) + (rnrs bytevectors)) + + (define (cache-compiled-file-name file) + (format #f ".cache/guile/ccache/~a-~a-~a-~a/~a" + (effective-version) + (if (eq? (native-endianness) (endianness little)) + "LE" + "BE") + (sizeof '*) + (effective-version) + file)) + + (define (compile-to-cache file) + (let ((compiled-file (cache-compiled-file-name file))) + (mkdir-p (dirname compiled-file)) + (compile-file file + #:opts %auto-compilation-options + #:output-file compiled-file))) + + (mkdir #$output) + (mkdir "contents") + (populate-store '("closure") "contents" + #:deduplicate? #f) + + (with-directory-excursion "contents" + (symlink #$init-wrapper "init") + (symlink #$real-init "real-init") + (compile-to-cache "real-init") + + ;; Allow Guile to find out where it is. + (mkdir-p "proc/self") + (symlink (string-append #$guile "/bin/guile") "proc/self/exe") + (readlink "proc/self/exe") + + (write-cpio-archive (string-append #$output "/initrd.cpio.gz") + "." + #:gzip (string-append #+gzip "/bin/gzip")))) + )) + + (file-append + (computed-file name builder + #:options + `(#:references-graphs (("closure" ,init-wrapper)))) + "/initrd.cpio.gz")) + +(define* (kexec-installer-initrd file-systems + #:key + (linux linux-libre) + (linux-modules '()) + (mapped-devices '()) + keyboard-layout + (helper-packages (list util-linux)) + qemu-networking? + volatile-root? + (on-error 'backtrace) + #:allow-other-keys) + "Return an initrd for kexec-style live systems whose root file system is a +fresh tmpfs. The initrd bind-mounts its own /gnu tree into the mounted root +before switching to it, so 'gnu.load' remains reachable after 'switch-root'." + (define kodir + (flat-linux-module-directory* linux linux-modules)) + + (define helper-packages* + (append helper-packages + (if keyboard-layout + (list loadkeys-static) + '()))) + + (expression->initrd-with-proc + (with-imported-modules + (source-module-closure + '((gnu build linux-boot) + (gnu build linux-modules) + (gnu build file-systems) + (gnu system file-systems) + (guix build syscalls) + (guix build utils) + (guix build bournish) + (system repl error-handling) + (system repl repl))) + #~(begin + (use-modules (system repl error-handling) + (system repl repl) + (srfi srfi-1) + (srfi srfi-13) + (ice-9 match) + (ice-9 popen) + (ice-9 rdelim) + (gnu build linux-boot) + (gnu build linux-modules) + (gnu build file-systems) + (gnu system file-systems) + ((guix build syscalls) + #:hide (file-system-type)) + ((guix build utils) #:hide (delete)) + (guix build bournish)) + + (with-output-to-port (%make-void-port "w") + (lambda () + (set-path-environment-variable "PATH" '("bin" "sbin") + '#$helper-packages*))) + + (define mount-root-file-system* + (@@ (gnu build linux-boot) mount-root-file-system)) + + (define move-essential-file-systems* + (@@ (gnu build linux-boot) move-essential-file-systems)) + + (define (device-string->file-system-device device-string) + (cond ((string-prefix? "/" device-string) device-string) + ((string-contains device-string ":/") device-string) + ((uuid device-string) => identity) + (else (file-system-label device-string)))) + + (define (root-mount-point? fs) + (string=? (file-system-mount-point fs) "/")) + + (define (populate-root-from-initrd-paths paths) + (for-each + (lambda (path) + (when (file-exists? path) + (let ((target (string-append "/root" path))) + (if (directory-exists? path) + (begin + (mkdir-p target) + ;; Make PATH its own mount point first so we can move it + ;; under /root and keep it alive across 'switch-root'. + (mount path path "" MS_BIND) + (mount path target "" MS_MOVE)) + (begin + (mkdir-p (dirname target)) + (copy-file path target))) + (format #t "staged '~a' at '~a'~%" path target)))) + paths)) + + (define (dump-file path) + (when (file-exists? path) + (format #t "--- ~a ---~%" path) + (call-with-input-file path + (lambda (port) + (let loop () + (let ((line (read-line port 'concat))) + (unless (eof-object? line) + (display line) + (newline) + (loop)))))) + (format #t "--- end ~a ---~%" path))) + + (define (log-path-state label path) + (format #t "~a: ~a exists? ~a dir? ~a~%" + label path + (file-exists? path) + (directory-exists? path))) + + (define (move-initrd-directory-under-root path) + (let ((target (string-append "/root" path))) + (mkdir-p target) + ;; Make PATH its own mount point so nested mounts move with it. + (mount path path "" MS_BIND) + (mount path target "" MS_MOVE) + (format #t "moved initrd mount '~a' to '~a'~%" path target))) + + (define (attach-loop-device image) + (let* ((pipe (open-pipe* OPEN_READ "losetup" "--find" "--show" + "--read-only" image)) + (device (string-trim-right (read-line pipe)))) + (close-pipe pipe) + (unless (and (string? device) + (string-prefix? "/dev/loop" device)) + (error "failed to attach loop device" image device)) + (format #t "attached loop device '~a' for '~a'~%" device image) + device)) + + (define (enter-root root) + ;; For the kexec installer we only need a new logical root, not a + ;; full initrd teardown. Avoiding 'switch-root' sidesteps the + ;; disappearing-/gnu problem while still giving the boot program a + ;; coherent "/" view. + (display "before enter-root\n") + (dump-file "/proc/self/mountinfo") + (move-essential-file-systems* root) + (chdir root) + (chroot ".") + (chdir "/") + (display "after enter-root\n") + (dump-file "/proc/self/mountinfo")) + + (define* (boot-system-with-initrd-binds #:key + (linux-modules '()) + linux-module-directory + keymap-file + qemu-guest-networking? + volatile-root? + (mounts '()) + (squashfs-store-image + "/gnu-store.squashfs") + (initrd-bind-mounts + '("/etc/guix-kexec")) + (on-error 'debug)) + (display "Welcome, this is GNU's early boot Guile.\n") + (display "Use 'gnu.repl' for an initrd REPL.\n\n") + + (call-with-error-handling + (lambda () + (mount-essential-file-systems) + (let* ((args (linux-command-line)) + (to-load (find-long-option "gnu.load" args)) + (root-device (and=> (find-long-option "root" args) + device-string->file-system-device)) + (rootfstype (find-long-option "rootfstype" args)) + (rootflags (find-long-option "rootflags" args)) + (root-fs* (find root-mount-point? mounts)) + (root-fs + (if root-fs* + (file-system + (inherit root-fs*) + (device (or root-device + (file-system-device root-fs*))) + (type (or rootfstype + (file-system-type root-fs*))) + (options (or rootflags + (file-system-options root-fs*)))) + (file-system + (device root-device) + (mount-point "/") + (type rootfstype) + (options rootflags))))) + + (unless (or root-fs* (and root-device rootfstype)) + (error "no root file system or 'root' and 'rootfstype' parameters")) + + (when (member "gnu.repl" args) + (start-repl)) + + (display "loading kernel modules...\n") + (load-linux-modules-from-directory linux-modules + linux-module-directory) + + (when keymap-file + (let ((status (system* "loadkeys" keymap-file))) + (unless (zero? status) + (format (current-error-port) + "warning: 'loadkeys' exited with status ~a~%" + status)))) + + (when qemu-guest-networking? + (unless (configure-qemu-networking) + (display "network interface is DOWN\n"))) + + (unless (file-exists? "/root") + (mkdir "/root")) + + (setenv "EXT2FS_NO_MTAB_OK" "1") + + (mount-root-file-system* (canonicalize-device-spec + (file-system-device root-fs)) + (file-system-type root-fs) + #:volatile-root? volatile-root? + #:flags (mount-flags->bit-mask + (file-system-flags root-fs)) + #:options (file-system-options root-fs) + #:check? #f + #:skip-check-if-clean? #f + #:repair #f) + + (for-each (lambda (fs) + (mount-file-system fs + #:check? #f + #:skip-check-if-clean? #f + #:repair #f)) + (remove root-mount-point? mounts)) + + (setenv "EXT2FS_NO_MTAB_OK" #f) + + ;; Mount the squashfs store image (embedded in initrd at + ;; /gnu-store.squashfs) directly under /root so the mounts + ;; remain visible after we chroot into the target tmpfs root. + ;; Items inside are at the squashfs root, stripped of the + ;; /gnu/store/ prefix. + (when (and squashfs-store-image + (file-exists? squashfs-store-image)) + (display "mounting squashfs store image...\n") + (let ((loop-device (attach-loop-device + squashfs-store-image))) + (mkdir-p "/root/gnu/.ro-store") + (mount loop-device "/root/gnu/.ro-store" "squashfs" + MS_RDONLY "") + (mkdir-p "/root/gnu/store") + (mkdir-p "/root/gnu/.rw-store/store") + (mkdir-p "/root/gnu/.rw-store/work") + (mount "overlay" "/root/gnu/store" "overlay" 0 + (string-append + "lowerdir=/root/gnu/.ro-store" + ",upperdir=/root/gnu/.rw-store/store" + ",workdir=/root/gnu/.rw-store/work")) + (log-path-state "pre-root" "/root/gnu") + (log-path-state "pre-root" "/root/gnu/store"))) + + (populate-root-from-initrd-paths initrd-bind-mounts) + + (if to-load + (begin + (enter-root "/root") + (format #t "post-root: /gnu exists? ~a, /gnu/store exists? ~a, boot exists? ~a~%" + (file-exists? "/gnu") + (file-exists? "/gnu/store") + (file-exists? to-load)) + (format #t "loading '~a'...\n" to-load) + (primitive-load to-load) + (format (current-error-port) + "boot program '~a' terminated, rebooting~%" + to-load) + (sleep 2) + (reboot)) + (begin + (display "no boot file passed via 'gnu.load'\n") + (display "entering a warm and cozy REPL\n") + (start-repl))))) + #:on-error on-error)) + + (boot-system-with-initrd-binds + #:mounts + (map spec->file-system + '#$(map file-system->spec file-systems)) + #:linux-modules '#$linux-modules + #:linux-module-directory '#$kodir + #:keymap-file #+(and=> keyboard-layout + keyboard-layout->console-keymap) + #:qemu-guest-networking? #$qemu-networking? + #:volatile-root? '#$volatile-root? + #:on-error '#$on-error))) + #:name "kexec-installer-initrd")) diff --git a/nbde/system/kexec-installer.scm b/nbde/system/kexec-installer.scm new file mode 100644 index 0000000..9b87934 --- /dev/null +++ b/nbde/system/kexec-installer.scm @@ -0,0 +1,152 @@ +(define-module (nbde system kexec-installer) + #:use-module (gnu) + #:use-module (gnu packages) + #:use-module (gnu packages base) + #:use-module (gnu packages compression) + #:use-module (gnu packages cryptsetup) + #:use-module (gnu packages disk) + #:use-module (gnu packages file-systems) + #:use-module (gnu packages linux) + #:use-module (gnu packages package-management) + #:use-module (gnu packages ssh) + #:use-module (gnu services networking) + #:use-module (gnu services ssh) + #:use-module (guix gexp) + #:use-module (nbde system kexec-initrd) + #:use-module (nbde packages crypto) + #:export (make-kexec-installer-os + kexec-installer-os)) + +(define %kexec-installer-shell-packages + (map specification->package + '("bash-minimal" + "coreutils" + "diffutils" + "findutils" + "gawk" + "grep" + "gzip" + "inetutils" + "iproute2" + "less" + "nss-certs" + "procps" + "rsync" + "sed" + "tar" + "which" + "xz"))) + +(define %kexec-installer-packages + ;; Keep the live image intentionally thin. This environment only needs + ;; enough tooling to repartition disks, format ext4/FAT, configure LUKS, and + ;; run the remote Guix installer flow after the kexec handoff. + (append + %kexec-installer-shell-packages + (list guix + clevis + cryptsetup + dosfstools + e2fsprogs + gptfdisk + kexec-tools + kmod + parted + util-linux))) + +(define %kexec-installer-initrd-modules + '("ahci" + "dm-crypt" + "fat" + "loop" + "nls_cp437" + "nls_iso8859-1" + "nvme" + "overlay" + "sd_mod" + "squashfs" + "vfat" + "virtio_blk" + "virtio_console" + "virtio_net" + "virtio_pci" + "virtio_scsi")) + +(define* (make-kexec-installer-os + #:key + (host-name "guix-kexec") + (timezone "Etc/UTC") + (locale "en_US.UTF-8") + (kernel-arguments + '("console=ttyS0,115200n8" + "net.ifnames=0" + "panic=30" + "loglevel=4")) + (extra-packages '()) + (extra-services '())) + (operating-system + (host-name host-name) + (timezone timezone) + (locale locale) + (keyboard-layout (keyboard-layout "us")) + (label "Guix kexec installer") + (initrd-modules %kexec-installer-initrd-modules) + (initrd kexec-installer-initrd) + (kernel-arguments kernel-arguments) + (bootloader + (bootloader-configuration + (bootloader grub-bootloader) + (targets '()))) + (file-systems + (cons (file-system + (device "tmpfs") + (mount-point "/") + (type "tmpfs") + (check? #f)) + %base-file-systems)) + (packages + (append extra-packages + %kexec-installer-packages)) + (services + (append + (list (service dhcpcd-service-type) + (simple-service + 'kexec-launch-authorized-keys + activation-service-type + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + (let ((source "/etc/guix-kexec/authorized_keys/root") + (target-dir "/root/.ssh") + (target "/root/.ssh/authorized_keys")) + (when (file-exists? source) + (mkdir-p target-dir) + (copy-file source target) + (chmod target-dir #o700) + (chmod target #o600)))))) + (service mingetty-service-type + (mingetty-configuration + (tty "ttyS0") + (auto-login "root") + (login-pause? #f))) + (service mingetty-service-type + (mingetty-configuration + (tty "tty1") + (auto-login "root") + (login-pause? #f))) + (service openssh-service-type + (openssh-configuration + (openssh openssh-sans-x) + (port-number 22) + (permit-root-login 'prohibit-password) + (extra-content + "AuthorizedKeysFile .ssh/authorized_keys .ssh/authorized_keys2 /etc/ssh/authorized_keys.d/%u /etc/guix-kexec/authorized_keys/%u") + (password-authentication? #f)))) + extra-services + (modify-services %base-services + (delete console-font-service-type) + (delete agetty-service-type) + (delete mingetty-service-type)))))) + +(define kexec-installer-os + (make-kexec-installer-os)) diff --git a/nbde/system/mapped-devices.scm b/nbde/system/mapped-devices.scm index f1771a3..0d65b2b 100644 --- a/nbde/system/mapped-devices.scm +++ b/nbde/system/mapped-devices.scm @@ -28,16 +28,26 @@ keeps a manual recovery slot available." source)) (keyfile #$key-file)) (mkdir-p "/run/cryptsetup/") + (let* ((partition (if (bytevector? source) - (or (let loop ((tries-left 10)) + (or (let loop ((tries-left 60)) (and (positive? tries-left) (or (find-partition-by-luks-uuid source) (begin + (format #t "nbde: waiting for LUKS partition (~a tries left)~%" + tries-left) + (force-output) (sleep 1) (loop (- tries-left 1)))))) - (error "LUKS partition not found" source)) - source)) + (error "LUKS partition not found" source)) + (or (let loop ((tries-left 60)) + (and (positive? tries-left) + (or (and (file-exists? source) source) + (begin + (sleep 1) + (loop (- tries-left 1)))))) + (error "LUKS partition not found" source)))) (shell-bin #$(file-append bash-minimal "/bin/sh")) (clevis-bin #$(file-append clevis-package "/bin/clevis")) (cryptsetup-bin #$(file-append cryptsetup-static