linux-initrd.scm (11867B)
1 ;;; SPDX-License-Identifier: GPL-3.0-or-later 2 ;; AI disclosure: LLM slop, but it works. This was made before I got more familiar with Guile Scheme and took many retries to get working. 3 ;; TODO: rewrite this later by deleting this and rewriting by reading the main initrd and my previous pre-guix initrd script. could maybe be deduplicated a lot via inherits. 4 (define-module (epistemia systems linux-initrd) 5 #:use-module (guix gexp) 6 #:use-module (guix utils) 7 #:use-module ((guix store) #:select (%store-prefix)) 8 #:use-module ((guix derivations) #:select (derivation->output-path)) 9 #:use-module (guix modules) 10 #:use-module (gnu packages compression) 11 #:use-module (gnu packages disk) 12 #:use-module (gnu packages guile) 13 #:use-module (gnu packages linux) 14 #:use-module (gnu packages file-systems) 15 #:use-module (gnu system file-systems) 16 #:use-module (gnu system mapped-devices) 17 #:use-module (gnu system keyboard) 18 #:use-module (gnu system linux-initrd) 19 #:use-module (ice-9 match) 20 #:use-module (ice-9 regex) 21 #:use-module (ice-9 vlist) 22 #:use-module (srfi srfi-1) 23 #:use-module (srfi srfi-26) 24 #:export (epistemia-zfs-initrd)) 25 26 (define (flat-linux-module-directory* linux extra-packages modules) 27 "Return a flat directory containing the Linux kernel modules listed in 28 MODULES." 29 (define imported-modules 30 (source-module-closure '((gnu build linux-modules) 31 (guix build utils)))) 32 33 (define build-exp 34 (with-imported-modules imported-modules 35 (with-extensions (list guile-zlib guile-zstd) 36 #~(begin 37 (use-modules (gnu build linux-modules) 38 (guix build utils) 39 (rnrs io ports) 40 (srfi srfi-1) 41 (srfi srfi-26) 42 (ice-9 match)) 43 44 (define module-dirs 45 (map (lambda (pkg) (string-append pkg "/lib/modules")) 46 (cons #$linux '#$extra-packages))) 47 48 (define builtin-modules 49 (match (find-files (string-append #$linux "/lib/modules") 50 (lambda (file stat) 51 (string=? (basename file) "modules.builtin"))) 52 ((file . _) 53 (call-with-input-file file 54 (lambda (port) 55 (map file-name->module-name 56 (string-tokenize (get-string-all port)))))) 57 (_ '()))) 58 59 (define modules-to-lookup 60 (lset-difference string=? '#$modules builtin-modules)) 61 62 (define (lookup-in-dirs name) 63 (let loop ((dirs module-dirs)) 64 (match dirs 65 ((dir . rest) 66 (let ((candidates 67 (find-files dir 68 (lambda (file stat) 69 (let ((base (basename file))) 70 (or (string=? base (string-append name ".ko")) 71 (string=? base (string-append name ".ko.gz")) 72 (string=? base (string-append name ".ko.zst")))))))) 73 (match candidates 74 ((first . _) first) 75 (() (loop rest))))) 76 (() #f)))) 77 78 (define modules 79 (let ((found-modules (map lookup-in-dirs modules-to-lookup))) 80 (append (filter identity found-modules) 81 (recursive-module-dependencies 82 (filter identity found-modules) 83 #:lookup-module lookup-in-dirs)))) 84 85 (define (maybe-uncompress file) 86 (cond 87 ((string-contains file ".ko.gz") 88 (invoke #+(file-append gzip "/bin/gunzip") file)) 89 ((string-contains file ".ko.zst") 90 (invoke #+(file-append zstd "/bin/zstd") "-d" file)))) 91 92 (mkdir #$output) 93 (for-each (lambda (module) 94 (when module 95 (let ((out-module 96 (string-append #$output "/" 97 (basename module)))) 98 (format #t "copying '~a'...~%" module) 99 (copy-file module out-module) 100 (maybe-uncompress out-module)))) 101 (delete-duplicates modules)) 102 103 (write-module-name-database #$output))))) 104 105 (computed-file "linux-modules-combined" build-exp)) 106 107 (define* (zfs-raw-initrd file-systems 108 #:key 109 (linux linux-libre) 110 (zfs-package zfs) 111 (linux-modules '()) 112 (pre-mount #t) 113 (mapped-devices '()) 114 (keyboard-layout #f) 115 (helper-packages '()) 116 qemu-networking? 117 volatile-root? 118 (on-error 'debug) 119 (monkey-patch? #t) 120 #:allow-other-keys) 121 122 (define device-mapping-commands 123 (map (lambda (md) 124 (let* ((source (mapped-device-source md)) 125 (targets (mapped-device-targets md)) 126 (type (mapped-device-type md)) 127 (open (mapped-device-kind-open type))) 128 (apply open source targets 129 (mapped-device-arguments md)))) 130 mapped-devices)) 131 132 (define file-system-scan-commands 133 (let ((file-system-types (map file-system-type file-systems))) 134 (if (member "btrfs" file-system-types) 135 #~((system* (string-append #$btrfs-progs/static "/bin/btrfs") 136 "device" "scan")) 137 #~()))) 138 139 (define zfs-import-commands 140 #~(begin 141 (format #t "Epistemia: Importing ZFS pools...~%") 142 (false-if-exception 143 (system* (string-append #$zfs-package "/sbin/zpool") 144 "import" "-a" "-N" "-f" "-d" "/dev")) 145 (format #t "Epistemia: Imported ZFS pools:~%") 146 (false-if-exception 147 (system* (string-append #$zfs-package "/sbin/zpool") 148 "status")) 149 (sleep 2) 150 #t)) 151 152 (define kodir 153 (flat-linux-module-directory* linux 154 (list (gexp-input zfs-package "module")) 155 linux-modules)) 156 157 (expression->initrd 158 (with-imported-modules (source-module-closure 159 '((gnu build linux-boot) 160 (guix build utils) 161 (guix build bournish) 162 (gnu system file-systems) 163 (gnu build file-systems))) 164 #~(begin 165 (use-modules (gnu build linux-boot) 166 (gnu system file-systems) 167 ((guix build utils) #:hide (delete)) 168 (guix build bournish) 169 (srfi srfi-1) 170 (srfi srfi-13) 171 (srfi srfi-26)) 172 173 ;; We must patch BOTH modules because linux-boot likely already 174 ;; imported the function. 175 #$(if monkey-patch? 176 #~(let* ((fs-mod (resolve-module '(gnu build file-systems))) 177 (boot-mod (resolve-module '(gnu build linux-boot))) 178 (orig-canon (module-ref fs-mod 'canonicalize-device-spec)) 179 (new-canon 180 (lambda (spec) 181 ;; ZFS datasets in Guix config are either strings or file-system-labels. 182 ;; If it's a label record, the first field is the label string. 183 (let ((device (cond 184 ((string? spec) spec) 185 ((and (struct? spec) 186 (string? (struct-ref spec 0))) 187 (struct-ref spec 0)) 188 (else #f)))) 189 (if (and device 190 (or (string-contains device "zroot/") 191 (string-contains device "zfs"))) 192 (begin 193 (format #t "Epistemia: ZFS bypass for ~s~%" device) 194 device) 195 (orig-canon spec)))))) 196 197 ;; 1. Overwrite the definition source 198 (module-set! fs-mod 'canonicalize-device-spec new-canon) 199 200 ;; 2. Overwrite the consumer's binding (Crucial for boot-system) 201 (module-set! boot-mod 'canonicalize-device-spec new-canon) 202 203 (format #t "Epistemia: ZFS Monkey Patch Applied.~%")) 204 #~#t) 205 206 (with-output-to-port (%make-void-port "w") 207 (lambda () 208 (set-path-environment-variable "PATH" '("bin" "sbin") 209 '#$helper-packages))) 210 211 (parameterize ((current-warning-port (%make-void-port "w"))) 212 (boot-system #:mounts 213 (map spec->file-system 214 '#$(map file-system->spec file-systems)) 215 #:pre-mount (lambda () 216 (and #$pre-mount 217 #$@device-mapping-commands 218 #$@file-system-scan-commands 219 #$zfs-import-commands)) 220 #:linux-modules '#$linux-modules 221 #:linux-module-directory '#$kodir 222 #:keymap-file #+(and=> keyboard-layout 223 keyboard-layout->console-keymap) 224 #:qemu-guest-networking? #$qemu-networking? 225 #:volatile-root? '#$volatile-root? 226 #:on-error '#$on-error)))) 227 #:name "zfs-initrd")) 228 229 (define* (epistemia-zfs-initrd file-systems 230 #:key 231 (linux linux-libre) 232 (zfs-package zfs) 233 (linux-modules '()) 234 (mapped-devices '()) 235 (keyboard-layout #f) 236 qemu-networking? 237 volatile-root? 238 (extra-modules '()) 239 (on-error 'debug) 240 (monkey-patch? #t) 241 #:allow-other-keys) 242 243 (define linux-modules* 244 (cons "zfs" 245 `(,@linux-modules 246 ,@(file-system-modules file-systems) 247 ,@(if volatile-root? '("overlay") '()) 248 ,@extra-modules))) 249 250 (define helper-packages 251 (cons zfs-package 252 (append (file-system-packages file-systems 253 #:volatile-root? volatile-root?) 254 (if keyboard-layout 255 (list loadkeys-static) 256 '())))) 257 258 (zfs-raw-initrd file-systems 259 #:linux linux 260 #:zfs-package zfs-package 261 #:linux-modules linux-modules* 262 #:mapped-devices mapped-devices 263 #:helper-packages helper-packages 264 #:keyboard-layout keyboard-layout 265 #:qemu-networking? qemu-networking? 266 #:volatile-root? volatile-root? 267 #:on-error on-error 268 #:monkey-patch? monkey-patch?))