commit dc5fae5eb743f51395d92d9c3235009f45225597 parent 6dc14eccb88e4bcb9b083974a38d5fc1d1b5f9d4 Author: Vineet Kumar <git@vineetk.net> Date: Tue, 19 May 2026 12:37:20 -0400 systems: import from guixsd-config Diffstat:
| A | epistemia/systems/base-system.scm | | | 33 | +++++++++++++++++++++++++++++++++ |
| A | epistemia/systems/linux-initrd.scm | | | 268 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
2 files changed, 301 insertions(+), 0 deletions(-)
diff --git a/epistemia/systems/base-system.scm b/epistemia/systems/base-system.scm @@ -0,0 +1,33 @@ +(define-module (epistemia systems base-system) + #:use-module (gnu) + #:use-module (gnu packages bash) + #:use-module (gnu packages ssh) + #:use-module (guix) + #:export (base-system)) + +(define base-system + (operating-system + (host-name "base") + (timezone "Canada/Eastern") + (locale "en_US.utf8") + + ;; should be set per-system + (kernel '()) + (firmware '()) + + ;; will be overrided per-system + (bootloader (bootloader-configuration + (bootloader grub-efi-bootloader) + (targets '("/boot/efi")))) + + (file-systems %base-file-systems) + + (packages %base-packages) + + (services (modify-services %base-services + (guix-service-type config => + (guix-configuration + (inherit config) + (authorized-keys + (append (list (local-file "../../demiurge.pub")) + %default-authorized-guix-keys)))))))) diff --git a/epistemia/systems/linux-initrd.scm b/epistemia/systems/linux-initrd.scm @@ -0,0 +1,268 @@ +;;; SPDX-License-Identifier: GPL-3.0-or-later +;; 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. +;; 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. +(define-module (epistemia systems linux-initrd) + #:use-module (guix gexp) + #:use-module (guix utils) + #:use-module ((guix store) #:select (%store-prefix)) + #:use-module ((guix derivations) #:select (derivation->output-path)) + #:use-module (guix modules) + #:use-module (gnu packages compression) + #:use-module (gnu packages disk) + #:use-module (gnu packages guile) + #:use-module (gnu packages linux) + #:use-module (gnu packages file-systems) + #:use-module (gnu system file-systems) + #:use-module (gnu system mapped-devices) + #:use-module (gnu system keyboard) + #:use-module (gnu system linux-initrd) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (ice-9 vlist) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (epistemia-zfs-initrd)) + +(define (flat-linux-module-directory* linux extra-packages modules) + "Return a flat directory containing the Linux kernel modules listed in +MODULES." + (define imported-modules + (source-module-closure '((gnu build linux-modules) + (guix build utils)))) + + (define build-exp + (with-imported-modules imported-modules + (with-extensions (list guile-zlib guile-zstd) + #~(begin + (use-modules (gnu build linux-modules) + (guix build utils) + (rnrs io ports) + (srfi srfi-1) + (srfi srfi-26) + (ice-9 match)) + + (define module-dirs + (map (lambda (pkg) (string-append pkg "/lib/modules")) + (cons #$linux '#$extra-packages))) + + (define builtin-modules + (match (find-files (string-append #$linux "/lib/modules") + (lambda (file stat) + (string=? (basename file) "modules.builtin"))) + ((file . _) + (call-with-input-file file + (lambda (port) + (map file-name->module-name + (string-tokenize (get-string-all port)))))) + (_ '()))) + + (define modules-to-lookup + (lset-difference string=? '#$modules builtin-modules)) + + (define (lookup-in-dirs name) + (let loop ((dirs module-dirs)) + (match dirs + ((dir . rest) + (let ((candidates + (find-files dir + (lambda (file stat) + (let ((base (basename file))) + (or (string=? base (string-append name ".ko")) + (string=? base (string-append name ".ko.gz")) + (string=? base (string-append name ".ko.zst")))))))) + (match candidates + ((first . _) first) + (() (loop rest))))) + (() #f)))) + + (define modules + (let ((found-modules (map lookup-in-dirs modules-to-lookup))) + (append (filter identity found-modules) + (recursive-module-dependencies + (filter identity found-modules) + #:lookup-module lookup-in-dirs)))) + + (define (maybe-uncompress file) + (cond + ((string-contains file ".ko.gz") + (invoke #+(file-append gzip "/bin/gunzip") file)) + ((string-contains file ".ko.zst") + (invoke #+(file-append zstd "/bin/zstd") "-d" file)))) + + (mkdir #$output) + (for-each (lambda (module) + (when module + (let ((out-module + (string-append #$output "/" + (basename module)))) + (format #t "copying '~a'...~%" module) + (copy-file module out-module) + (maybe-uncompress out-module)))) + (delete-duplicates modules)) + + (write-module-name-database #$output))))) + + (computed-file "linux-modules-combined" build-exp)) + +(define* (zfs-raw-initrd file-systems + #:key + (linux linux-libre) + (zfs-package zfs) + (linux-modules '()) + (pre-mount #t) + (mapped-devices '()) + (keyboard-layout #f) + (helper-packages '()) + qemu-networking? + volatile-root? + (on-error 'debug) + (monkey-patch? #t) + #:allow-other-keys) + + (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 zfs-import-commands + #~(begin + (format #t "Epistemia: Importing ZFS pools...~%") + (false-if-exception + (system* (string-append #$zfs-package "/sbin/zpool") + "import" "-a" "-N" "-f" "-d" "/dev")) + (format #t "Epistemia: Imported ZFS pools:~%") + (false-if-exception + (system* (string-append #$zfs-package "/sbin/zpool") + "status")) + (sleep 2) + #t)) + + (define kodir + (flat-linux-module-directory* linux + (list (gexp-input zfs-package "module")) + linux-modules)) + + (expression->initrd + (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-13) + (srfi srfi-26)) + + ;; We must patch BOTH modules because linux-boot likely already + ;; imported the function. + #$(if monkey-patch? + #~(let* ((fs-mod (resolve-module '(gnu build file-systems))) + (boot-mod (resolve-module '(gnu build linux-boot))) + (orig-canon (module-ref fs-mod 'canonicalize-device-spec)) + (new-canon + (lambda (spec) + ;; ZFS datasets in Guix config are either strings or file-system-labels. + ;; If it's a label record, the first field is the label string. + (let ((device (cond + ((string? spec) spec) + ((and (struct? spec) + (string? (struct-ref spec 0))) + (struct-ref spec 0)) + (else #f)))) + (if (and device + (or (string-contains device "zroot/") + (string-contains device "zfs"))) + (begin + (format #t "Epistemia: ZFS bypass for ~s~%" device) + device) + (orig-canon spec)))))) + + ;; 1. Overwrite the definition source + (module-set! fs-mod 'canonicalize-device-spec new-canon) + + ;; 2. Overwrite the consumer's binding (Crucial for boot-system) + (module-set! boot-mod 'canonicalize-device-spec new-canon) + + (format #t "Epistemia: ZFS Monkey Patch Applied.~%")) + #~#t) + + (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 #$pre-mount + #$@device-mapping-commands + #$@file-system-scan-commands + #$zfs-import-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 "zfs-initrd")) + +(define* (epistemia-zfs-initrd file-systems + #:key + (linux linux-libre) + (zfs-package zfs) + (linux-modules '()) + (mapped-devices '()) + (keyboard-layout #f) + qemu-networking? + volatile-root? + (extra-modules '()) + (on-error 'debug) + (monkey-patch? #t) + #:allow-other-keys) + + (define linux-modules* + (cons "zfs" + `(,@linux-modules + ,@(file-system-modules file-systems) + ,@(if volatile-root? '("overlay") '()) + ,@extra-modules))) + + (define helper-packages + (cons zfs-package + (append (file-system-packages file-systems + #:volatile-root? volatile-root?) + (if keyboard-layout + (list loadkeys-static) + '())))) + + (zfs-raw-initrd file-systems + #:linux linux + #:zfs-package zfs-package + #:linux-modules linux-modules* + #:mapped-devices mapped-devices + #:helper-packages helper-packages + #:keyboard-layout keyboard-layout + #:qemu-networking? qemu-networking? + #:volatile-root? volatile-root? + #:on-error on-error + #:monkey-patch? monkey-patch?))