You've already forked guix-tribes
Update NBDE channel for kexec installs
This commit is contained in:
@@ -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
|
||||
|
||||
@@ -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>
|
||||
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{<nbde-network-configuration>} 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"))
|
||||
|
||||
387
nbde/system/kexec-initrd.scm
Normal file
387
nbde/system/kexec-initrd.scm
Normal file
@@ -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"))
|
||||
152
nbde/system/kexec-installer.scm
Normal file
152
nbde/system/kexec-installer.scm
Normal file
@@ -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))
|
||||
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user