From c84ef6b747d79d38e196dafd1b27eeb37ddac336 Mon Sep 17 00:00:00 2001 From: Polyedre Date: Sat, 20 Jun 2026 10:58:11 +0200 Subject: [PATCH 01/15] ci: provision from manifest.scm via Guix; document deps The apt-based CI couldn't satisfy the build: (hexol k8s)/cmdb need (json) from guile-json and (hexol ansible) needs (yaml) from guile-libyaml, which isn't packaged for Ubuntu. hexol is a Guix project anyway, so CI now installs Guix and runs the suite inside `guix shell -m manifest.scm`, making the manifest the single source of truth. - manifest.scm: add guile-json + guile-libyaml (the real deps). - ci.yml: install Guix, run make build/test/test-examples in the guix shell. - README: document the Guile-library dependencies and the `guix shell -m manifest.scm` install path. Verified locally: `guix shell -m manifest.scm -- make build test test-examples` is fully green. --- .github/workflows/ci.yml | 35 ++++++++++++++++++++--------------- README.md | 20 +++++++++++++++++--- manifest.scm | 11 +++++++++-- 3 files changed, 46 insertions(+), 20 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 7eeb2c6..1647415 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -8,24 +8,29 @@ on: jobs: test: runs-on: ubuntu-latest - env: - # Ubuntu ships the Guile 3 binary as `guile-3.0`; the Makefile takes - # GUILE ?= guile, so we point it at that. (manifest.scm lists guile + jq.) - GUILE: guile-3.0 + timeout-minutes: 30 steps: - uses: actions/checkout@v4 - - name: Install Guile 3, guile-json and jq + # hexol is a Guix project: manifest.scm is the source of truth for + # dependencies (guile + guile-json + guile-libyaml + jq). We provision + # the same environment in CI rather than re-deriving it from apt — among + # other things, the (yaml) module comes from guile-libyaml, which isn't + # packaged for Ubuntu. + - name: Install Guix run: | - sudo apt-get update - sudo apt-get install -y --no-install-recommends guile-3.0 guile-json jq - ${GUILE} --version | head -1 + wget -qO /tmp/guix-install.sh \ + https://git.savannah.gnu.org/cgit/guix.git/plain/etc/guix-install.sh + yes | sudo bash /tmp/guix-install.sh + # Make `guix` available to later steps. + echo "/var/guix/profiles/per-user/root/current-guix/bin" >> "$GITHUB_PATH" - - name: Build (compile every module — surfaces load/compile errors) - run: make build + - name: Show Guix version + run: guix --version - - name: Test (kernel, surface, construct, k8s, cmdb) - run: make test - - - name: Test examples (render each standalone example, check it exits 0) - run: make test-examples + # Single step so the substitutes are fetched once. `guix shell -m + # manifest.scm --` runs the command with exactly the manifest's packages + # on PATH and GUILE_LOAD_PATH; `make` then uses the Guix `guile`. + - name: Build, test, and smoke-test examples + run: | + guix shell -m manifest.scm -- make build test test-examples diff --git a/README.md b/README.md index 0f881fd..4d7749f 100644 --- a/README.md +++ b/README.md @@ -56,12 +56,26 @@ A few things this buys you over plain manifests: ## Install -Hexol runs on [Guile](https://www.gnu.org/software/guile/) 3.x — install that, -clone the repo, and run `./bin/hexol` (it auto-compiles on first use): +Hexol runs on [Guile](https://www.gnu.org/software/guile/) 3.x and needs two +Guile libraries: **guile-json** (the `(json)` module) and **guile-libyaml** +(the `(yaml)` module). It also uses `jq`. All of these are declared in +[`manifest.scm`](manifest.scm), which is the source of truth for dependencies. + +The easy path is [Guix](https://guix.gnu.org/), which reads that manifest +directly — no manual install: ```sh git clone https://github.com/Polyedre/hexol && cd hexol -./bin/hexol render -i examples/kubernetes.scm +guix shell -m manifest.scm -- ./bin/hexol render -i examples/kubernetes.scm +``` + +(The repo's `.envrc` does this automatically under [direnv](https://direnv.net/).) + +Without Guix, install Guile 3.x plus guile-json, guile-libyaml, and jq however +your distro provides them, then: + +```sh +./bin/hexol render -i examples/kubernetes.scm # auto-compiles on first use ``` The CLI itself shells out to nothing. Individual features do, and only when you diff --git a/manifest.scm b/manifest.scm index 2b8f956..1088328 100644 --- a/manifest.scm +++ b/manifest.scm @@ -1,2 +1,9 @@ -;; guile-json provides the (json) module that (hexol k8s) and the cmdb import. -(specifications->manifest (list "guile" "guile-json" "jq")) +;; Dependencies for building, testing, and running hexol. +;; guile — the interpreter (3.x) +;; guile-json — the (json) module, imported by (hexol k8s), terraform, +;; secrets, and the cmdb +;; guile-libyaml — the (yaml) module, imported by (hexol ansible) +;; jq — used by the secrets tooling +;; This manifest is the source of truth for dependencies: `guix shell -m +;; manifest.scm` reproduces the dev environment, and CI provisions from it. +(specifications->manifest (list "guile" "guile-json" "guile-libyaml" "jq")) From d1bec61440232521b3384929fcf88c31359d8dca Mon Sep 17 00:00:00 2001 From: Polyedre Date: Sat, 20 Jun 2026 11:17:05 +0200 Subject: [PATCH 02/15] ci: install Guix from binary tarball (interactive installer hangs in CI) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit guix-install.sh blocks on a yes/no prompt that piped input can't satisfy. Switch to the manual binary-tarball install from the Guix manual: extract, create build users, start the daemon, authorize the official substitute key, then run the suite in guix shell — all one step so the backgrounded daemon survives. --- .github/workflows/ci.yml | 52 +++++++++++++++++++++++++++------------- 1 file changed, 36 insertions(+), 16 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 1647415..072e2c4 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -17,20 +17,40 @@ jobs: # the same environment in CI rather than re-deriving it from apt — among # other things, the (yaml) module comes from guile-libyaml, which isn't # packaged for Ubuntu. - - name: Install Guix + # + # We install Guix from the official binary tarball (the interactive + # guix-install.sh hangs in CI), start the daemon, authorize the official + # substitute key so dependencies download instead of building, then run + # the suite inside `guix shell -m manifest.scm`. It's one step so the + # backgrounded daemon stays alive for the build. + - name: Provision Guix and run the suite run: | - wget -qO /tmp/guix-install.sh \ - https://git.savannah.gnu.org/cgit/guix.git/plain/etc/guix-install.sh - yes | sudo bash /tmp/guix-install.sh - # Make `guix` available to later steps. - echo "/var/guix/profiles/per-user/root/current-guix/bin" >> "$GITHUB_PATH" - - - name: Show Guix version - run: guix --version - - # Single step so the substitutes are fetched once. `guix shell -m - # manifest.scm --` runs the command with exactly the manifest's packages - # on PATH and GUILE_LOAD_PATH; `make` then uses the Guix `guile`. - - name: Build, test, and smoke-test examples - run: | - guix shell -m manifest.scm -- make build test test-examples + set -eux + GUIX_VERSION=1.4.0 + GUIX_PROFILE=/var/guix/profiles/per-user/root/current-guix + GUIX_BIN="$GUIX_PROFILE/bin" + + cd /tmp + wget -q "https://ftp.gnu.org/gnu/guix/guix-binary-${GUIX_VERSION}.x86_64-linux.tar.xz" + sudo tar --warning=no-timestamp -xf "guix-binary-${GUIX_VERSION}.x86_64-linux.tar.xz" -C / + + # Build users + daemon, per the Guix manual's binary-install steps. + sudo groupadd --system guixbuild || true + for i in $(seq -w 1 10); do + sudo useradd -g guixbuild -G guixbuild -d /var/empty \ + -s "$(command -v nologin)" -c "Guix build user $i" --system "guixbuilder$i" || true + done + sudo mkdir -p /root/.config/guix + sudo ln -sf "$GUIX_PROFILE" /root/.config/guix/current + + sudo "$GUIX_BIN/guix-daemon" --build-users-group=guixbuild & + sleep 5 + + # Download prebuilt binaries instead of compiling from source. + sudo "$GUIX_BIN/guix" archive --authorize \ + < "$GUIX_PROFILE/share/guix/ci.guix.gnu.org.pub" + + "$GUIX_BIN/guix" --version + # Run as root (daemon owner) to avoid socket-permission friction. + cd "$GITHUB_WORKSPACE" + sudo "$GUIX_BIN/guix" shell -m manifest.scm -- make build test test-examples From f2e0ab1bbfabcb5c16d30c34583ab08d9e0c522d Mon Sep 17 00:00:00 2001 From: Polyedre Date: Sat, 20 Jun 2026 11:19:50 +0200 Subject: [PATCH 03/15] ci: give root a throwaway SSH key for the terraform example render examples/terraform.scm reads ~/.ssh/id_*.pub at render time; the runner has none, so generate an ephemeral key (used only as rendered data, never to connect). --- .github/workflows/ci.yml | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 072e2c4..25f46e8 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -51,6 +51,13 @@ jobs: < "$GUIX_PROFILE/share/guix/ci.guix.gnu.org.pub" "$GUIX_BIN/guix" --version + + # examples/terraform.scm reads an SSH public key from ~/.ssh at render + # time. The suite runs as root below, so give root a throwaway key — + # it's read as data for the rendered config, never used to connect. + sudo mkdir -p /root/.ssh + sudo ssh-keygen -t ed25519 -N '' -f /root/.ssh/id_ed25519 -q + # Run as root (daemon owner) to avoid socket-permission friction. cd "$GITHUB_WORKSPACE" sudo "$GUIX_BIN/guix" shell -m manifest.scm -- make build test test-examples From 9c5d152b23b7aac7bc52ae8a81ed11b77b2667b0 Mon Sep 17 00:00:00 2001 From: Polyedre Date: Sun, 21 Jun 2026 14:11:43 +0200 Subject: [PATCH 04/15] hexol: self-contained sops/age secrets example MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit examples/secrets.scm ships an inline (secrets-store …) sealed to an age recipient plus its throwaway identity, so `hexol render -o yaml -i examples/secrets.scm` decrypts and substitutes real plaintext on a fresh clone (the secrets it guards are fake). A `fetch-age-key` hook documents where the decryption key comes from and how to override it. `hexol secret` now loads the inventory before shelling out to sops, so the inventory's own key provisioning — e.g. (setenv "SOPS_AGE_KEY" …) — is honored by the management verbs too, not just `render`. Wire the example into the render smoke-test (it degrades to placeholders where sops is absent, so CI stays green) and point the README at it. --- README.md | 5 ++- bin/hexol | 30 ++++++++++--- examples/secrets.scm | 103 +++++++++++++++++++++++++++++++++++++++++++ test/examples.sh | 1 + 4 files changed, 133 insertions(+), 6 deletions(-) create mode 100644 examples/secrets.scm diff --git a/README.md b/README.md index 4d7749f..64671a8 100644 --- a/README.md +++ b/README.md @@ -112,7 +112,10 @@ While the kernel is target-agnostic, the library provide a few syntaxic sugar he - **Secrets (SOPS)** — secrets live inline in the inventory, encrypted at rest with [sops](https://github.com/getsops/sops): no separate `*.sops.yaml` files to keep in sync. `(secret-ref 'key)` is a cheap marker, so only `render` - shells out to sops; manage the store with the `hexol secret` subcommands. See + shells out to sops; manage the store with the `hexol secret` subcommands. + [`examples/secrets.scm`](examples/secrets.scm) is self-contained — it ships a + throwaway age key, so `hexol render -o yaml -i examples/secrets.scm` decrypts + and substitutes real plaintext on a fresh clone. See also [`examples/homelab.scm`](examples/homelab.scm) and [`docs/authoring.md`](docs/authoring.md#secrets-inline-sops-backed). diff --git a/bin/hexol b/bin/hexol index cc46830..470712f 100755 --- a/bin/hexol +++ b/bin/hexol @@ -180,6 +180,19 @@ (unless (file-exists? inv) (die "no such inventory file: ~a" inv)) (load-inventory-file inv)) +;; `hexol secret` rewrites the inventory *file* (byte-accurate splice), so — +;; unlike `render` — it never evaluates it. But evaluating is exactly what runs +;; the inventory's own key provisioning, e.g. +;; (setenv "SOPS_AGE_KEY" (fetch-age-key)) +;; so without it sops can't find the age/PGP identity to decrypt. Load the +;; inventory first, purely for those side effects, so the same hook that serves +;; `render` serves `secret` too — no separate key protocol. Best-effort: a file +;; that doesn't load cleanly (no ops yet, mid-edit) just falls back to whatever +;; key you've put in the real environment. +(define (prime-inventory-env inv) + (when (and inv (file-exists? inv)) + (catch #t (lambda () (load-inventory-file inv)) (lambda _ #f)))) + ;; Like `load-ops`, but also collect what the file registered onto COLLECTOR — ;; a kernel registration collector (current-renderers / -appliers / -actions). ;; Returns (values ops entries) in registration order. tree/explain/show don't @@ -865,12 +878,19 @@ The inventory comes from -i/--inventory or $HEXOL_INVENTORY.") (lambda (inv vrest) (let* ((pos (filter (lambda (a) (not (string-prefix? "-" a))) vrest)) (sym string->symbol) - ;; Inventory or secret-error (not generic usage-error, so the - ;; secret usage block is shown). + (cached #f) + ;; Resolve the inventory (or secret-error, so the secret usage + ;; block is shown), then prime its env once — running the + ;; inventory's own key hook before secret-tool shells out to + ;; sops. Memoized so it loads at most once per command. (inv* (lambda () - (or inv (env-inventory) - (secret-error "secret ~a: no inventory — pass -i FILE or set $HEXOL_INVENTORY" - verb))))) + (or cached + (let ((p (or inv (env-inventory) + (secret-error "secret ~a: no inventory — pass -i FILE or set $HEXOL_INVENTORY" + verb)))) + (prime-inventory-env p) + (set! cached p) + p))))) (match (cons verb pos) (("ls") (secret-ls (inv*))) (("get" key) (secret-get (inv*) (sym key))) diff --git a/examples/secrets.scm b/examples/secrets.scm new file mode 100644 index 0000000..42b8bfd --- /dev/null +++ b/examples/secrets.scm @@ -0,0 +1,103 @@ +;;; examples/secrets.scm — inline, sops-backed secrets, end to end. +;;; +;;; Unlike examples/homelab.scm (whose real `(secrets-store …)` lives in a +;;; gitignored homelab.secrets.scm and only its deployer can decrypt), this +;;; file is fully self-contained: it carries both the encrypted store AND a +;;; THROWAWAY age key, so `hexol render` decrypts and substitutes real +;;; plaintext for *anyone* on a fresh clone. The secrets it guards are fake. +;;; +;;; Three moving parts (all from (hexol secrets)): +;;; (secrets-store …) — the encrypted store, sealed to an age recipient +;;; (secret-ref 'key) — a marker that stands in for a secret at a field +;;; (resolve-secret-refs) — terminal op: decrypts once, swaps in plaintext +;;; +;;; Render it: ./bin/hexol render -o yaml -i examples/secrets.scm + +(use-modules (hexol k8s) + (hexol secrets)) + +;; ---- where the decryption key comes from ---- +;; +;; sops needs the age *identity* (private key) to decrypt the store below. +;; hexol never touches the key itself — it shells out to `sops -d`, which +;; hunts for the identity in the environment (SOPS_AGE_KEY, then +;; SOPS_AGE_KEY_FILE, …). So the only thing an inventory has to do is put the +;; key somewhere sops already looks. +;; +;; `fetch-age-key' is that single hook. The default below returns a throwaway +;; key hardcoded in this file, so the example is reproducible for everyone. In +;; a real inventory you would REDEFINE it to source the key from wherever you +;; actually keep it — anything that returns the `AGE-SECRET-KEY-1…` string — +;; e.g. one of: +;; +;; (define (fetch-age-key) (getenv "HEXOL_AGE_KEY")) ; from the env +;; +;; (define (fetch-age-key) ; from a file +;; (call-with-input-file "/run/secrets/age.key" +;; (@ (ice-9 textual-ports) get-string-all))) +;; +;; (define (fetch-age-key) ; from `pass` +;; (let* ((p ((@ (ice-9 popen) open-input-pipe) "pass show age/hexol")) +;; (k ((@ (ice-9 textual-ports) get-string-all) p))) +;; (close-pipe p) k)) +;; +(define (fetch-age-key) + "AGE-SECRET-KEY-1E3W2J9G97YCKVJS0FNWSRD7VC7CMYF77TUPYKAQ2MMLF0HS3WHLQ2CM4FW") + +;; Hand it to sops via the environment it already searches. (SOPS_AGE_KEY +;; takes the key material directly; no temp file needed.) +;; +;; NOTE: this runs at inventory *load* time, so it covers `hexol render`. The +;; `hexol secret` management commands (edit/set/rekey/…) do NOT evaluate the +;; inventory — they parse the (secrets-store …) form for byte-accurate +;; rewriting — so they won't see this. To manage the store, export the key +;; yourself first: +;; export SOPS_AGE_KEY=AGE-SECRET-KEY-1E3W2J9G97YCKVJS0FNWSRD7VC7CMYF77TUPYKAQ2MMLF0HS3WHLQ2CM4FW +(setenv "SOPS_AGE_KEY" (fetch-age-key)) + +;; ---- the encrypted store ---- +;; +;; One sops document, sealed to the age recipient +;; `age10fet6zvr3h2dldc36630g93qp6zyd77pfmn63r48fkkwmzauucaq3tem02' (its +;; identity is the throwaway key above). A single age stanza + one MAC cover +;; every secret; `data' keys are kept sorted so the MAC verifies on decrypt. +;; To rotate or add secrets, manage it with `hexol secret set|edit|rekey`. +(secrets-store + (version "3.12.2") + (lastmodified "2026-06-21T11:45:44Z") + (mac "ENC[AES256_GCM,data:qxcrOTSo4weQ/8PSFPWxTa7+aLsAYA120iW4bLEmxEssX16az5t3U0HecSvrxdxgDoYih1ZERT3Mx5lM0dkWs4qhDdSfVAxHpzB0vCwqAuULuKAYVJl10DXS/Hh/v/y21wY38nWSs9zi6qReWI6laeIaFOzgzmgNEunuUfDCBCs=,iv:Jq8ZP1p0NpjMr0Eg7Y4MGnjf5yeOJm5Ar5VaLZ4q0qw=,tag:Spdcx+h4KazMcW6hBoxedA==,type:str]") + (keys + (age + (recipient "age10fet6zvr3h2dldc36630g93qp6zyd77pfmn63r48fkkwmzauucaq3tem02") + (enc + "-----BEGIN AGE ENCRYPTED FILE-----" + "YWdlLWVuY3J5cHRpb24ub3JnL3YxCi0+IFgyNTUxOSBFV1JjNlFVU0xjRkdMRkFl" + "Qm5aeGJDanBnOHhVZ0tUM1MrSDJLSC90YkEwCkh2ZHBTZmFsMThaTWtxMTVMdnUx" + "cUpoN25vaVVlaFdsS2FIUWlyelF0cTQKLS0tICtSQ2IzTWF0Wit1ZmlxOE9zZ2NU" + "UVBoV0FONEQ4Z01BQ3BSK2VUWHJjejAK1ih8/M9sO/1uq0ofzjw80exph4XN2dZq" + "xh5UyEpbIeW7b0FcxRSRcIfB6o/JIndR2M9MCRVwvEHiLrdOeoQWAg==" + "-----END AGE ENCRYPTED FILE-----"))) + (data + (api/token . "ENC[AES256_GCM,data:5eOoONOPZIIwTV+jC5LvWIlmiRo=,iv:I6uShjyWuWsfcgH6jeIGb+ejT5BPOyPprPq7oNADaf4=,tag:qzfJytikUrikVtpJrgv1mA==,type:str]") + (db/password . "ENC[AES256_GCM,data:xcg/hKLvdBv0aGYpcVBfa+P5tw==,iv:3oU1CC5r7BFAFl4MBWUXMy4aOZ0eUqHsFMrJwWRORVA=,tag:9CqsWE70lJNrwXhDWp4a1Q==,type:str]") + (tls/dhparam.pem . "ENC[AES256_GCM,data:Fi2NcXaqcYks7rVM3eoIg7+OTrae9j56tr1HtBC98huJyR+g/8xZaMPvBJVpmin7mRLVHDu8l6sRcj6RlGpbHeJxtk+odPDAa/S2s7TZ4Q6PWxgn+01urxd7,iv:PYFF1cfum3/LD0oJaZPJVSrBa/GLivebT9+q2/ttN7s=,tag:6snTwnpljmmJBhszyo1kxg==,type:str]"))) + +;; ---- consume the secrets ---- +;; +;; `(secret-ref 'key)' bakes a marker into the resource at load time; the +;; render-time `resolve-secret-refs' op below decrypts the store once and +;; swaps each marker for its plaintext. We put them in `string-data' (the +;; plaintext side of a k8s Secret — Kubernetes base64s it at apply), so the +;; rendered YAML shows the decrypted values verbatim. +(hx-ops + (with-namespace "tintin" + (secret "app-secrets" + (string-data + (DB_PASSWORD (secret-ref 'db/password)) + (API_TOKEN (secret-ref 'api/token)))) + (secret "tls-params" + (string-data + (dhparam.pem (secret-ref 'tls/dhparam.pem))))) + + ;; Resolve last: it must run after every resource that holds a marker. + (resolve-secret-refs)) diff --git a/test/examples.sh b/test/examples.sh index dcba9e7..392fdcf 100755 --- a/test/examples.sh +++ b/test/examples.sh @@ -27,6 +27,7 @@ failures=0 cases=( "examples/inventory.scm sexp" "examples/kubernetes.scm yaml" + "examples/secrets.scm yaml" "examples/terraform.scm terraform" "examples/ansible.scm ansible" "examples/database-schema.scm sql" From 421b327c201b112c1db5739aa8e087510f9514e5 Mon Sep 17 00:00:00 2001 From: Polyedre Date: Sun, 21 Jun 2026 14:12:29 +0200 Subject: [PATCH 05/15] hexol: terraform output reporter + validate action MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Replace the file-writing terraform-outputter with two read-only CLI actions in (hexol apply): - terraform-output-reporter: `hexol output` mirrors `terraform output` — bare prints all outputs, a NAME positional prints that one with -raw (so `hexol output kubeconfig > deploy/kubeconfig` lands the file), --json for machine-readable. No files written by hexol itself. - terraform-validator: `hexol validate` writes the rendered config, `tofu init -backend=false` then `tofu validate` — checks exactly what apply would push, touching no infra/state/creds. Factor config-writing into write-terraform-config, shared by the applier and validator. Wire both actions into examples/homelab.scm. --- examples/homelab.scm | 22 ++++++++----- hexol/apply.scm | 78 ++++++++++++++++++++++++++++++-------------- 2 files changed, 67 insertions(+), 33 deletions(-) diff --git a/examples/homelab.scm b/examples/homelab.scm index 50035a9..3ba00de 100644 --- a/examples/homelab.scm +++ b/examples/homelab.scm @@ -666,15 +666,19 @@ ("destroy" "destroy [--dry-run] tear the stack down (tofu destroy)" (terraform-destroyer #:workdir "deploy" #:binary "tofu")) - ;; Re-fetch cluster credentials from existing tofu state, no apply: writes - ;; deploy/kubeconfig + deploy/talosconfig. Install with: - ;; hexol output -i examples/homelab.scm - ;; cp deploy/kubeconfig ~/.kube/config - ;; cp deploy/talosconfig ~/.talos/config - ("output" "output write kubeconfig + talosconfig from tofu state" - (terraform-outputter #:workdir "deploy" #:binary "tofu" - #:outputs '(("kubeconfig" . "deploy/kubeconfig") - ("talosconfig" . "deploy/talosconfig")))) + ;; Validate the rendered Terraform config without touching infra (init + ;; -backend=false, then validate) — a fast `terraform validate' pre-flight: + ;; hexol validate -i examples/homelab.scm + ("validate" "validate validate the rendered tofu config (no apply)" + (terraform-validator #:workdir "deploy" #:binary "tofu")) + + ;; Read terraform outputs from existing state, no apply — like `terraform + ;; output'. Bare prints all; a NAME prints one raw, so you can install creds: + ;; hexol output -i examples/homelab.scm # all outputs + ;; hexol output kubeconfig -i examples/homelab.scm > ~/.kube/config + ;; hexol output talosconfig -i examples/homelab.scm > ~/.talos/config + ("output" "output [NAME] print tofu outputs (all, or NAME with -raw)" + (terraform-output-reporter #:workdir "deploy" #:binary "tofu")) ;; Day-2 config rollout: push machine config to nodes one at a time, waiting ;; for cluster health between each (so a reboot never breaks etcd quorum). Edit diff --git a/hexol/apply.scm b/hexol/apply.scm index c0d4e0e..2317e57 100644 --- a/hexol/apply.scm +++ b/hexol/apply.scm @@ -57,7 +57,7 @@ ;; (hexol kernel). #:re-export (state-get) #:export (terraform-applier kubectl-applier terraform-destroyer - terraform-outputter talos-config-applier + terraform-output-reporter terraform-validator talos-config-applier appliers actions wait-for check report cmd sh-ok?)) ;; ---------- shell helpers ---------- @@ -190,6 +190,20 @@ never fails. Runs even under DRY?." ;; ---------- terraform applier ---------- +;; Write the resolved (terraform_config) subtree to WORKDIR/CONFIG-FILE as +;; Terraform JSON, creating WORKDIR if absent; return the path. Shared by the +;; applier (before init/plan/apply) and the validator (before validate), so both +;; operate on exactly the config hexol renders. Errors if state has no +;; (terraform_config). +(define (write-terraform-config state workdir config-file) + (let ((config (or (state-get state '(terraform_config)) + (error "apply[terraform]: no (terraform_config) in state"))) + (path (string-append workdir "/" config-file))) + (unless (file-exists? workdir) (mkdir workdir)) + (call-with-output-file path + (lambda (p) (emit-terraform-json p config))) + path)) + (define* (terraform-applier #:key (workdir "deploy") (binary "tofu") (config-file "infra.tf.json") (output->file '()) (pre '()) (post '())) @@ -202,15 +216,10 @@ for stock Terraform. #:pre / #:post run their checks (one or a list) before init and after the outputs are written; name the result in an `appliers' form." (lambda (state dry?) (run-checks (as-checks pre) state dry?) - (let ((tf (find-binary binary)) - (config (or (state-get state '(terraform_config)) - (error "apply[terraform]: no (terraform_config) in state"))) - (chdir (string-append "-chdir=" workdir))) - (unless (file-exists? workdir) (mkdir workdir)) - (let ((path (string-append workdir "/" config-file))) - (call-with-output-file path - (lambda (p) (emit-terraform-json p config))) - (log ";; apply[terraform]: wrote ~a~%" path)) + (let ((tf (find-binary binary)) + (chdir (string-append "-chdir=" workdir))) + (log ";; apply[terraform]: wrote ~a~%" + (write-terraform-config state workdir config-file)) (run* tf chdir "init" "-input=false") (cond (dry? (run* tf chdir "plan")) @@ -241,25 +250,46 @@ explicit `hexol' verb — never a step in a bare `hexol apply'." (begin (log ";; destroy: ~a ~a destroy~%" binary chdir) (run* tf chdir "destroy")))))) -;; ---------- terraform outputter (a CLI action, not a pipeline step) ---------- +;; ---------- terraform validator (a CLI action, not a pipeline step) ---------- -(define* (terraform-outputter #:key (workdir "deploy") (binary "tofu") (outputs '())) +(define* (terraform-validator #:key (workdir "deploy") (binary "tofu") + (config-file "infra.tf.json")) "Return an *action* (a (state args -> effects) CLI verb, not an applier) that -fetches terraform outputs out of the state and writes them to files: for each -(OUTPUT . FILE) pair in OUTPUTS, capture `BINARY -chdir=WORKDIR output -raw -OUTPUT' and write it to FILE. Same hand-off `terraform-applier's #:output->file -does after an apply, but on demand — so a `hexol output' verb can re-fetch the -kubeconfig / talosconfig from existing state without re-running apply. Register -it with `defines-action'/`actions' to make it its own `hexol' verb." +validates the rendered config — `terraform validate' for hexol. Writes +WORKDIR/CONFIG-FILE from (terraform_config), runs `BINARY -chdir=WORKDIR init +-backend=false' (provider schemas only — no backend, no creds) then `BINARY +-chdir=WORKDIR validate'. Checks exactly what `hexol apply' would push without +touching infra or state. Register with `defines-action'/`actions' to expose it +as its own `hexol' verb (e.g. `hexol validate')." (lambda (state args) (let ((tf (find-binary binary)) (chdir (string-append "-chdir=" workdir))) - (for-each - (lambda (pair) - (let ((val (capture tf chdir "output" "-raw" (car pair)))) - (write-file (cdr pair) val) - (log ";; output: ~a -> ~a~%" (car pair) (cdr pair)))) - outputs)))) + (log ";; validate: wrote ~a~%" + (write-terraform-config state workdir config-file)) + (run* tf chdir "init" "-backend=false" "-input=false") + (run* tf chdir "validate")))) + +;; ---------- terraform output reporter (a CLI action, not a pipeline step) ---- + +(define* (terraform-output-reporter #:key (workdir "deploy") (binary "tofu")) + "Return an *action* (a (state args -> effects) CLI verb, not an applier) that +reads terraform outputs from existing state and prints them to stdout — `hexol +output', mirroring `terraform output': bare prints every output, a single NAME +positional prints just that one with `-raw' (so `hexol output kubeconfig > +deploy/kubeconfig' lands the file). Pass `--json' for machine-readable output. +Read-only: no apply, no files written by hexol. Register with +`defines-action'/`actions' to make it its own `hexol' verb." + (lambda (state args) + (let* ((tf (find-binary binary)) + (chdir (string-append "-chdir=" workdir)) + (json? (and (member "--json" args) #t)) + ;; first non-flag positional is the output name (terraform output NAME) + (name (find (lambda (a) (not (string-prefix? "-" a))) args))) + (cond + ((and name json?) (run* tf chdir "output" "-json" name)) + (name (run* tf chdir "output" "-raw" name)) + (json? (run* tf chdir "output" "-json")) + (else (run* tf chdir "output")))))) ;; ---------- talos day-2 lifecycle (CLI actions, not pipeline steps) ---------- ;; From bd01b068848c8cd53a6a442fbcf548b9ab3568dd Mon Sep 17 00:00:00 2001 From: Polyedre Date: Sun, 21 Jun 2026 14:13:15 +0200 Subject: [PATCH 06/15] hexol: trim verbose --help footer to the cross-cutting notes MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The footer re-explained every verb's behavior in prose, pushing the verb/inventory-action list — the part --help is actually used for — far down. Keep only the notes that don't fit a synopsis line: where the inventory comes from and the global --color flag. --- bin/hexol | 37 +++++-------------------------------- 1 file changed, 5 insertions(+), 32 deletions(-) diff --git a/bin/hexol b/bin/hexol index 470712f..bce92d6 100755 --- a/bin/hexol +++ b/bin/hexol @@ -1033,39 +1033,12 @@ The inventory comes from -i/--inventory or $HEXOL_INVENTORY.") (inventory-or-default cmd inv)))) ;; The prose tail of `hexol --help`; the verb synopses above it are generated -;; from *actions*, so the help can't drift from the registered set. +;; from *actions*, so the help can't drift from the registered set. Kept terse +;; on purpose — `--help` is mostly used to list verbs/inventory actions, so the +;; footer is just the cross-cutting notes that don't fit a synopsis line. (define usage-footer "\ -sexp (default) and json render the whole resolved state. -o yaml targets the -(kubernetes_resources) list (a `helm template` equivalent); -o tf targets the -(terraform_config) subtree (Terraform JSON config, a `terraform init`-ready -*.tf.json file); -o ansible targets the (ansible_plays) accumulator (an Ansible -playbook, emitted as JSON). -o NAME runs a renderer the inventory registered via -`renders-with` (e.g. -o sql / -o ledger emit that file's domain text). --path -overrides the target. - -apply runs the effect adapters an inventory registers with `applies-with` -(e.g. tofu apply, kubectl apply), in their registered order, against one -resolved state. --list prints that order. --only SPEC runs a subset, keeping -order: SPEC is comma-separated NAMEs or jj-style ranges over the pipeline — -A::B, A:: (A to end), ::B (start to B), e.g. --only kubernetes:: to resume. ---dry-run delegates to each tool's native dry-run (pair it with --only). -Appliers prompt via their own tool; there is no separate hexol confirmation. - -tree prints a stable content hash beside each op; `show HASH` resolves any -unambiguous prefix of one to that op's kind, label, source, location(s), -children, and the state delta it introduced during the resolve. tree -v adds a -per-op fold-time column (the time the resolve spent in each op's effect, -inclusive of its children), so you can see where folding the inventory is slow. - -The inventory is never a positional: pass it with -i/--inventory FILE, or set -$HEXOL_INVENTORY once for the session. So a verb's positional is purely its -domain token, and an exploration loop is just `show HASH` / `explain PATH` — -the iterated token is the only positional (up-arrow, edit it, re-run). - ---color[=always|never|auto] (any position) forces the human views' coloring: -auto (default) paints only on a TTY and honors NO_COLOR; always forces it on -(for `… | less -R` or a colored log); never forces it off. Bare --color = -always. The data renders (sexp/json/yaml/terraform/ansible) are never painted.") +Inventory: -i/--inventory FILE, or set $HEXOL_INVENTORY (never a positional). +Global: --color[=always|never|auto] forces the human views' coloring.") ;; Adapt a kernel — an inventory-contributed (state args -> effects) ;; verb — into a dispatch , so built-ins and inventory verbs share one From 1258239fd31122d173b200fe961772e822f43118 Mon Sep 17 00:00:00 2001 From: Polyedre Date: Sun, 21 Jun 2026 23:06:07 +0200 Subject: [PATCH 07/15] hexol: path-keyed inline secrets, recipient-preserving seal MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Inline secrets no longer need a hand-written id. `(hx-secret "ENC[…]")` is keyed by its path in the resolved state (e.g. kubernetes_resources.app-secrets.stringData.DB_PASSWORD); `(hx-secret 'id "ENC")` still pins an explicit, rename-safe id, and `(secret-ref 'id)` references one. resolve-secret-refs walks the state tracking the path, gathers each marker's ciphertext keyed by id-or-path, decrypts the shared envelope once, and substitutes. The inline registry is gone — the marker carries its cipher. `hexol secret` now folds the inventory (decryption disabled via the secret-resolution-disabled parameter) and runs the same path walk, so seal and decrypt agree on keys; ciphertext byte-search still locates each splice site. Verbs name secrets by path or id. set/edit/rm/edit-all now seal to the recipients already in the envelope (sops -e --age/--pgp), so they need no .sops.yaml and never silently switch a store's recipients; rekey still rotates via the .sops.yaml creation rule. This makes examples/secrets.scm self-managing in-repo without an age creation rule. examples/secrets.scm uses the no-symbol form. --- examples/secrets.scm | 103 ++++----------- hexol/secret-tool.scm | 297 ++++++++++++++++++++++++++++++++---------- hexol/secrets.scm | 214 ++++++++++++++++++++++-------- 3 files changed, 414 insertions(+), 200 deletions(-) diff --git a/examples/secrets.scm b/examples/secrets.scm index 42b8bfd..d288468 100644 --- a/examples/secrets.scm +++ b/examples/secrets.scm @@ -1,103 +1,56 @@ ;;; examples/secrets.scm — inline, sops-backed secrets, end to end. ;;; -;;; Unlike examples/homelab.scm (whose real `(secrets-store …)` lives in a -;;; gitignored homelab.secrets.scm and only its deployer can decrypt), this -;;; file is fully self-contained: it carries both the encrypted store AND a -;;; THROWAWAY age key, so `hexol render` decrypts and substitutes real -;;; plaintext for *anyone* on a fresh clone. The secrets it guards are fake. +;;; Self-contained: it carries the encrypted store AND a throwaway age key, so +;;; `hexol render` decrypts and substitutes real plaintext on a fresh clone. +;;; The secrets it guards are fake. ;;; -;;; Three moving parts (all from (hexol secrets)): -;;; (secrets-store …) — the encrypted store, sealed to an age recipient -;;; (secret-ref 'key) — a marker that stands in for a secret at a field -;;; (resolve-secret-refs) — terminal op: decrypts once, swaps in plaintext +;;; (secrets-store …) the envelope — one age recipient + one MAC, no data +;;; (hx-secret "ENC[…]") a ciphertext at its point of use, keyed by its path +;;; in the output (pin a name with (hx-secret 'id "…")) +;;; (resolve-secret-refs) decrypts once and swaps each marker for plaintext ;;; -;;; Render it: ./bin/hexol render -o yaml -i examples/secrets.scm +;;; Render: ./bin/hexol render -o yaml -i examples/secrets.scm +;;; Manage: ./bin/hexol secret ls|get|set|edit|rekey -i examples/secrets.scm (use-modules (hexol k8s) (hexol secrets)) -;; ---- where the decryption key comes from ---- -;; -;; sops needs the age *identity* (private key) to decrypt the store below. -;; hexol never touches the key itself — it shells out to `sops -d`, which -;; hunts for the identity in the environment (SOPS_AGE_KEY, then -;; SOPS_AGE_KEY_FILE, …). So the only thing an inventory has to do is put the -;; key somewhere sops already looks. -;; -;; `fetch-age-key' is that single hook. The default below returns a throwaway -;; key hardcoded in this file, so the example is reproducible for everyone. In -;; a real inventory you would REDEFINE it to source the key from wherever you -;; actually keep it — anything that returns the `AGE-SECRET-KEY-1…` string — -;; e.g. one of: -;; -;; (define (fetch-age-key) (getenv "HEXOL_AGE_KEY")) ; from the env -;; -;; (define (fetch-age-key) ; from a file -;; (call-with-input-file "/run/secrets/age.key" -;; (@ (ice-9 textual-ports) get-string-all))) -;; -;; (define (fetch-age-key) ; from `pass` -;; (let* ((p ((@ (ice-9 popen) open-input-pipe) "pass show age/hexol")) -;; (k ((@ (ice-9 textual-ports) get-string-all) p))) -;; (close-pipe p) k)) -;; +;; sops decrypts with the age identity it finds in the environment; hexol just +;; has to put it there. `fetch-age-key' is the hook — here a hardcoded +;; throwaway key; in a real inventory return yours instead, e.g. +;; (define (fetch-age-key) (getenv "HEXOL_AGE_KEY")) (define (fetch-age-key) "AGE-SECRET-KEY-1E3W2J9G97YCKVJS0FNWSRD7VC7CMYF77TUPYKAQ2MMLF0HS3WHLQ2CM4FW") -;; Hand it to sops via the environment it already searches. (SOPS_AGE_KEY -;; takes the key material directly; no temp file needed.) -;; -;; NOTE: this runs at inventory *load* time, so it covers `hexol render`. The -;; `hexol secret` management commands (edit/set/rekey/…) do NOT evaluate the -;; inventory — they parse the (secrets-store …) form for byte-accurate -;; rewriting — so they won't see this. To manage the store, export the key -;; yourself first: -;; export SOPS_AGE_KEY=AGE-SECRET-KEY-1E3W2J9G97YCKVJS0FNWSRD7VC7CMYF77TUPYKAQ2MMLF0HS3WHLQ2CM4FW (setenv "SOPS_AGE_KEY" (fetch-age-key)) -;; ---- the encrypted store ---- -;; -;; One sops document, sealed to the age recipient -;; `age10fet6zvr3h2dldc36630g93qp6zyd77pfmn63r48fkkwmzauucaq3tem02' (its -;; identity is the throwaway key above). A single age stanza + one MAC cover -;; every secret; `data' keys are kept sorted so the MAC verifies on decrypt. -;; To rotate or add secrets, manage it with `hexol secret set|edit|rekey`. +;; The envelope: crypto metadata for one sops document, sealed to the throwaway +;; key's recipient. No data block — ciphertexts live inline below. (secrets-store (version "3.12.2") - (lastmodified "2026-06-21T11:45:44Z") - (mac "ENC[AES256_GCM,data:qxcrOTSo4weQ/8PSFPWxTa7+aLsAYA120iW4bLEmxEssX16az5t3U0HecSvrxdxgDoYih1ZERT3Mx5lM0dkWs4qhDdSfVAxHpzB0vCwqAuULuKAYVJl10DXS/Hh/v/y21wY38nWSs9zi6qReWI6laeIaFOzgzmgNEunuUfDCBCs=,iv:Jq8ZP1p0NpjMr0Eg7Y4MGnjf5yeOJm5Ar5VaLZ4q0qw=,tag:Spdcx+h4KazMcW6hBoxedA==,type:str]") + (lastmodified "2026-06-21T13:41:25Z") + (mac "ENC[AES256_GCM,data:oIN8GNRf3fCK2iLrrOJkuwXSQITUK6lJ3WRrfybDwFEwZjWXklKsk3CqdytLm5Zmtbc0RJO5f+pTuQ4GzAHqlLxTSRmZX+UOlhMVdG2lD4Vm2DKDclZ8s18+fxWPviQP3IgwHzeMTIrNaf7alXEE765aYCom3G5aC4mNE1uThAE=,iv:CkoYhk0oBDpi3txa97c8cvyzIvpH9LARIaAL+WAT7CA=,tag:vOxJCMdGITlPvoBBkdIZLw==,type:str]") (keys (age (recipient "age10fet6zvr3h2dldc36630g93qp6zyd77pfmn63r48fkkwmzauucaq3tem02") (enc "-----BEGIN AGE ENCRYPTED FILE-----" - "YWdlLWVuY3J5cHRpb24ub3JnL3YxCi0+IFgyNTUxOSBFV1JjNlFVU0xjRkdMRkFl" - "Qm5aeGJDanBnOHhVZ0tUM1MrSDJLSC90YkEwCkh2ZHBTZmFsMThaTWtxMTVMdnUx" - "cUpoN25vaVVlaFdsS2FIUWlyelF0cTQKLS0tICtSQ2IzTWF0Wit1ZmlxOE9zZ2NU" - "UVBoV0FONEQ4Z01BQ3BSK2VUWHJjejAK1ih8/M9sO/1uq0ofzjw80exph4XN2dZq" - "xh5UyEpbIeW7b0FcxRSRcIfB6o/JIndR2M9MCRVwvEHiLrdOeoQWAg==" - "-----END AGE ENCRYPTED FILE-----"))) - (data - (api/token . "ENC[AES256_GCM,data:5eOoONOPZIIwTV+jC5LvWIlmiRo=,iv:I6uShjyWuWsfcgH6jeIGb+ejT5BPOyPprPq7oNADaf4=,tag:qzfJytikUrikVtpJrgv1mA==,type:str]") - (db/password . "ENC[AES256_GCM,data:xcg/hKLvdBv0aGYpcVBfa+P5tw==,iv:3oU1CC5r7BFAFl4MBWUXMy4aOZ0eUqHsFMrJwWRORVA=,tag:9CqsWE70lJNrwXhDWp4a1Q==,type:str]") - (tls/dhparam.pem . "ENC[AES256_GCM,data:Fi2NcXaqcYks7rVM3eoIg7+OTrae9j56tr1HtBC98huJyR+g/8xZaMPvBJVpmin7mRLVHDu8l6sRcj6RlGpbHeJxtk+odPDAa/S2s7TZ4Q6PWxgn+01urxd7,iv:PYFF1cfum3/LD0oJaZPJVSrBa/GLivebT9+q2/ttN7s=,tag:6snTwnpljmmJBhszyo1kxg==,type:str]"))) + "YWdlLWVuY3J5cHRpb24ub3JnL3YxCi0+IFgyNTUxOSBvb2luOG54TVo2MVNwbUJY" + "WFpKWms4SWxYQzltR2licFBhVTJqWTFlUEcwCmZmSk81UnhnQ1l5UXdWQ1VreHpk" + "K1NhSkk3SFd1cmRIZENCZkErKytieTQKLS0tIGhJbWo5cFFLUlFVQ2RHVThvbWdM" + "V0NubTNldi96QmwrRWFwQXh3QXMraVEKPH0Gbnm9ygDW34kSlXJVecgOJ57wYQwr" + "wInFC7JEUDYli9Gb0z/hzIq1mPaIVvNRNsJ/chv1tvMsBLBr4jJb1A==" + "-----END AGE ENCRYPTED FILE-----")))) -;; ---- consume the secrets ---- -;; -;; `(secret-ref 'key)' bakes a marker into the resource at load time; the -;; render-time `resolve-secret-refs' op below decrypts the store once and -;; swaps each marker for its plaintext. We put them in `string-data' (the -;; plaintext side of a k8s Secret — Kubernetes base64s it at apply), so the -;; rendered YAML shows the decrypted values verbatim. +;; Each (hx-secret "ENC[…]") resolves to its plaintext at render. Using +;; `string-data' (plaintext side of a k8s Secret) shows the decrypted values. (hx-ops (with-namespace "tintin" (secret "app-secrets" (string-data - (DB_PASSWORD (secret-ref 'db/password)) - (API_TOKEN (secret-ref 'api/token)))) + (DB_PASSWORD (hx-secret "ENC[AES256_GCM,data:zZw60P1n7VDwgyWx3Kg4xsW1tw==,iv:iKO5lh40stVRKZwv6dBNVi46cNNbYpZjflanijxI/n8=,tag:LvnSOK4zDk+F0NprFeTu6g==,type:str]")) + (API_TOKEN (hx-secret "ENC[AES256_GCM,data:09mmjPNA3QKWjf/S6f+DUj/znvs=,iv:+Gr+CkAYJQakLfJbQYeJoh/W7kg/Jcse75/Kzg2MP3k=,tag:7NcJl8TKalOKUcM/Bv7gpg==,type:str]")))) (secret "tls-params" (string-data - (dhparam.pem (secret-ref 'tls/dhparam.pem))))) - - ;; Resolve last: it must run after every resource that holds a marker. + (dhparam.pem (hx-secret "ENC[AES256_GCM,data:xsF6bl936FdZoP1nY/DehNSPr4xEJNuiOdivydLJmjB/8I79IeQNDNO7qsdFguSDs5PgKtkdB82Ec7khOE5R2Y6oHawwhWpRQLxXqbY+LnX1vt5FwjpTZq7t,iv:qnCpHwtnZm8JhuDMZijjwym3U1xzJvvOdvyP8PqyqR4=,tag:86BYrKZqRN7wJzK9i68qnQ==,type:str]"))))) (resolve-secret-refs)) diff --git a/hexol/secret-tool.scm b/hexol/secret-tool.scm index f8b2afa..dfef157 100644 --- a/hexol/secret-tool.scm +++ b/hexol/secret-tool.scm @@ -19,9 +19,9 @@ (define-module (hexol secret-tool) #:use-module (hexol secrets) + #:use-module (hexol kernel) ; resolve + load-inventory-file (path keys) #:use-module (srfi srfi-1) #:use-module (srfi srfi-13) - #:use-module (ice-9 match) #:use-module (ice-9 format) #:use-module (ice-9 popen) #:use-module (ice-9 textual-ports) @@ -38,7 +38,6 @@ (define (clause-val clauses tag) (let ((c (assq tag clauses))) (and c (pair? (cdr c)) (cadr c)))) (define (store-data clauses) (or (clause-tail clauses 'data) '())) -(define (store-keys clauses) (map (lambda (kv) (car kv)) (store-data clauses))) ;; Raise in the (scm-error) shape bin/hexol's reporter formats cleanly: ;; ~a/~p holes in FMT filled with ARGS. @@ -108,22 +107,86 @@ (values (cdr form) (scan-to-open bv before) (ftell port) bv)) (else (loop))))))) -(define (require-store path) - (call-with-values (lambda () (find-store-form path)) - (lambda (clauses start end bv) - (unless clauses - (fail "no (secrets-store …) form in ~a — run `hexol secret init` first" path)) - (values clauses start end bv)))) +;; ---------- inline secrets: (hx-secret "ENC[…]") / (hx-secret 'id "ENC") ---- +;; +;; Inline ciphertexts live at their point of use; the store form is the shared +;; *envelope* (one age key, one MAC). Each secret is keyed by an explicit id or +;; by its PATH in the resolved state (see (hexol secrets)). To manage these we +;; need each secret's (keystr . ciphertext) — for decrypt + re-seal — and the +;; *byte span* of each ciphertext literal — to splice a fresh one back. +;; +;; The keystrings come from resolving the inventory with decryption disabled +;; and running the SAME path-walk (`marker-doc') the renderer uses, so seal and +;; decrypt agree on the keys. The spans come from byte-searching the raw file +;; for the quoted literal: sops `ENC[…]' strings are ASCII and globally unique +;; (random iv/tag), so the search is exact and dodges the char-vs-byte hazard. + +;; Fold the inventory to the marker-bearing state (no sops), then gather the +;; inline secrets as (keystr . ciphertext). +(define (resolve-inline path) + (parameterize ((secret-resolution-disabled #t)) + (marker-doc (resolve (load-inventory-file path) '())))) + +;; Byte search: all non-overlapping start offsets of PAT in BV. +(define (bv-match-at? bv i pat) + (let ((m (bytevector-length pat))) + (let lp ((j 0)) + (cond ((= j m) #t) + ((= (bytevector-u8-ref bv (+ i j)) (bytevector-u8-ref pat j)) (lp (+ j 1))) + (else #f))))) + +(define (bv-find-all bv pat) + (let ((n (bytevector-length bv)) (m (bytevector-length pat))) + (let loop ((i 0) (acc '())) + (cond ((> (+ i m) n) (reverse acc)) + ((bv-match-at? bv i pat) (loop (+ i m) (cons i acc))) + (else (loop (+ i 1) acc)))))) + +;; ((idstr start end) …): the byte span of every inline ciphertext literal +;; (quotes included), so a re-seal can splice fresh ciphertext over each. +(define (inline-cipher-spans bv inline) + (append-map + (lambda (kv) + (let* ((pat (string->utf8 (string-append "\"" (cdr kv) "\""))) + (m (bytevector-length pat)) + (starts (bv-find-all bv pat))) + (when (null? starts) + (fail "inline ciphertext for ~a is not a plain string literal — can't rewrite it" + (car kv))) + (map (lambda (s) (list (car kv) s (+ s m))) starts))) + inline)) ;; ---------- decrypt / plaintext ---------- -;; Plaintext map ((kstr . value) …). Empty `data' means never sealed (e.g. -;; just `init'd) — no sops call, just '(). -(define (load-plaintext clauses) - (if (null? (store-data clauses)) - '() - (or (decrypt-yaml (clauses->sops-yaml clauses)) - (fail "could not decrypt the store (is your key available?)")))) +;; Return CLAUSES with their `data' clause replaced by DATA ((k . cipher) …). +(define (set-data clauses data) + (append (filter (lambda (c) (not (eq? (car c) 'data))) clauses) + (list (cons 'data data)))) + +;; Merge the store's `data' block with the inline (idstr . cipher) pairs into +;; one (idstr . cipher) alist — the full sealed map. A key in both must carry +;; identical ciphertext (they seal as one document). +(define (merge-data clauses inline) + (let ((out (map (lambda (kv) (cons (symbol->string (car kv)) (cdr kv))) + (store-data clauses)))) + (for-each + (lambda (kv) + (let ((cur (assoc (car kv) out))) + (cond + ((not cur) (set! out (append out (list kv)))) + ((not (string=? (cdr cur) (cdr kv))) + (fail "inline secret ~a conflicts with the store `data' block" (car kv)))))) + inline) + out)) + +;; Plaintext map ((kstr . value) …) from the merged block+inline ciphertexts. +;; Empty means never sealed (e.g. just `init'd) — no sops call, just '(). +(define (load-plaintext clauses inline) + (let ((merged (merge-data clauses inline))) + (if (null? merged) + '() + (or (decrypt-yaml (clauses->sops-yaml (set-data clauses merged))) + (fail "could not decrypt the store (is your key available?)"))))) ;; ---------- sealing (mutate → fresh sops doc → structured clauses) ---------- @@ -140,32 +203,57 @@ (define (mk-seal-dir) (mkdtemp "/tmp/hexol-seal-XXXXXX")) -;; Encrypt PLAIN ((kstr . val) …) into fresh structured store clauses via the -;; creation rule in SOPS-CONFIG. An empty map seals to `((data))'. -(define (seal-data plain sops-config) +;; Encrypt PLAIN ((kstr . val) …) into fresh structured store clauses, passing +;; EXTRA-ARGS verbatim to `sops -e' (either `--config ' to use a creation +;; rule, or `--age …`/`--pgp …` to seal to explicit recipients). An empty map +;; seals to `((data))'. Keys are sorted in the same order `clauses->sops-yaml' +;; feeds sops at decrypt, so the MAC (over data values in tree order) verifies. +(define (sops-encrypt plain extra-args) (if (null? plain) '((data)) (let* ((sops (or (which-cmd "sops") (fail "sops not on PATH"))) (dir (mk-seal-dir)) (file (string-append dir "/store.sops.yaml")) - ;; Sort in the same order `clauses->sops-yaml' feeds sops at - ;; decrypt: the MAC covers data values in tree order, so the two - ;; orders must agree or decrypt fails with a MAC mismatch. (sorted (sort plain (lambda (a b) (stringjson-string (list (cons "data" sorted))))) (call-with-output-file file (lambda (p) (display json p))) - (let* ((cmd (format #f "~a -e --config ~a --input-type json --output-type json ~a" - sops sops-config file)) + (let* ((cmd (format #f "~a -e ~a --input-type json --output-type json ~a" + sops extra-args file)) (in (open-input-pipe cmd)) (output (get-string-all in)) (status (close-pipe in))) (delete-file file) (rmdir dir) (unless (zero? (status:exit-val status)) - (fail "sops -e failed (check the .sops.yaml creation rule)")) + (fail "sops -e failed (~a)" extra-args)) (json->clauses (json-string->scm output)))))) -(define (lines-of s) (if (string? s) (string-split s #\newline) '())) +;; Seal via the .sops.yaml creation rule (used by `rekey' to rotate recipients, +;; and as a fallback when the store has no recipients yet). +(define (seal-data plain sops-config) + (sops-encrypt plain (string-append "--config " sops-config))) + +;; `sops -e' flags that seal to the recipients ALREADY in the store envelope — +;; so set/edit preserve them instead of re-reading .sops.yaml. KEYS is the +;; envelope's `keys' clause: (age (recipient "…") …) / (pgp (fp "…") …). "" if +;; there are none (then the caller falls back to the creation rule). +(define (recipient-flags keys) + (let ((ages (filter-map (lambda (e) (and (eq? (car e) 'age) (clause-val (cdr e) 'recipient))) keys)) + (pgps (filter-map (lambda (e) (and (eq? (car e) 'pgp) (clause-val (cdr e) 'fp))) keys))) + (string-append + (if (pair? ages) (string-append " --age " (string-join ages ",")) "") + (if (pair? pgps) (string-append " --pgp " (string-join pgps ",")) "")))) + +;; Split a sops `enc' value into lines for the `(enc …)' clause. sops' value +;; ends in a newline, so drop trailing empties — but keep interior blanks (PGP +;; armor has a meaningful blank line after its header). +(define (lines-of s) + (if (string? s) + (let loop ((ls (reverse (string-split s #\newline)))) + (if (and (pair? ls) (string=? (car ls) "")) + (loop (cdr ls)) + (reverse ls))) + '())) ;; sops emits the recipient id under varying field names; keep only the ;; load-bearing ones, dropping any the encrypt left empty. @@ -248,11 +336,10 @@ (if (null? (cdr ks)) (format p ")~%") ; close keys (begin (newline p) (loop (cdr ks))))))) - (format p " (data") - (if (null? data) - (format p ")")) + ;; A `data' block only when there are block (non-inline) keys; an + ;; all-inline store stays pure envelope. (unless (null? data) - (newline p) + (format p " (data~%") (let loop ((ds data)) (let ((kv (car ds))) (format p " (~a . ~s)" (sym->text (car kv)) (cdr kv)) @@ -263,42 +350,101 @@ ;; ---------- splice ---------- -;; Replace bytes [START,END) with NEW-FORM (a string), leaving the rest of -;; the file untouched. -(define (splice-store! path start end new-form) - (let ((bv (slurp-bytes path))) +;; Apply several non-overlapping replacements in one pass. REGIONS is a list of +;; (START END BYTES); each [START,END) becomes BYTES, the rest is byte-identical. +(define (splice-regions! path regions) + (let* ((bv (slurp-bytes path)) + (sorted (sort regions (lambda (a b) (< (car a) (car b)))))) + ;; Guard against overlap — a bug here would corrupt the file. + (let chk ((rs sorted)) + (when (and (pair? rs) (pair? (cdr rs))) + (when (> (cadr (car rs)) (car (cadr rs))) + (fail "internal: overlapping splice regions")) + (chk (cdr rs)))) (call-with-output-file path (lambda (p) - (put-bytevector p (subbv bv 0 start)) - (put-bytevector p (string->utf8 new-form)) - (put-bytevector p (subbv bv end (bytevector-length bv)))) + (let loop ((pos 0) (rs sorted)) + (if (null? rs) + (put-bytevector p (subbv bv pos (bytevector-length bv))) + (let ((s (car (car rs))) (e (cadr (car rs))) (nw (caddr (car rs)))) + (put-bytevector p (subbv bv pos s)) + (put-bytevector p nw) + (loop e (cdr rs)))))) #:binary #t))) -;; Re-seal PLAIN and write the regenerated form over [START,END). -(define (reseal! path start end plain) - (let* ((cfg (find-sops-config path)) - (clauses (seal-data plain cfg))) - (splice-store! path start end (emit-store-form clauses)) - clauses)) +;; Re-seal PLAIN. Normally seal to the recipients ALREADY in the envelope +;; (CLAUSES' `keys'), so set/edit preserve them; REKEY? (or a store with no +;; recipients yet) falls back to the .sops.yaml creation rule — that's how +;; `rekey' rotates. +(define (reseal-clauses path clauses plain rekey?) + (let ((flags (recipient-flags (or (clause-tail clauses 'keys) '())))) + (if (or rekey? (string-null? flags)) + (seal-data plain (find-sops-config path)) + (sops-encrypt plain flags)))) + +;; Re-seal PLAIN (the whole map) and write it back across the inline layout: +;; the envelope form over [ENV-START,ENV-END) carrying only the keys that have +;; no inline site, plus fresh ciphertext spliced over each inline ciphertext in +;; INLINE-SPANS ((keystr start end) …). Re-sealing regenerates the data key, so +;; *every* ciphertext changes — hence all spans are rewritten in one pass. +(define (reseal-inline! path env-start env-end inline-spans clauses plain rekey?) + (let* ((sealed (reseal-clauses path clauses plain rekey?)) ; full clauses, all data + (dmap (map (lambda (kv) (cons (symbol->string (car kv)) (cdr kv))) + (store-data sealed))) ; (keystr . new-cipher) + (inline-ids (delete-duplicates (map car inline-spans) string=?)) + (block (filter (lambda (kv) (not (member (car kv) inline-ids))) dmap)) + (env-form (emit-store-form + (set-data sealed + (map (lambda (kv) (cons (string->symbol (car kv)) (cdr kv))) + block)))) + (regions (cons (list env-start env-end (string->utf8 env-form)) + (map (lambda (sp) + (let* ((id (car sp)) (s (cadr sp)) (e (caddr sp)) + (nc (assoc-ref dmap id))) + (unless nc + (fail "cannot remove inline secret ~a — delete its (hx-secret …) form first" id)) + (list s e (string->utf8 (string-append "\"" nc "\""))))) + inline-spans)))) + (splice-regions! path regions) + sealed)) ;; ---------- the verbs ---------- +;; +;; Each verb runs through `call-with-store', which locates the envelope form +;; (CLAUSES + [START,END)), the inline (idstr . cipher) pairs, and each inline +;; ciphertext's byte SPANS, then hands them to PROC. Mutating verbs re-seal the +;; merged map with `reseal-inline!', which rewrites the envelope and every +;; inline ciphertext in one pass. + +(define (call-with-store path proc) + (call-with-values (lambda () (find-store-form path)) + (lambda (clauses start end bv) + (unless clauses + (fail "no (secrets-store …) form in ~a — run `hexol secret init` first" path)) + (let* ((inline (resolve-inline path)) ; (keystr . cipher), via resolve + (spans (inline-cipher-spans bv inline))) + (proc clauses start end inline spans))))) + +;; True if KSTR is one of the inline-declared secrets. +(define (inline-key? kstr spans) (and (member kstr (map car spans)) #t)) (define (secret-ls path) - (call-with-values (lambda () (require-store path)) - (lambda (clauses start end text) - (let ((keys (store-keys clauses))) + (call-with-store path + (lambda (clauses start end inline spans) + (let ((keys (sort (map car (merge-data clauses inline)) stringstring kinds) ", ")))))))) + (string-join (map symbol->string kinds) ", ")) + (and (pair? inline) (length inline)))))))) (define (secret-get path key) - (call-with-values (lambda () (require-store path)) - (lambda (clauses start end text) - (let* ((plain (load-plaintext clauses)) + (call-with-store path + (lambda (clauses start end inline spans) + (let* ((plain (load-plaintext clauses inline)) (entry (assoc (symbol->string key) plain))) (unless entry (fail "no such key: ~a" key)) (display (cdr entry)) @@ -306,32 +452,38 @@ ;; VALUE is a string, or #f to read the value from stdin. (define (secret-set path key value) - (call-with-values (lambda () (require-store path)) - (lambda (clauses start end text) + (call-with-store path + (lambda (clauses start end inline spans) (let* ((v (or value (string-trim-right (get-string-all (current-input-port)) #\newline))) - (plain (load-plaintext clauses)) + (plain (load-plaintext clauses inline)) (kstr (symbol->string key)) + (new? (not (assoc kstr plain))) (next (assoc-set! (alist-copy plain) kstr v))) - (reseal! path start end next) + (reseal-inline! path start end spans clauses next #f) + (when new? + (format (current-error-port) + ";; ~a is new — sealed into the store's data block (no inline site)~%" kstr)) (format (current-error-port) "✓ sealed ~a secret~p → ~a~%" (length next) (length next) path))))) (define (secret-rm path key) - (call-with-values (lambda () (require-store path)) - (lambda (clauses start end text) + (call-with-store path + (lambda (clauses start end inline spans) (let* ((kstr (symbol->string key)) - (plain (load-plaintext clauses))) + (plain (load-plaintext clauses inline))) (unless (assoc kstr plain) (fail "no such key: ~a" key)) + (when (inline-key? kstr spans) + (fail "~a is declared inline — delete its (hx-secret …) form, then `rekey`" kstr)) (let ((next (alist-delete kstr (alist-copy plain)))) - (reseal! path start end next) + (reseal-inline! path start end spans clauses next #f) (format (current-error-port) "✓ removed ~a — sealed ~a secret~p → ~a~%" key (length next) (length next) path)))))) (define (secret-edit path key) - (call-with-values (lambda () (require-store path)) - (lambda (clauses start end text) + (call-with-store path + (lambda (clauses start end inline spans) (let* ((kstr (symbol->string key)) - (plain (load-plaintext clauses)) + (plain (load-plaintext clauses inline)) (cur (let ((e (assoc kstr plain))) (if e (cdr e) ""))) (editor (or (getenv "EDITOR") "vi")) (tmpl (string-copy "/tmp/hexol-edit-XXXXXX")) @@ -349,7 +501,7 @@ (format (current-error-port) ";; ~a unchanged — nothing to seal~%" key)) (else (let ((next (assoc-set! (alist-copy plain) kstr new))) - (reseal! path start end next) + (reseal-inline! path start end spans clauses next #f) (format (current-error-port) "✓ updated ~a — sealed ~a secret~p → ~a~%" key (length next) (length next) path))))))))) @@ -409,9 +561,9 @@ pairs))) (define (secret-edit-all path) - (call-with-values (lambda () (require-store path)) - (lambda (clauses start end text) - (let* ((plain (load-plaintext clauses)) + (call-with-store path + (lambda (clauses start end inline spans) + (let* ((plain (load-plaintext clauses inline)) (editor (or (getenv "EDITOR") "vi")) (tmpl (string-copy "/tmp/hexol-edit-XXXXXX")) (tp (mkstemp! tmpl))) @@ -424,21 +576,26 @@ (let ((new-text (call-with-input-file tmpl get-string-all))) (delete-file tmpl) ; plaintext off disk before parsing (let* ((next (parse-plain-sexp new-text)) + (dropped (filter (lambda (id) (not (assoc id next))) + (delete-duplicates (map car spans) string=?))) (norm (lambda (m) (sort (map (lambda (kv) (cons (car kv) (cdr kv))) m) (lambda (a b) (stringsops-yaml decrypt-yaml secrets-warn)) + #:export (secrets-store secret-ref secret-ref? secret-ref-key secret-ref-cipher + hx-secret resolve-secret-refs secret-resolution-disabled + ;; reused by (hexol secret-tool): doc gather + serializer + decrypt. + marker-doc clauses->sops-yaml decrypt-yaml secrets-warn)) ;; ---------- the secret-ref marker ---------- ;; -;; `(secret-ref 'key)` returns one of these — data, not an op. It sits where -;; the author wrote it until `resolve-secret-refs` swaps in the plaintext. +;; A marker is data, not an op — it sits where the author wrote it until +;; `resolve-secret-refs' swaps in the plaintext. It carries two optional bits: +;; +;; KEY an explicit symbol id, or #f → the secret is keyed by its *path* +;; in the resolved state (where it ends up in the tree). +;; CIPHER the inline `ENC[…]' ciphertext, or #f → a pure reference that +;; borrows another marker's (or the store block's) ciphertext by id. +;; +;; So `(hx-secret "ENC")' is path-keyed inline data; `(hx-secret 'id "ENC")' is +;; symbol-keyed inline data (rename-safe, re-usable); `(secret-ref 'id)' is a +;; pure reference. All resolve through the SAME store envelope (one age key, +;; one MAC) — only the source layout and the choice of key differ. (define-record-type - (make-secret-ref key) + (make-secret-ref key cipher) secret-ref? - (key secret-ref-key)) + (key secret-ref-key) + (cipher secret-ref-cipher)) (define (secret-ref key) - "Return a marker standing in for the secret named KEY (a symbol) until -`resolve-secret-refs' decrypts the store and substitutes its plaintext." - (make-secret-ref key)) + "Reference the secret named KEY (a symbol), declared elsewhere by +`(hx-secret 'KEY …)' or in the store's `(data …)' block. A marker with no +ciphertext of its own." + (make-secret-ref key #f)) + +(define hx-secret + ;; (hx-secret "ENC[…]") → keyed by its path in the resolved state. + ;; (hx-secret 'id "ENC[…]") → keyed by the explicit symbol ID (survives + ;; renames, and re-usable via (secret-ref 'id)). + (case-lambda + ((cipher) + (unless (string? cipher) + (error "secrets: (hx-secret CIPHER) wants a ciphertext string, got:" cipher)) + (make-secret-ref #f cipher)) + ((id cipher) + (unless (and (symbol? id) (string? cipher)) + (error "secrets: (hx-secret 'ID CIPHER) wants a symbol then a string, got:" id cipher)) + (make-secret-ref id cipher)))) -;; ---------- the registered store ---------- +;; ---------- the registered store (the envelope) ---------- ;; ;; `(secrets-store …)` quotes and records its clauses — it does NOT decrypt. ;; `registered-store` holds the clause alist (version / lastmodified / mac / -;; age / data); `decrypt-memo` caches the one per-render decryption ('unset -;; until forced, then the plaintext string-keyed alist, or #f on failure). +;; keys / optional data). Inline ciphertexts no longer register here; they are +;; gathered from the resolved state at resolve time (see `marker-doc'). (define registered-store #f) -(define decrypt-memo 'unset) (define-syntax secrets-store (syntax-rules () @@ -75,24 +100,24 @@ (register-secrets-store! (quote (clause ...)))))) (define (register-secrets-store! clauses) - "Record the quoted CLAUSES of a (secrets-store …) form for later -decryption. Resets any cached plaintext." + "Record the quoted CLAUSES of a (secrets-store …) form for later decryption." (set! registered-store clauses) - (set! decrypt-memo 'unset) *unspecified*) -;; clause accessors: (version "x") → "x" (scalar); (data (k . v) …) → the -;; tail (multi); likewise (age …). `clause-*' take an explicit alist (so the -;; CLI can serialize a parsed store); `store-*' are shorthands over the -;; registered store. +;; When parameterized to #t, `resolve-secret-refs' leaves the markers in place +;; instead of decrypting — so (hexol secret-tool) can fold the inventory to the +;; marker-bearing state, read each secret's path/ciphertext, and never shell +;; out to sops just to inspect the layout. +(define secret-resolution-disabled (make-parameter #f)) + +;; clause accessors over an explicit clause alist: (version "x") → "x" +;; (scalar); (data (k . v) …) → the tail (multi); likewise (keys …). (define (clause-scalar clauses tag) (let ((c (and clauses (assq tag clauses)))) (and c (pair? (cdr c)) (cadr c)))) (define (clause-multi clauses tag) (let ((c (and clauses (assq tag clauses)))) (and c (cdr c)))) -(define (store-scalar tag) (clause-scalar registered-store tag)) -(define (store-multi tag) (clause-multi registered-store tag)) ;; ---------- serialization back to a sops document ---------- ;; @@ -179,7 +204,83 @@ decryption. Resets any cached plaintext." (format p " mac: ~a~%" (clause-scalar clauses 'mac)) (format p " version: ~a~%" (clause-scalar clauses 'version)))))) -(define (store->sops-yaml) (clauses->sops-yaml registered-store)) +;; ---------- walking the resolved state by path ---------- +;; +;; A secret's key is its explicit symbol id, or — lacking one — its PATH in the +;; resolved state: the dotted chain of alist keys and sequence labels leading +;; to it. resolve and (hexol secret-tool) both compute it from the same walk +;; over the same state, so the sops data-map key (which is each value's GCM +;; AAD) matches between seal and decrypt. + +(define (alist-get alist k) (let ((c (assq k alist))) (and c (cdr c)))) + +;; A value is alist-like when it is a non-empty proper list of (key . _) pairs +;; with symbol/string keys; a proper list that is not alist-like is a sequence. +(define (alist-like? v) + (and (pair? v) (list? v) + (every (lambda (e) (and (pair? e) (let ((k (car e))) (or (symbol? k) (string? k))))) + v))) +(define (seq-like? v) (and (pair? v) (list? v) (not (alist-like? v)))) + +(define (comp->string c) + (cond ((symbol? c) (symbol->string c)) ((number? c) (number->string c)) (else c))) +(define (path->key parts) (string-join (map comp->string (reverse parts)) ".")) + +;; A sequence element's label: its `name' (top-level or under `metadata') when +;; present and unique among siblings, else its index — keeps k8s resource paths +;; readable and reorder-stable where resources are named. +(define (element-name e) + (and (alist-like? e) + (let* ((md (alist-get e 'metadata)) + (n (or (alist-get e 'name) + (and (alist-like? md) (alist-get md 'name))))) + (and (string? n) n)))) +(define (seq-labels elements) + (let ((names (map element-name elements))) + (map (lambda (nm i) + (if (and nm (= 1 (length (filter (lambda (x) (equal? x nm)) names)))) nm i)) + names (iota (length elements))))) + +;; KEY of a marker reached at PARTS: its explicit id, else its path. +(define (marker-key m parts) + (if (secret-ref-key m) (key->string (secret-ref-key m)) (path->key parts))) + +;; Merge (keystr . cipher) pairs into ACC, erroring on a divergent ciphertext +;; for a key already present (they seal as one document). +(define (doc-add acc k c) + (let ((cur (assoc k acc))) + (cond ((not cur) (cons (cons k c) acc)) + ((equal? (cdr cur) c) acc) + (else (error "secrets: two different ciphertexts for key:" k))))) + +;; Gather every cipher-bearing marker in STATE as (keystr . ciphertext), keyed +;; by id or path — the inline secrets, in first-seen order. (Excludes the +;; store's `(data …)' block; see `full-doc'.) +(define (marker-doc state) + (let ((acc '())) + (define (walk v parts) + (cond + ((secret-ref? v) + (when (secret-ref-cipher v) + (set! acc (doc-add acc (marker-key v parts) (secret-ref-cipher v))))) + ((alist-like? v) (for-each (lambda (e) (walk (cdr e) (cons (car e) parts))) v)) + ((seq-like? v) + (for-each (lambda (e lbl) (walk e (cons lbl parts))) v (seq-labels v))) + (else #t))) + (walk state '()) + (reverse acc))) + +;; The full sops document: inline markers plus the store's `(data …)' block. +(define (full-doc state) + (fold (lambda (kv acc) (doc-add acc (key->string (car kv)) (cdr kv))) + (marker-doc state) + (or (clause-multi registered-store 'data) '()))) + +;; The store envelope with its `data' clause set to DOC — the sops document to +;; (de/en)crypt. +(define (store-with-data doc) + (append (filter (lambda (c) (not (eq? (car c) 'data))) registered-store) + (list (cons 'data doc)))) ;; ---------- decryption (lazy, memoized) ---------- ;; @@ -218,40 +319,43 @@ decryption. Resets any cached plaintext." (or (assoc-ref parsed "data") (begin (secrets-warn "decrypted store has no `data' map") #f))))))))))) -(define (force-store-decrypt!) - (when (eq? decrypt-memo 'unset) - (set! decrypt-memo (decrypt-yaml (store->sops-yaml)))) - decrypt-memo) - -(define (secret-value key) - "Resolve the secret named KEY (a symbol) to its plaintext string, or a -placeholder when the store can't be decrypted." - (unless registered-store - (error "secrets: (secret-ref) used but no (secrets-store …) was declared")) - (let ((plain (force-store-decrypt!))) - (if (not plain) - (format #f "" key) - (let ((entry (assoc (key->string key) plain))) - (if entry - (cdr entry) - (error "secrets: no such key in store:" key)))))) +;; Decrypt the gathered DOC ((keystr . cipher) …) under the store envelope, +;; returning a (keystr . plaintext) alist, or #f when sops can't decrypt. +(define (decrypt-doc doc) + (cond + ((null? doc) '()) + ((not registered-store) + (error "secrets: secrets referenced but no (secrets-store …) envelope declared")) + (else (decrypt-yaml (clauses->sops-yaml (store-with-data doc)))))) ;; ---------- the resolution op ---------- -(define (replace-refs x) - "Deep-copy X, replacing every marker with its plaintext. -Recurs through both alists and plain lists via car/cdr." - (cond - ((secret-ref? x) (secret-value (secret-ref-key x))) - ((pair? x) (cons (replace-refs (car x)) (replace-refs (cdr x)))) - (else x))) +;; Rebuild STATE replacing each marker with its plaintext, keyed exactly as +;; `marker-doc' gathered it (same walk → same key). PLAIN is the decrypted map, +;; or #f → every secret renders a placeholder (sops absent / key missing). +(define (substitute-refs state plain) + (define (lookup k) + (if (not plain) + (format #f "" k) + (let ((e (assoc k plain))) (if e (cdr e) (error "secrets: no such secret:" k))))) + (define (walk v parts) + (cond + ((secret-ref? v) (lookup (marker-key v parts))) + ((alist-like? v) (map (lambda (e) (cons (car e) (walk (cdr e) (cons (car e) parts)))) v)) + ((seq-like? v) (map (lambda (e lbl) (walk e (cons lbl parts))) v (seq-labels v))) + (else v))) + (walk state '())) (define (resolve-secret-refs) - "Return an op that walks the resolved state and replaces every -`(secret-ref 'key)' marker with the secret's plaintext. Decrypts the store -once (memoized) the first time a marker is found, so it must run after the -resources that reference secrets — place it last in the inventory. Because -it only runs during `resolve', `tree'/`ops' never invoke sops." + "Return an op that walks the resolved state, gathers every marker's +ciphertext (keyed by id or path), decrypts the store once, and substitutes the +plaintext. Place it last in the inventory — it must run after the resources +that reference secrets. A no-op when `secret-resolution-disabled' is set (so +the secret tooling can read the marker layout), and sops-free for `tree'/`ops' +since it only fires during `resolve'." (make-op 'resolve-secret-refs '(resolve-secret-refs) - (lambda (state) (replace-refs state)) + (lambda (state) + (if (secret-resolution-disabled) + state + (substitute-refs state (decrypt-doc (full-doc state))))) "resolve-secret-refs")) From 4c3962d7e50929f7d49edd33fca35fc37bc57430 Mon Sep 17 00:00:00 2001 From: Polyedre Date: Tue, 23 Jun 2026 13:57:12 +0200 Subject: [PATCH 08/15] cache: share kernel's FNV-1a/64 instead of re-rolling it cache.scm carried a byte-for-byte copy of kernel's FNV-1a/64 hash and its u64 constants (its own comment noted it 'mirrors (hexol kernel)'s addresser'). Export fnv1a-64 from the kernel and import it; cache keeps only the 3-line hex16 wrapper. --- hexol/cache.scm | 22 ++++------------------ hexol/kernel.scm | 2 +- 2 files changed, 5 insertions(+), 19 deletions(-) diff --git a/hexol/cache.scm b/hexol/cache.scm index a4d8cb4..198b1e0 100644 --- a/hexol/cache.scm +++ b/hexol/cache.scm @@ -23,30 +23,16 @@ ;;; results. (define-module (hexol cache) + #:use-module (hexol kernel) ; fnv1a-64 — the op addresser's hash #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (ice-9 textual-ports) - #:use-module (rnrs bytevectors) #:export (current-render-cache open-render-cache render-cache? cached-json)) -;; ---------- key hashing (FNV-1a/64, mirrors (hexol kernel)'s addresser) ---------- -;; A cache key only needs to avoid accidental collisions, not resist attack — -;; same rationale as the op content hash, kept dependency-free so this module -;; stands alone. - -(define %fnv-offset 14695981039346656037) -(define %fnv-prime 1099511628211) -(define %u64-mask (- (expt 2 64) 1)) - -(define (fnv1a-64 str) - (let ((bytes (string->utf8 str))) - (let loop ((i 0) (h %fnv-offset)) - (if (>= i (bytevector-length bytes)) - h - (loop (+ i 1) - (logand %u64-mask - (* %fnv-prime (logxor h (bytevector-u8-ref bytes i))))))))) +;; ---------- key hashing ---------- +;; A cache key only needs to avoid accidental collisions, not resist attack, so +;; it shares the kernel's FNV-1a/64 op addresser (no crypto/deps). (define (hex16 str) (let ((s (number->string (fnv1a-64 str) 16))) diff --git a/hexol/kernel.scm b/hexol/kernel.scm index 4cff899..e32c3e8 100644 --- a/hexol/kernel.scm +++ b/hexol/kernel.scm @@ -15,7 +15,7 @@ #:export (;; ops make-op op? op-kind op-source op-effect op-label op-children op-loc current-author-loc stamp-loc relabel - op-content-hash op-short-hash + op-content-hash op-short-hash fnv1a-64 apply-op resolve compose-ops scope-ops for-each-into op:merge op:set op:append op:when op:case op:copy op:move op:delete From 6f7e23158747ddacb878d5ca85a3277b330bd456 Mon Sep 17 00:00:00 2001 From: Polyedre Date: Tue, 23 Jun 2026 13:58:57 +0200 Subject: [PATCH 09/15] kernel: drop deep-merge-with per-path strategy engine (unused) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit deep-merge-with and its merge-by-key helper (replace / append / replace-by-key strategies) had no caller outside their own test — every real merge goes through plain deep-merge. Collapse deep-merge to the self-contained no-strategy recursion and delete the strategy machinery, its exports, and its test block. --- hexol.scm | 2 +- hexol/kernel.scm | 74 +++++++++--------------------------------------- test.scm | 22 -------------- 3 files changed, 14 insertions(+), 84 deletions(-) diff --git a/hexol.scm b/hexol.scm index dac7fae..e4face1 100644 --- a/hexol.scm +++ b/hexol.scm @@ -12,7 +12,7 @@ make-op op? op-kind op-source op-effect op-label op-children apply-op resolve compose-ops for-each-into op:merge op:set op:append op:when op:case - state-get state-set state-append deep-merge deep-merge-with + state-get state-set state-append deep-merge current-trace resolve-with-trace path-get load-inventory-file current-timings resolve-with-timings renders-with diff --git a/hexol/kernel.scm b/hexol/kernel.scm index e32c3e8..dc025a7 100644 --- a/hexol/kernel.scm +++ b/hexol/kernel.scm @@ -20,7 +20,7 @@ op:merge op:set op:append op:when op:case op:copy op:move op:delete ;; state helpers - state-get state-set state-append state-delete deep-merge deep-merge-with + state-get state-set state-append state-delete deep-merge path->string ;; tracing (explain support) current-trace resolve-with-trace path-get @@ -290,66 +290,18 @@ unchanged. Deleting the empty path is a no-op (the root has no key)." (define (deep-merge target incoming) "Recursively merge INCOMING into TARGET. Scalars and non-alist lists in INCOMING win outright; two alists are merged key-by-key, recursing on -shared keys. This is `deep-merge-with' with no per-path strategy -overrides, so the two share one algorithm." - (deep-merge-walk target incoming '() '())) - -;; ---------- deep-merge-with: per-path strategy overrides ---------- -;; -;; deep-merge plus an alist of (path . strategy) overrides, matched against the -;; current path at each step; matched -> strategy decides, else default merge. -;; -;; Strategies: -;; replace — incoming wins outright (skip recursion) -;; append — list-concat target and incoming -;; (replace-by-key K) — lists of alists; for each incoming entry, replace the -;; target entry whose K field matches, else append. -;; -;; Unmatched paths behave like deep-merge, so this is a strict superset. - -(define (deep-merge-with target incoming strategies) - "Like `deep-merge', but STRATEGIES is an alist of (path . strategy) -overrides consulted at each step. A strategy may be `replace' (incoming -wins), `append' (list-concat), or (replace-by-key K) (replace list-of-alist -entries matching field K). Unmatched paths behave exactly like -`deep-merge', making this a strict superset." - (deep-merge-walk target incoming strategies '())) - -(define (deep-merge-walk target incoming strategies path) - (let ((strat (assoc-ref strategies path))) - (cond - ((eq? strat 'replace) incoming) - ((eq? strat 'append) - (append (if (list? target) target '()) - (if (list? incoming) incoming (list incoming)))) - ((and (pair? strat) (eq? (car strat) 'replace-by-key)) - (merge-by-key target incoming (cadr strat))) - ;; default: deep-merge, recursing with the strategy table. - ((not (alist? incoming)) incoming) - ((not (alist? target)) incoming) - (else - (fold (lambda (entry acc) - (let* ((k (car entry)) - (v (cdr entry)) - (existing (state-get acc (list k)))) - (state-set acc (list k) - (deep-merge-walk existing v strategies - (append path (list k)))))) - target - incoming))))) - -(define (merge-by-key target incoming key) - ;; lists of alists; each incoming entry replaces the target entry with a - ;; matching `key` value, or is appended. - (fold (lambda (new acc) - (let ((k-val (assq-ref new key))) - (if (any (lambda (rec) (equal? (assq-ref rec key) k-val)) acc) - (map (lambda (rec) - (if (equal? (assq-ref rec key) k-val) new rec)) - acc) - (append acc (list new))))) - (if (list? target) target '()) - (if (list? incoming) incoming '()))) +shared keys." + (cond + ((not (alist? incoming)) incoming) + ((not (alist? target)) incoming) + (else + (fold (lambda (entry acc) + (let* ((k (car entry)) + (v (cdr entry)) + (existing (state-get acc (list k)))) + (state-set acc (list k) (deep-merge existing v)))) + target + incoming)))) ;; ---------- op constructors ---------- diff --git a/test.scm b/test.scm index 0d6662c..2a1bd4b 100644 --- a/test.scm +++ b/test.scm @@ -38,28 +38,6 @@ (deep-merge '((nginx (workers . 4) (user . "nginx"))) '((nginx (workers . 8))))) -(format #t "~%kernel: deep-merge-with (per-path strategies)~%") -(check "dmw: default = same as deep-merge" - (deep-merge '((a (b . 1) (c . 2))) '((a (b . 9)))) - (deep-merge-with '((a (b . 1) (c . 2))) '((a (b . 9))) '())) -(check "dmw: replace at path drops siblings" - '((a . ((b . 9)))) - (deep-merge-with '((a (b . 1) (c . 2))) - '((a (b . 9))) - '(((a) . replace)))) -(check "dmw: append concatenates at path" - '((xs . (1 2 3 4))) - (deep-merge-with '((xs 1 2)) '((xs 3 4)) - '(((xs) . append)))) -(check "dmw: replace-by-key swaps matching record" - '((items . (((id . 1) (v . "a")) - ((id . 2) (v . "new")) - ((id . 3) (v . "c"))))) - (deep-merge-with - '((items ((id . 1) (v . "a")) ((id . 2) (v . "b")) ((id . 3) (v . "c")))) - '((items ((id . 2) (v . "new")))) - '(((items) . (replace-by-key id))))) - (format #t "~%kernel: ops + resolve (raw constructors)~%") (define baseline (op:merge '((nginx (workers . 4))) 'baseline)) From 3f99b74d227c4dce6b4b0bce1f06bd3b2972877e Mon Sep 17 00:00:00 2001 From: Polyedre Date: Tue, 23 Jun 2026 14:00:54 +0200 Subject: [PATCH 10/15] kernel/surface: drop copy/move/delete ops (unused surface) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit op:copy / op:move / op:delete and their hx-copy / hx-move / hx-delete surface macros had no caller in any example, library, or inventory — only their own tests. Remove the ops, the %copy/%move/%delete macros, the exports, and the tests. state-delete stays as a state primitive (symmetric with state-set/state-append). --- hexol/kernel.scm | 28 ---------------------------- hexol/surface.scm | 26 -------------------------- test.scm | 41 ----------------------------------------- 3 files changed, 95 deletions(-) diff --git a/hexol/kernel.scm b/hexol/kernel.scm index dc025a7..5c3566e 100644 --- a/hexol/kernel.scm +++ b/hexol/kernel.scm @@ -18,7 +18,6 @@ op-content-hash op-short-hash fnv1a-64 apply-op resolve compose-ops scope-ops for-each-into op:merge op:set op:append op:when op:case - op:copy op:move op:delete ;; state helpers state-get state-set state-append state-delete deep-merge path->string @@ -330,33 +329,6 @@ SOURCE is the authored form recorded for debugging." (lambda (state) (state-append state path value)) (string-append "append " (path->string path)))) -(define (op:copy src dst source) - "Return an op that copies the value at path SRC to path DST. A missing -SRC (resolving to #f) leaves the state unchanged. SRC and DST are lists of -symbol keys; SOURCE is the authored form." - (make-op 'copy source - (lambda (state) - (let ((v (state-get state src))) - (if v (state-set state dst v) state))) - (string-append "copy " (path->string src) " -> " (path->string dst)))) - -(define (op:move src dst source) - "Return an op that moves the value at path SRC to path DST (set DST, then -delete SRC). A missing SRC leaves the state unchanged. SRC and DST should -be disjoint paths; SOURCE is the authored form." - (make-op 'move source - (lambda (state) - (let ((v (state-get state src))) - (if v (state-delete (state-set state dst v) src) state))) - (string-append "move " (path->string src) " -> " (path->string dst)))) - -(define (op:delete path source) - "Return an op that removes the entry at PATH (a list of symbol keys) from -the state, leaving a missing PATH unchanged. SOURCE is the authored form." - (make-op 'delete source - (lambda (state) (state-delete state path)) - (string-append "delete " (path->string path)))) - (define (op:when pred body source) "Return an op that folds BODY (a list of ops) into the state only when PRED, a (state -> bool) procedure, holds. SOURCE is the authored form; diff --git a/hexol/surface.scm b/hexol/surface.scm index 8bb530f..a4ba28c 100644 --- a/hexol/surface.scm +++ b/hexol/surface.scm @@ -36,7 +36,6 @@ op? op-kind op-source op-effect apply-op compose-ops for-each-into renders-with applies-with) #:export (hx-ops hx-each hx-merge hx-when hx-case hx-append - hx-copy hx-move hx-delete $ attr get attrs str fmt resource transform-resources annotate-all label-all block body @@ -273,28 +272,6 @@ metadata.labels." ((_ k ($ expr)) (op:append-dyn '(k) (lambda (state) expr) '(append k ($ expr)))) ((_ k val) (op:append '(k) 'val '(append k val))))) -;; %copy/%move move a value between paths; %delete removes one. Each path slot -;; is a bare symbol (`nginx`) or a segment list (`(nginx workers)`), auto-quoted -;; like %append's path. -(define-syntax %copy - (syntax-rules () - ((_ (s ...) (d ...)) (op:copy '(s ...) '(d ...) '(copy (s ...) (d ...)))) - ((_ (s ...) d) (op:copy '(s ...) '(d) '(copy (s ...) d))) - ((_ s (d ...)) (op:copy '(s) '(d ...) '(copy s (d ...)))) - ((_ s d) (op:copy '(s) '(d) '(copy s d))))) - -(define-syntax %move - (syntax-rules () - ((_ (s ...) (d ...)) (op:move '(s ...) '(d ...) '(move (s ...) (d ...)))) - ((_ (s ...) d) (op:move '(s ...) '(d) '(move (s ...) d))) - ((_ s (d ...)) (op:move '(s) '(d ...) '(move s (d ...)))) - ((_ s d) (op:move '(s) '(d) '(move s d))))) - -(define-syntax %delete - (syntax-rules () - ((_ (k ...)) (op:delete '(k ...) '(delete (k ...)))) - ((_ k) (op:delete '(k) '(delete k))))) - ;; %case: (case expr arm ...), each arm ((v ...) body ...) or (else body ...). ;; Dispatch expr runs with current-state bound, so `attr`/`get` work. Only the ;; first matching arm's ops fold; arm bodies flatten one level like hx-ops. @@ -321,9 +298,6 @@ metadata.labels." (define-syntax hx-when (syntax-rules () ((_ . a) (%when . a)))) (define-syntax hx-case (syntax-rules () ((_ . a) (%case . a)))) (define-syntax hx-append (syntax-rules () ((_ . a) (%append . a)))) -(define-syntax hx-copy (syntax-rules () ((_ . a) (%copy . a)))) -(define-syntax hx-move (syntax-rules () ((_ . a) (%move . a)))) -(define-syntax hx-delete (syntax-rules () ((_ . a) (%delete . a)))) (define-syntax attrs (syntax-rules () ((_ . a) (%attrs . a)))) ;; (hx-ops form ...) -> a flat list of ops. Each slot is an op or a list of ops, diff --git a/test.scm b/test.scm index 2a1bd4b..7428c32 100644 --- a/test.scm +++ b/test.scm @@ -64,32 +64,6 @@ (check "state-delete missing path (no-op)" '((a (b . 1))) (state-delete '((a (b . 1))) '(a z))) -(define src-state '((db (host . "h") (port . 5432)) (app (name . "x")))) - -;; op:copy duplicates the value, leaving the source in place -(check "op:copy: dst set, src kept" - '((attributes) (db (host . "h") (port . 5432)) (app (name . "x") (db_host . "h"))) - (resolve (list (op:merge src-state 'm) - (op:copy '(db host) '(app db_host) '(copy))) '())) -;; op:copy of a missing source is a no-op (no dst key created) -(check "op:copy missing src (no-op)" #f - (state-get (resolve (list (op:merge src-state 'm) - (op:copy '(db nope) '(app nope) '(copy))) '()) - '(app nope))) - -;; op:move sets dst and removes src -(define r-move (resolve (list (op:merge src-state 'm) - (op:move '(db port) '(app db_port) '(move))) '())) -(check "op:move: dst set" 5432 (state-get r-move '(app db_port))) -(check "op:move: src removed" #f (state-get r-move '(db port))) -(check "op:move: sibling kept" "h" (state-get r-move '(db host))) - -;; op:delete removes a path -(define r-del (resolve (list (op:merge src-state 'm) - (op:delete '(db port) '(delete))) '())) -(check "op:delete removes" #f (state-get r-del '(db port))) -(check "op:delete keeps sibling" "h" (state-get r-del '(db host))) - (format #t "~%surface: macros~%") (define inv-1 @@ -112,21 +86,6 @@ (define r-app (resolve inv-2 '())) (check "surface: hx-append $ fold-time" '(2) (state-get r-app '(items))) -;; hx-copy / hx-move / hx-delete: each path accepts a bare symbol or a -;; segment list, auto-quoted like hx-append. -(define inv-cmd - (hx-ops - (hx-merge (db (host "h") (port 5432) (legacy "x")) (app (name "demo"))) - (hx-copy (db host) (app db_host)) ; segment-list paths - (hx-move (db port) (app db_port)) - (hx-delete (db legacy)))) -(define r-cmd (resolve inv-cmd '())) -(check "surface: hx-copy keeps source" "h" (state-get r-cmd '(db host))) -(check "surface: hx-copy writes dest" "h" (state-get r-cmd '(app db_host))) -(check "surface: hx-move writes dest" 5432 (state-get r-cmd '(app db_port))) -(check "surface: hx-move removes source" #f (state-get r-cmd '(db port))) -(check "surface: hx-delete removes" #f (state-get r-cmd '(db legacy))) - ;; hx-ops / hx-when flatten body slots one level, so a helper procedure that ;; returns a *list* of ops drops straight in (the sub-inventory pattern). (define (extra-ops) (list (hx-merge (a 1)) (hx-merge (b 2)))) From 400eb0b065c024752b3b93f5c9820c3fdd69e702 Mon Sep 17 00:00:00 2001 From: Polyedre Date: Tue, 23 Jun 2026 14:05:59 +0200 Subject: [PATCH 11/15] k8s: inline single-caller % helpers into their constructs MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Every typed constructor paired a %name define* (full #:key list) with a define-construct re-declaring the same fields, whose #:build only forwarded them — each field written three times. For the 15 helpers called by nothing but their own construct, fold the body straight into #:build and delete the helper. The 7 helpers shared by composites (%deployment, %ingress, %custom-resource, %namespace, %service-account, %cluster-role, %cluster-role-binding) stay: they're the runtime-keyword implementation the macro surface can't forward into (a #:map field can't splice a runtime alist). No output change — golden renders and the test suite are byte-identical. --- hexol/k8s.scm | 272 +++++++++++++++++--------------------------------- 1 file changed, 93 insertions(+), 179 deletions(-) diff --git a/hexol/k8s.scm b/hexol/k8s.scm index 00b9998..17ee0f5 100644 --- a/hexol/k8s.scm +++ b/hexol/k8s.scm @@ -275,18 +275,6 @@ alist. Each side is \"req\" or \"req-lim\"; `*' or empty omits a bound." #:resources resources #:privileged privileged #:args args #:command command #:service-account service-account #:labels labels)) -(define* (%daemonset #:key name image (port 0) (namespace (current-k8s-namespace)) - (env '()) (env-from '()) (volumes '()) (resources '()) (privileged #f) - (args '()) (command '()) (service-account #f) - (host-network #f) (host-pid #f) (labels '()) - (capabilities '()) (host-port #f) (protocol #f)) - (resource (workload-alist #:kind "DaemonSet" #:name name #:image image #:port port - #:replicas #f #:namespace namespace #:env env #:env-from env-from - #:volumes volumes #:resources resources #:privileged privileged - #:args args #:command command #:service-account service-account - #:host-network host-network #:host-pid host-pid #:labels labels - #:capabilities capabilities #:host-port host-port #:protocol protocol))) - (define-construct daemonset #:head name #:fields ((image #:required) (port #:default 0) @@ -296,31 +284,26 @@ alist. Each side is \"req\" or \"req-lim\"; `*' or empty omits a bound." (args #:list) (command #:list) (service-account #:default #f) (host-network #:flag) (host-pid #:flag) (labels #:map) (capabilities #:list) (host-port #:default #f) (protocol #:default #f)) - #:build (%daemonset #:name name #:image image #:port port #:namespace namespace - #:env env #:env-from env-from #:volumes volumes #:resources resources - #:privileged privileged #:args args #:command command - #:service-account service-account #:host-network host-network - #:host-pid host-pid #:labels labels #:capabilities capabilities - #:host-port host-port #:protocol protocol)) - -(define* (%service #:key name port (target-port port) (port-name "http") - (namespace (current-k8s-namespace)) (type #f) (selector-name #f) (labels '())) - (let ((sel (or selector-name name))) - (resource - `((apiVersion . "v1") - (kind . "Service") - (metadata ,@(k8s-metadata name namespace labels)) - (spec (selector (app . ,sel)) - ,@(if type `((type . ,type)) '()) - (ports ((name . ,port-name) (port . ,port) (targetPort . ,target-port)))))))) + #:build (resource (workload-alist #:kind "DaemonSet" #:name name #:image image #:port port + #:replicas #f #:namespace namespace #:env env #:env-from env-from + #:volumes volumes #:resources resources #:privileged privileged + #:args args #:command command #:service-account service-account + #:host-network host-network #:host-pid host-pid #:labels labels + #:capabilities capabilities #:host-port host-port #:protocol protocol))) (define-construct service #:head name #:fields ((port #:required) (target-port #:default port) (port-name #:default "http") (namespace #:default (current-k8s-namespace)) (type #:default #f) (selector-name #:default #f) (labels #:map)) - #:build (%service #:name name #:port port #:target-port target-port #:port-name port-name - #:namespace namespace #:type type #:selector-name selector-name #:labels labels)) + #:build (let ((sel (or selector-name name))) + (resource + `((apiVersion . "v1") + (kind . "Service") + (metadata ,@(k8s-metadata name namespace labels)) + (spec (selector (app . ,sel)) + ,@(if type `((type . ,type)) '()) + (ports ((name . ,port-name) (port . ,port) (targetPort . ,target-port)))))))) (define* (%ingress #:key name port (host #f) (namespace (current-k8s-namespace)) (path "/") (labels '())) (let ((h (or host (string-append name ".example.com")))) @@ -341,82 +324,60 @@ alist. Each side is \"req\" or \"req-lim\"; `*' or empty omits a bound." #:build (%ingress #:name name #:port port #:host host #:namespace namespace #:path path #:labels labels)) -(define* (%configmap #:key name data (namespace (current-k8s-namespace)) (labels '())) - (resource - `((apiVersion . "v1") - (kind . "ConfigMap") - (metadata ,@(k8s-metadata name namespace labels)) - (data ,@data)))) - (define-construct configmap #:head name #:fields ((data #:map) (namespace #:default (current-k8s-namespace)) (labels #:map)) - #:build (%configmap #:name name #:data data #:namespace namespace #:labels labels)) - -(define* (%secret #:key name (data '()) (string-data '()) - (namespace (current-k8s-namespace)) (type "Opaque") (labels '())) - (resource - `((apiVersion . "v1") - (kind . "Secret") - (metadata ,@(k8s-metadata name namespace labels)) - (type . ,type) - ,@(if (null? data) '() `((data ,@data))) - ,@(if (null? string-data) '() `((stringData ,@string-data)))))) + #:build (resource + `((apiVersion . "v1") + (kind . "ConfigMap") + (metadata ,@(k8s-metadata name namespace labels)) + (data ,@data)))) (define-construct secret #:head name #:fields ((data #:map) (string-data #:map) (namespace #:default (current-k8s-namespace)) (type #:default "Opaque") (labels #:map)) - #:build (%secret #:name name #:data data #:string-data string-data - #:namespace namespace #:type type #:labels labels)) + #:build (resource + `((apiVersion . "v1") + (kind . "Secret") + (metadata ,@(k8s-metadata name namespace labels)) + (type . ,type) + ,@(if (null? data) '() `((data ,@data))) + ,@(if (null? string-data) '() `((stringData ,@string-data)))))) ;; --------------------------------------------------------------------------- ;; storage ;; --------------------------------------------------------------------------- -(define* (%storage-class #:key name provisioner (default #f) (volume-binding-mode #f) - (reclaim-policy #f) (allow-volume-expansion #f) - (parameters '()) (labels '())) - (resource - `((apiVersion . "storage.k8s.io/v1") - (kind . "StorageClass") - (metadata ,@(k8s-metadata name #f labels) ; cluster-scoped: no namespace - ,@(if default - '((annotations (storageclass.kubernetes.io/is-default-class . "true"))) - '())) - (provisioner . ,provisioner) - ,@(if volume-binding-mode `((volumeBindingMode . ,volume-binding-mode)) '()) - ,@(if allow-volume-expansion '((allowVolumeExpansion . #t)) '()) - ,@(if reclaim-policy `((reclaimPolicy . ,reclaim-policy)) '()) - ,@(if (null? parameters) '() `((parameters ,@parameters)))))) - (define-construct storage-class #:head name #:fields ((provisioner #:required) (default #:flag) (volume-binding-mode #:default #f) (reclaim-policy #:default #f) (allow-volume-expansion #:flag) (parameters #:map) (labels #:map)) - #:build (%storage-class #:name name #:provisioner provisioner #:default default - #:volume-binding-mode volume-binding-mode #:reclaim-policy reclaim-policy - #:allow-volume-expansion allow-volume-expansion - #:parameters parameters #:labels labels)) - -(define* (%persistent-volume-claim #:key name size (namespace (current-k8s-namespace)) - (access-mode "ReadWriteOnce") (storage-class #f) (labels '())) - (resource - `((apiVersion . "v1") - (kind . "PersistentVolumeClaim") - (metadata ,@(k8s-metadata name namespace labels)) - (spec (accessModes ,access-mode) - ,@(if storage-class `((storageClassName . ,storage-class)) '()) - (resources (requests (storage . ,size))))))) + #:build (resource + `((apiVersion . "storage.k8s.io/v1") + (kind . "StorageClass") + (metadata ,@(k8s-metadata name #f labels) ; cluster-scoped: no namespace + ,@(if default + '((annotations (storageclass.kubernetes.io/is-default-class . "true"))) + '())) + (provisioner . ,provisioner) + ,@(if volume-binding-mode `((volumeBindingMode . ,volume-binding-mode)) '()) + ,@(if allow-volume-expansion '((allowVolumeExpansion . #t)) '()) + ,@(if reclaim-policy `((reclaimPolicy . ,reclaim-policy)) '()) + ,@(if (null? parameters) '() `((parameters ,@parameters)))))) (define-construct persistent-volume-claim #:head name #:fields ((size #:required) (namespace #:default (current-k8s-namespace)) (access-mode #:default "ReadWriteOnce") (storage-class #:default #f) (labels #:map)) - #:build (%persistent-volume-claim #:name name #:size size #:namespace namespace - #:access-mode access-mode #:storage-class storage-class - #:labels labels)) + #:build (resource + `((apiVersion . "v1") + (kind . "PersistentVolumeClaim") + (metadata ,@(k8s-metadata name namespace labels)) + (spec (accessModes ,access-mode) + ,@(if storage-class `((storageClassName . ,storage-class)) '()) + (resources (requests (storage . ,size))))))) (define* (%custom-resource #:key api kind name (namespace (current-k8s-namespace)) (spec '()) (labels '())) (resource @@ -433,36 +394,28 @@ alist. Each side is \"req\" or \"req-lim\"; `*' or empty omits a bound." #:build (%custom-resource #:api api #:kind kind #:name name #:namespace namespace #:spec spec #:labels labels)) -(define* (%service-monitor #:key name (port "http") (path "/metrics") - (interval "30s") (namespace (current-k8s-namespace)) (labels '())) - (%custom-resource - #:api "monitoring.coreos.com/v1" #:kind "ServiceMonitor" - #:name name #:namespace namespace #:labels labels - #:spec `((selector (matchLabels (app . ,name))) - (endpoints ((port . ,port) (path . ,path) (interval . ,interval)))))) - (define-construct service-monitor #:head name #:fields ((port #:default "http") (path #:default "/metrics") (interval #:default "30s") (namespace #:default (current-k8s-namespace)) (labels #:map)) - #:build (%service-monitor #:name name #:port port #:path path #:interval interval - #:namespace namespace #:labels labels)) + #:build (%custom-resource + #:api "monitoring.coreos.com/v1" #:kind "ServiceMonitor" + #:name name #:namespace namespace #:labels labels + #:spec `((selector (matchLabels (app . ,name))) + (endpoints ((port . ,port) (path . ,path) (interval . ,interval)))))) ;; --------------------------------------------------------------------------- ;; Gateway API ;; --------------------------------------------------------------------------- -(define* (%gateway-class #:key name controller-name (labels '())) - (resource - `((apiVersion . "gateway.networking.k8s.io/v1") - (kind . "GatewayClass") - (metadata ,@(k8s-metadata name #f labels)) ; cluster-scoped: no namespace - (spec (controllerName . ,controller-name))))) - (define-construct gateway-class #:head name #:fields ((controller-name #:required) (labels #:map)) - #:build (%gateway-class #:name name #:controller-name controller-name #:labels labels)) + #:build (resource + `((apiVersion . "gateway.networking.k8s.io/v1") + (kind . "GatewayClass") + (metadata ,@(k8s-metadata name #f labels)) ; cluster-scoped: no namespace + (spec (controllerName . ,controller-name))))) ;; A Gateway listener (sub-construct). #:tls-certificate names one or more ;; Secrets → a Terminate-mode tls block; absent → a plain listener. @@ -483,28 +436,13 @@ alist. Each side is \"req\" or \"req-lim\"; `*' or empty omits a bound." ,@(map (lambda (s) `((kind . "Secret") (name . ,s))) tls-certificate)))))))) -(define* (%gateway #:key name gateway-class-name (namespace (current-k8s-namespace)) - (listeners '()) (labels '())) - (%custom-resource #:api "gateway.networking.k8s.io/v1" #:kind "Gateway" - #:name name #:namespace namespace #:labels labels - #:spec `((gatewayClassName . ,gateway-class-name) (listeners ,@listeners)))) - (define-construct gateway #:head name #:fields ((gateway-class-name #:required) (namespace #:default (current-k8s-namespace)) (listener #:repeated #:construct listener) (labels #:map)) - #:build (%gateway #:name name #:gateway-class-name gateway-class-name - #:namespace namespace #:listeners listener #:labels labels)) - -(define* (%http-route #:key name (namespace (current-k8s-namespace)) parent-name - (parent-namespace #f) (hostnames '()) backend-service backend-port - (labels '())) - (%custom-resource #:api "gateway.networking.k8s.io/v1" #:kind "HTTPRoute" - #:name name #:namespace namespace #:labels labels - #:spec `((parentRefs ((name . ,parent-name) - ,@(if parent-namespace `((namespace . ,parent-namespace)) '()))) - (hostnames ,@hostnames) - (rules ((backendRefs ((name . ,backend-service) (port . ,backend-port)))))))) + #:build (%custom-resource #:api "gateway.networking.k8s.io/v1" #:kind "Gateway" + #:name name #:namespace namespace #:labels labels + #:spec `((gatewayClassName . ,gateway-class-name) (listeners ,@listener)))) (define-construct http-route #:head name @@ -512,10 +450,12 @@ alist. Each side is \"req\" or \"req-lim\"; `*' or empty omits a bound." (parent-name #:required) (parent-namespace #:default #f) (hostnames #:list) (backend-service #:required) (backend-port #:required) (labels #:map)) - #:build (%http-route #:name name #:namespace namespace #:parent-name parent-name - #:parent-namespace parent-namespace #:hostnames hostnames - #:backend-service backend-service #:backend-port backend-port - #:labels labels)) + #:build (%custom-resource #:api "gateway.networking.k8s.io/v1" #:kind "HTTPRoute" + #:name name #:namespace namespace #:labels labels + #:spec `((parentRefs ((name . ,parent-name) + ,@(if parent-namespace `((namespace . ,parent-namespace)) '()))) + (hostnames ,@hostnames) + (rules ((backendRefs ((name . ,backend-service) (port . ,backend-port)))))))) ;; --------------------------------------------------------------------------- ;; RBAC @@ -547,34 +487,26 @@ alist. Each side is \"req\" or \"req-lim\"; `*' or empty omits a bound." #:fields ((namespace #:default (current-k8s-namespace)) (labels #:map)) #:build (%service-account #:name name #:namespace namespace #:labels labels)) -(define* (%role #:key name (namespace (current-k8s-namespace)) (rules '()) (labels '())) - (resource - `((apiVersion . "rbac.authorization.k8s.io/v1") - (kind . "Role") - (metadata ,@(k8s-metadata name namespace labels)) - (rules ,@rules)))) - (define-construct role #:head name #:fields ((rule #:repeated #:construct rule) (namespace #:default (current-k8s-namespace)) (labels #:map)) - #:build (%role #:name name #:namespace namespace #:rules rule #:labels labels)) - -(define* (%role-binding #:key name (namespace (current-k8s-namespace)) role - service-account (sa-namespace namespace) (labels '())) - (resource - `((apiVersion . "rbac.authorization.k8s.io/v1") - (kind . "RoleBinding") - (metadata ,@(k8s-metadata name namespace labels)) - (roleRef (apiGroup . "rbac.authorization.k8s.io") (kind . "Role") (name . ,role)) - (subjects ((kind . "ServiceAccount") (name . ,service-account) (namespace . ,sa-namespace)))))) + #:build (resource + `((apiVersion . "rbac.authorization.k8s.io/v1") + (kind . "Role") + (metadata ,@(k8s-metadata name namespace labels)) + (rules ,@rule)))) (define-construct role-binding #:head name #:fields ((namespace #:default (current-k8s-namespace)) (role #:required) (service-account #:required) (sa-namespace #:default namespace) (labels #:map)) - #:build (%role-binding #:name name #:namespace namespace #:role role - #:service-account service-account #:sa-namespace sa-namespace #:labels labels)) + #:build (resource + `((apiVersion . "rbac.authorization.k8s.io/v1") + (kind . "RoleBinding") + (metadata ,@(k8s-metadata name namespace labels)) + (roleRef (apiGroup . "rbac.authorization.k8s.io") (kind . "Role") (name . ,role)) + (subjects ((kind . "ServiceAccount") (name . ,service-account) (namespace . ,sa-namespace)))))) (define* (%cluster-role #:key name (rules '()) (labels '())) (resource @@ -604,18 +536,15 @@ alist. Each side is \"req\" or \"req-lim\"; `*' or empty omits a bound." #:build (%cluster-role-binding #:name name #:role role #:service-account service-account #:sa-namespace sa-namespace #:labels labels)) -(define* (%cluster-rbac #:key name (rules '()) (namespace (current-k8s-namespace)) (labels '())) - (compose-ops 'cluster-rbac (list 'cluster-rbac name) - (list (%service-account #:name name #:namespace namespace #:labels labels) - (%cluster-role #:name name #:rules rules #:labels labels) - (%cluster-role-binding #:name name #:role name #:service-account name - #:sa-namespace namespace #:labels labels)))) - (define-construct cluster-rbac #:head name #:fields ((rule #:repeated #:construct rule) (namespace #:default (current-k8s-namespace)) (labels #:map)) - #:build (%cluster-rbac #:name name #:rules rule #:namespace namespace #:labels labels)) + #:build (compose-ops 'cluster-rbac (list 'cluster-rbac name) + (list (%service-account #:name name #:namespace namespace #:labels labels) + (%cluster-role #:name name #:rules rule #:labels labels) + (%cluster-role-binding #:name name #:role name #:service-account name + #:sa-namespace namespace #:labels labels)))) ;; --------------------------------------------------------------------------- ;; external manifests — splice resources produced at render time @@ -683,36 +612,18 @@ JSON with yq, and appends every manifest it yields to (kubernetes_resources)." ;; composites ;; --------------------------------------------------------------------------- -(define* (%app #:key name image (port 8080) (replicas 2) (namespace (current-k8s-namespace)) - (env '()) (env-from '()) (volumes '()) (resources '()) (privileged #f) - (service-account #f)) - (compose-ops 'app `(app ,name) - (list (expose - (%deployment #:name name #:image image #:port port #:replicas replicas - #:namespace namespace #:env env #:env-from env-from #:volumes volumes - #:resources resources #:privileged privileged - #:service-account service-account))))) - (define-construct app #:head name #:fields ((image #:required) (port #:default 8080) (replicas #:default 2) (namespace #:default (current-k8s-namespace)) (env #:list) (env-from #:list) (volumes #:list) (resources #:default '()) (privileged #:flag) (service-account #:default #f)) - #:build (%app #:name name #:image image #:port port #:replicas replicas #:namespace namespace - #:env env #:env-from env-from #:volumes volumes #:resources resources - #:privileged privileged #:service-account service-account)) - -(define* (%public-app #:key name image (port 8080) (replicas 2) (namespace (current-k8s-namespace)) - (env '()) (env-from '()) (volumes '()) (resources '()) (privileged #f) - (service-account #f) (host #f)) - (compose-ops 'public-app `(public-app ,name) - (list (expose - (%deployment #:name name #:image image #:port port #:replicas replicas - #:namespace namespace #:env env #:env-from env-from #:volumes volumes - #:resources resources #:privileged privileged - #:service-account service-account)) - (%ingress #:name name #:port port #:namespace namespace #:host host)))) + #:build (compose-ops 'app `(app ,name) + (list (expose + (%deployment #:name name #:image image #:port port #:replicas replicas + #:namespace namespace #:env env #:env-from env-from #:volumes volumes + #:resources resources #:privileged privileged + #:service-account service-account))))) (define-construct public-app #:head name @@ -721,10 +632,13 @@ JSON with yq, and appends every manifest it yields to (kubernetes_resources)." (env #:list) (env-from #:list) (volumes #:list) (resources #:default '()) (privileged #:flag) (service-account #:default #f) (host #:default #f)) - #:build (%public-app #:name name #:image image #:port port #:replicas replicas - #:namespace namespace #:env env #:env-from env-from #:volumes volumes - #:resources resources #:privileged privileged - #:service-account service-account #:host host)) + #:build (compose-ops 'public-app `(public-app ,name) + (list (expose + (%deployment #:name name #:image image #:port port #:replicas replicas + #:namespace namespace #:env env #:env-from env-from #:volumes volumes + #:resources resources #:privileged privileged + #:service-account service-account)) + (%ingress #:name name #:port port #:namespace namespace #:host host)))) ;; --------------------------------------------------------------------------- ;; expose — derive a Service from a workload. From c21b43fa62c5779c49b4a03758b1a778070365a3 Mon Sep 17 00:00:00 2001 From: Polyedre Date: Tue, 23 Jun 2026 14:08:15 +0200 Subject: [PATCH 12/15] hexol: reuse yaml's object-shape? in state-diff state-diff carried map-alist?, a near-copy of (hexol yaml) object-shape? differing only by the distinct-key check. Resolved state never has duplicate keys (state-set/deep-merge always replace), so the two agree on every input state-diff sees; drop map-alist? and call object-shape? (already imported, already used by sequence-of-maps?). show/explain output byte-identical. --- bin/hexol | 13 ++++--------- 1 file changed, 4 insertions(+), 9 deletions(-) diff --git a/bin/hexol b/bin/hexol index bce92d6..99a3e4a 100755 --- a/bin/hexol +++ b/bin/hexol @@ -639,19 +639,14 @@ (exit 2)) (else matches)))) -;; Is X a map-shaped alist (every entry a (symbol . _) pair)? Decides whether -;; to recurse into a state node or treat it as a changed leaf. -(define (map-alist? x) - (and (pair? x) (list? x) - (every (lambda (e) (and (pair? e) (symbol? (car e)))) x))) - ;; Leaf-level diff of two state nodes: (path before after) for every path whose -;; value differs. Recurses through map-shaped alists; anything else (scalars, -;; vectors, plain lists) is compared whole. +;; value differs. Recurses through map-shaped alists (via yaml's `object-shape?', +;; sound because resolved state never carries duplicate keys); anything else +;; (scalars, vectors, plain lists) is compared whole. (define (state-diff a b path) (cond ((equal? a b) '()) - ((and (map-alist? a) (map-alist? b)) + ((and (object-shape? a) (object-shape? b)) (let ((keys (delete-duplicates (append (map car a) (map car b)) eq?))) (append-map (lambda (k) (state-diff (assq-ref a k) (assq-ref b k) From b8ac59fe31152eb2512759f9a9595c7961d0402e Mon Sep 17 00:00:00 2001 From: Polyedre Date: Tue, 23 Jun 2026 14:09:34 +0200 Subject: [PATCH 13/15] hexol: drop the show source-blob syntax highlighter show's source s-expression was run through a hand-rolled, string-aware Scheme tinter (token-end + tint-atom + highlight-sexp, ~75 lines) purely to color a debug view. pretty-print already lays the form out; print it indented and uncolored. Tree labels, the hash gutter, and the red/green state delta keep their color. Non-TTY output (and the golden renders) unchanged. --- bin/hexol | 81 +++---------------------------------------------------- 1 file changed, 4 insertions(+), 77 deletions(-) diff --git a/bin/hexol b/bin/hexol index 99a3e4a..3a33ef0 100755 --- a/bin/hexol +++ b/bin/hexol @@ -682,84 +682,11 @@ ;; --------------------------------------------------------------------------- ;; source blob — `show` prints the op's raw source s-expression. pretty-print -;; lays it out; this adds light syntax tinting and a 2-space indent so the blob -;; sits under the `;; source:` header and scans like the other views. +;; lays it out; we add a 2-space indent so the blob sits under the `;; source:` +;; header. ;; --------------------------------------------------------------------------- -;; Where a bare token ends: next whitespace, paren/bracket, string quote, or -;; comment. Lifts one atom out of the pretty-printed text at a time. -(define (token-end s i n) - (let loop ((j i)) - (if (>= j n) - j - (let ((c (string-ref s j))) - (if (or (char-whitespace? c) - (memv c '(#\( #\) #\[ #\] #\" #\;))) - j - (loop (+ j 1))))))) - -;; Tint one atom. A symbol heading a list (operator slot) reads as a keyword; -;; numbers, #-literals, and :keywords each get their own hue; everything else -;; stays default. -(define (tint-atom tok head?) - (cond - (head? (o-cyan tok)) - ((string->number tok) (o-yellow tok)) - ((string-prefix? "#" tok) (o-magenta tok)) - ((string-prefix? ":" tok) (o-magenta tok)) - (else tok))) - -;; Colorize pretty-printed Scheme. A flat char scan, string-aware so we never -;; paint inside a "literal" (where parens/semicolons aren't syntax). The token -;; right after an opening paren is the list head; the rest are arguments. -(define (highlight-sexp s) - (if (not stdout-color?) - s - (let ((out (open-output-string)) - (n (string-length s))) - (let loop ((i 0) (head? #f)) - (if (>= i n) - (get-output-string out) - (let ((c (string-ref s i))) - (cond - ;; string literal — consume through the closing quote, - ;; honoring backslash escapes - ((char=? c #\") - (let scan ((j (+ i 1))) - (cond - ((>= j n) - (display (o-green (substring s i j)) out) - (loop j #f)) - ((char=? (string-ref s j) #\\) (scan (+ j 2))) - ((char=? (string-ref s j) #\") - (display (o-green (substring s i (+ j 1))) out) - (loop (+ j 1) #f)) - (else (scan (+ j 1)))))) - ;; comment to end of line - ((char=? c #\;) - (let ((eol (or (string-index s #\newline i) n))) - (display (o-dim (substring s i eol)) out) - (loop eol #f))) - ;; opening bracket — next atom is the list head - ((or (char=? c #\() (char=? c #\[)) - (write-char c out) (loop (+ i 1) #t)) - ((or (char=? c #\)) (char=? c #\])) - (write-char c out) (loop (+ i 1) #f)) - ;; whitespace carries head? across (so `(\n foo` still tints - ;; foo as the head) - ((char-whitespace? c) - (write-char c out) (loop (+ i 1) head?)) - ;; reader prefixes ' ` , don't consume the head slot - ((memv c '(#\' #\` #\,)) - (write-char c out) (loop (+ i 1) head?)) - ;; a bare atom - (else - (let* ((j (token-end s i n)) - (tok (substring s i j))) - (display (tint-atom tok head?) out) - (loop j #f)))))))))) - -;; Pretty-print DATUM, indent every line two spaces, then tint. +;; Pretty-print DATUM, indent every line two spaces. (define (print-source-blob datum) (let* ((raw (call-with-output-string (lambda (p) @@ -771,7 +698,7 @@ (string-join (string-split (string-trim-right raw #\newline) #\newline) "\n ")))) - (display (highlight-sexp indented)) + (display indented) (newline))) ;; Render one side of a state-delta entry as `;;` comment lines. A one-line From d2d5abba923efe797476ba28c0698e7ff462bd90 Mon Sep 17 00:00:00 2001 From: Polyedre Date: Tue, 23 Jun 2026 14:11:04 +0200 Subject: [PATCH 14/15] json: move the JSON adapter from (cmdb json) to (hexol json) The CLI's JSON renderer lived in the CMDB namespace, forcing bin/hexol to depend on cmdb just for sexp->json-string. Move it to (hexol json), reusing (hexol yaml) object-shape? instead of a third local copy, and repoint bin/hexol, cmdb/server, and the build target. Render output identical. --- Makefile | 2 +- bin/hexol | 2 +- cmdb/server.scm | 2 +- {cmdb => hexol}/json.scm | 15 +++------------ 4 files changed, 6 insertions(+), 15 deletions(-) rename {cmdb => hexol}/json.scm (78%) diff --git a/Makefile b/Makefile index e4027e6..07f74ad 100644 --- a/Makefile +++ b/Makefile @@ -26,7 +26,7 @@ test-examples: GUILE=$(GUILE) ./test/examples.sh build: - @$(GUILE) -L . -c '(begin (use-modules (hexol) (hexol k8s) (hexol terraform) (hexol apply) (hexol ansible) (hexol ledger) (hexol sql) (cmdb json)) (display "build ok\n"))' + @$(GUILE) -L . -c '(begin (use-modules (hexol) (hexol k8s) (hexol terraform) (hexol apply) (hexol ansible) (hexol ledger) (hexol sql) (hexol json)) (display "build ok\n"))' clean: rm -rf ~/.cache/guile/ccache/*$(CURDIR)* diff --git a/bin/hexol b/bin/hexol index 3a33ef0..50454f5 100755 --- a/bin/hexol +++ b/bin/hexol @@ -51,7 +51,7 @@ (hexol yaml) (hexol terraform) (hexol secret-tool) - (cmdb json) + (hexol json) (srfi srfi-1) (srfi srfi-9) (ice-9 match) diff --git a/cmdb/server.scm b/cmdb/server.scm index 5a81dce..9a26da6 100644 --- a/cmdb/server.scm +++ b/cmdb/server.scm @@ -13,7 +13,7 @@ (define-module (cmdb server) #:use-module (cmdb store) - #:use-module (cmdb json) + #:use-module (hexol json) #:use-module (web server) #:use-module (web request) #:use-module (web response) diff --git a/cmdb/json.scm b/hexol/json.scm similarity index 78% rename from cmdb/json.scm rename to hexol/json.scm index 7564a60..e614c00 100644 --- a/cmdb/json.scm +++ b/hexol/json.scm @@ -1,4 +1,4 @@ -;;; cmdb/json.scm — JSON adapter for CMDB state shapes. +;;; hexol/json.scm — JSON adapter for hexol state shapes. ;;; ;;; Delegates to guile-json: it renders lists as JSON objects (alists) ;;; and vectors as arrays. Our state holds arrays as plain lists (e.g. @@ -7,21 +7,12 @@ ;;; ;;; `()` renders as `{}` (empty alist); for an empty array pass `#()`. -(define-module (cmdb json) +(define-module (hexol json) #:use-module (json) + #:use-module ((hexol yaml) #:select (object-shape?)) #:use-module (srfi srfi-1) #:export (sexp->json-string state->json-ready)) -(define (object-shape? obj) - ;; Non-empty list of (symbol . X) with distinct keys. Unique-keys check - ;; disambiguates from arrays of symbol-headed elements (e.g. a fact list - ;; `((merge ...) (merge ...))` is an array, not an object). - (and (pair? obj) - (list? obj) - (every (lambda (e) (and (pair? e) (symbol? (car e)))) obj) - (let ((keys (map car obj))) - (= (length keys) (length (delete-duplicates keys eq?)))))) - (define (state->json-ready obj) (cond ((null? obj) '()) ; -> {} From d097e7d37a3d7a403e52b96dc54d17efd55c2c15 Mon Sep 17 00:00:00 2001 From: Polyedre Date: Tue, 23 Jun 2026 14:14:14 +0200 Subject: [PATCH 15/15] cmdb: delete the CMDB subsystem MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The event-sourced CMDB (HTTP fact-log server, versioned-library replay, waved rollout tooling) was a second product beside the inventory engine that the hexol CLI never invoked — its only tie, the JSON adapter, moved to (hexol json) in the previous commit. Remove cmdb/, bin/cmdb-server, bin/sync-inventory, bin/promote, docs/cmdb.md, the two cmdb tests, the cmdb-only examples/regions.scm, and the Makefile test lines; scrub the README/model.md references. (This also subsumes the v1/v2 library duplication finding.) docs/authoring.md still lists the cmdb layout but is mid-edit in the working tree, so its scrub is left to that change. --- Makefile | 4 +- README.md | 2 - bin/cmdb-server | 45 -------- bin/promote | 159 ---------------------------- bin/sync-inventory | 90 ---------------- cmdb/apps.scm | 233 ----------------------------------------- cmdb/libraries/v1.scm | 21 ---- cmdb/libraries/v2.scm | 28 ----- cmdb/region-body.scm | 172 ------------------------------ cmdb/region-render.scm | 12 --- cmdb/server.scm | 143 ------------------------- cmdb/store.scm | 141 ------------------------- docs/cmdb.md | 125 ---------------------- docs/model.md | 3 +- examples/inventory.scm | 2 +- examples/regions.scm | 22 ---- hexol/ansible.scm | 6 +- manifest.scm | 2 +- test/cmdb-server.scm | 204 ------------------------------------ test/cmdb-store.scm | 167 ----------------------------- 20 files changed, 7 insertions(+), 1574 deletions(-) delete mode 100755 bin/cmdb-server delete mode 100755 bin/promote delete mode 100755 bin/sync-inventory delete mode 100644 cmdb/apps.scm delete mode 100644 cmdb/libraries/v1.scm delete mode 100644 cmdb/libraries/v2.scm delete mode 100644 cmdb/region-body.scm delete mode 100644 cmdb/region-render.scm delete mode 100644 cmdb/server.scm delete mode 100644 cmdb/store.scm delete mode 100644 docs/cmdb.md delete mode 100644 examples/regions.scm delete mode 100644 test/cmdb-server.scm delete mode 100644 test/cmdb-store.scm diff --git a/Makefile b/Makefile index 07f74ad..7bbe88c 100644 --- a/Makefile +++ b/Makefile @@ -4,7 +4,7 @@ GUILE ?= guile help: @echo "targets:" - @echo " make test run the smoke tests (kernel, surface, res, cmdb)" + @echo " make test run the smoke tests (kernel, surface, res, k8s)" @echo " make test-examples render the standalone examples, check they exit 0" @echo " make build compile all modules (surfaces any load/compile error)" @echo " make clean remove this project's Guile compile cache" @@ -19,8 +19,6 @@ test: $(GUILE) -L . test.scm $(GUILE) -L . test/construct.scm $(GUILE) -L . test/k8s-res.scm - $(GUILE) -L . test/cmdb-store.scm - $(GUILE) -L . test/cmdb-server.scm test-examples: GUILE=$(GUILE) ./test/examples.sh diff --git a/README.md b/README.md index 64671a8..c8e901e 100644 --- a/README.md +++ b/README.md @@ -154,8 +154,6 @@ live homelab. Kick the tires before you bet a cluster on it. - [`docs/extending.md`](docs/extending.md) — building target libraries, the kernel/library/example boundary, worked Terraform and Helm conversions, and introspection. -- [`docs/cmdb.md`](docs/cmdb.md) — the event-sourced CMDB built on the same - kernel (fact log + versioned libraries + HTTP server). ## License diff --git a/bin/cmdb-server b/bin/cmdb-server deleted file mode 100755 index 9834799..0000000 --- a/bin/cmdb-server +++ /dev/null @@ -1,45 +0,0 @@ -#!/usr/bin/env -S guile -L . -e main -s -!# -;;; bin/cmdb-server — boot the CMDB HTTP server. -;;; -;;; Usage: -;;; ./bin/cmdb-server [initial-library=] [log=] [port=] -;;; -;;; Defaults: -;;; initial-library = v1 (resolves to cmdb/libraries/v1.scm) -;;; log = cmdb.log -;;; port = 8080 -;;; -;;; initial-library only matters for an empty log: `(bump-lib "")` -;;; facts switch libraries at their points on replay, and initial-library -;;; covers facts before the first bump-lib. - -(add-to-load-path (dirname (dirname (current-filename)))) - -(use-modules (cmdb store) - (cmdb server) - (ice-9 format)) - -(define (parse-arg arg) - (let ((idx (string-index arg #\=))) - (unless idx (error "expected key=value, got:" arg)) - (cons (substring arg 0 idx) (substring arg (+ idx 1))))) - -(define (main args) - (let loop ((args (cdr args)) - (lib "v1") - (log "cmdb.log") - (port 8080)) - (cond - ((null? args) - (let ((c (make-cmdb log #:initial-library lib))) - (format #t "cmdb: initial-library=~s log=~s~%" lib log) - (start-server c #:port port))) - (else - (let* ((p (parse-arg (car args))) - (k (car p)) (v (cdr p))) - (cond - ((string=? k "initial-library") (loop (cdr args) v log port)) - ((string=? k "log") (loop (cdr args) lib v port)) - ((string=? k "port") (loop (cdr args) lib log (string->number v))) - (else (error "unknown arg:" k)))))))) diff --git a/bin/promote b/bin/promote deleted file mode 100755 index 85ea688..0000000 --- a/bin/promote +++ /dev/null @@ -1,159 +0,0 @@ -#!/usr/bin/env -S guile -L . -e main -s -!# -;;; bin/promote — progressive image-tag rollout via the CMDB HTTP API. -;;; -;;; Usage: -;;; ./bin/promote app= tag= waves= \ -;;; [url=http://127.0.0.1:8080] [gate=] -;;; -;;; A wave is comma-separated region symbols, e.g. -;;; waves=alpha5:golf1,bravo1:charlie6,hotel3 -;;; -;;; Per wave: POST a promote fact per region, read back to verify, then -;;; run (if given) — non-zero exit aborts. -;;; -;;; Exit: 0 ok, 1 gate failed, 2 transport/HTTP error. - -(add-to-load-path (dirname (dirname (current-filename)))) - -(use-modules ((web client) #:renamer (lambda (s) - (case s - ((http-post) 'web:http-post) - ((http-get) 'web:http-get) - (else s)))) - (web response) - (rnrs bytevectors) - (ice-9 format) - (ice-9 textual-ports) - (ice-9 popen) - (srfi srfi-1)) - -(define (parse-arg arg) - (let ((idx (string-index arg #\=))) - (unless idx (error "expected key=value, got:" arg)) - (cons (substring arg 0 idx) (substring arg (+ idx 1))))) - -(define (decode-body body) - (cond ((not body) "") - ((bytevector? body) (utf8->string body)) - ((string? body) body) - (else (format #f "~s" body)))) - -(define (post-sexp url sexp) - (call-with-values - (lambda () - (web:http-post url - #:body (string->utf8 - (call-with-output-string - (lambda (p) (write sexp p)))) - #:headers '((content-type . (application/scheme))))) - (lambda (response body) - (values (response-code response) (decode-body body))))) - -(define (get-url url) - (call-with-values - (lambda () (web:http-get url)) - (lambda (response body) - (values (response-code response) (decode-body body))))) - -(define (post-fact url sexp) - (call-with-values (lambda () (post-sexp url sexp)) - (lambda (code body) - (unless (= code 200) - (format (current-error-port) "POST failed (~a): ~a~%" code body) - (exit 2)) - body))) - -(define (get-path url-base path-str) - (call-with-values (lambda () (get-url (string-append url-base "/state/" path-str))) - (lambda (code body) - (cond ((= code 200) (call-with-input-string body read)) - ((= code 404) #f) - (else - (format (current-error-port) "GET failed (~a): ~a~%" code body) - (exit 2)))))) - -(define (parse-waves s) - (map (lambda (w) - (map string->symbol (string-split w #\,))) - (string-split s #\:))) - -(define (run-gate gate-cmd wave-idx) - (when gate-cmd - (format #t " gate: running ~s~%" gate-cmd) - (let ((status (system gate-cmd))) - (unless (zero? status) - (format (current-error-port) - " gate FAILED for wave ~a (status ~a) — aborting~%" - wave-idx status) - (exit 1))) - (format #t " gate: ok~%"))) - -;; A promotion is a `(promote )` fact; is -;; region-rooted (e.g. (apps ingress-nginx chart version)). -(define (kind->path-tail kind) - (cond ((string=? kind "image") '(image tag)) - ((string=? kind "chart") '(chart version)) - (else (error "unknown kind (want image|chart):" kind)))) - -(define (verify-path-string region app kind) - (let ((tail (kind->path-tail kind))) - (string-join - (cons "regions" - (cons (symbol->string region) - (cons "apps" - (cons app (map symbol->string tail))))) - "."))) - -(define (promote-wave url kind app tag wave-idx regions) - (format #t "wave ~a: regions ~a~%" wave-idx regions) - (let ((tail (kind->path-tail kind))) - (for-each - (lambda (region) - (let* ((path (cons 'apps (cons (string->symbol app) tail))) - (fact `(promote ,region ,path ,tag))) - (format #t " -> ~s~%" fact) - (post-fact (string-append url "/facts") fact) - (let ((observed (get-path url (verify-path-string region app kind)))) - (unless (equal? observed tag) - (format (current-error-port) - " verify FAILED for ~a: expected ~s, got ~s~%" - region tag observed) - (exit 2)) - (format #t " verified ~a@~a~%" region observed)))) - regions))) - -(define (main args) - (let loop ((args (cdr args)) - (url "http://127.0.0.1:8080") - (kind "image") - (app #f) (tag #f) (waves #f) (gate #f)) - (cond - ((null? args) - (unless (and app tag waves) - (format (current-error-port) - "missing required: app=, tag=, waves=~%") - (exit 2)) - (let ((parsed-waves (parse-waves waves))) - (format #t "promote: kind=~a app=~a tag=~a url=~a~%" kind app tag url) - (format #t "waves: ~a~%~%" parsed-waves) - (let inner ((ws parsed-waves) (i 1)) - (cond - ((null? ws) - (format #t "~%done.~%")) - (else - (promote-wave url kind app tag i (car ws)) - (when (and gate (not (null? (cdr ws)))) - (run-gate gate i)) - (inner (cdr ws) (+ i 1))))))) - (else - (let* ((p (parse-arg (car args))) - (k (car p)) (v (cdr p))) - (cond - ((string=? k "url") (loop (cdr args) v kind app tag waves gate)) - ((string=? k "kind") (loop (cdr args) url v app tag waves gate)) - ((string=? k "app") (loop (cdr args) url kind v tag waves gate)) - ((string=? k "tag") (loop (cdr args) url kind app v waves gate)) - ((string=? k "waves") (loop (cdr args) url kind app tag v gate)) - ((string=? k "gate") (loop (cdr args) url kind app tag waves v)) - (else (error "unknown arg:" k)))))))) diff --git a/bin/sync-inventory b/bin/sync-inventory deleted file mode 100755 index 59cbbac..0000000 --- a/bin/sync-inventory +++ /dev/null @@ -1,90 +0,0 @@ -#!/usr/bin/env -S guile -L . -e main -s -!# -;;; bin/sync-inventory — push the region table to the CMDB as facts. -;;; -;;; Usage: -;;; ./bin/sync-inventory [regions=examples/regions.scm] \ -;;; [url=http://127.0.0.1:8080] -;;; -;;; Posts one `(region )` fact per table entry; the CMDB -;;; expands each into the full subtree via region-render.scm (body shared -;;; with examples/inventory.scm). Facts stay small (~100 bytes). -;;; -;;; The regions file must define-module `(examples regions)` and export -;;; `regions`. - -(add-to-load-path (dirname (dirname (current-filename)))) - -(use-modules ((web client) #:renamer (lambda (s) - (if (eq? s 'http-post) 'web:http-post s))) - (web response) - (rnrs bytevectors) - (ice-9 format)) - -(define (parse-arg arg) - (let ((idx (string-index arg #\=))) - (unless idx (error "expected key=value, got:" arg)) - (cons (substring arg 0 idx) (substring arg (+ idx 1))))) - -(define (decode-body body) - (cond ((not body) "") - ((bytevector? body) (utf8->string body)) - (else body))) - -(define (post-fact url sexp) - (call-with-values - (lambda () - (web:http-post url - #:body (string->utf8 - (call-with-output-string - (lambda (p) (write sexp p)))) - #:headers '((content-type . (application/scheme))))) - (lambda (response body) - (let ((code (response-code response))) - (unless (= code 200) - (format (current-error-port) - "POST failed (~a): ~a~%" code (decode-body body)) - (exit 2)))))) - -(define (load-regions-table regions-path) - ;; primitive-load + module-ref so arbitrary module names like - ;; (examples regions-prod) work, not just (examples regions). - (let* ((port (open-input-file regions-path)) - (head (read port))) - (close-port port) - (unless (and (pair? head) (eq? (car head) 'define-module)) - (error "regions file must start with (define-module ...)" regions-path)) - (let ((mod-name (cadr head))) - (primitive-load regions-path) - (module-ref (resolve-module mod-name) 'regions)))) - -(define (run regions-path url) - (format #t "sync: loading region table from ~a~%" regions-path) - (let* ((regions (load-regions-table regions-path)) - (count (length regions)) - (endpoint (string-append url "/facts"))) - (format #t "sync: ~a regions to push -> ~a~%" count endpoint) - (let loop ((rs regions) (n 0)) - (if (null? rs) - (format #t "sync: pushed ~a regions~%" n) - (let* ((entry (car rs)) - (name (car entry)) - (attrs (cdr entry)) - (fact `(region ,name ,attrs))) - (post-fact endpoint fact) - (when (zero? (modulo (+ n 1) 10)) - (format #t " pushed ~a/~a~%" (+ n 1) count)) - (loop (cdr rs) (+ n 1))))))) - -(define (main args) - (let loop ((args (cdr args)) - (regs "examples/regions.scm") - (url "http://127.0.0.1:8080")) - (if (null? args) - (run regs url) - (let* ((p (parse-arg (car args))) - (k (car p)) (v (cdr p))) - (cond - ((string=? k "regions") (loop (cdr args) v url)) - ((string=? k "url") (loop (cdr args) regs v)) - (else (error "unknown arg:" k))))))) diff --git a/cmdb/apps.scm b/cmdb/apps.scm deleted file mode 100644 index a0de4db..0000000 --- a/cmdb/apps.scm +++ /dev/null @@ -1,233 +0,0 @@ -;;; cmdb/apps.scm — Helm releases per region (loaded by cmdb/region-body). -;;; -;;; Per-app shape: -;;; (apps ( (chart (url ) (version ) (values )))) -;;; -;;; Conditional stacks (gpu, sovereign-audit, backup) gated inline. - -(hx-ops - - ;; ---------- Base: ingress, cert-manager, external-dns (all regions) ---------- - (hx-merge - (apps - (ingress-nginx - (chart - (url "https://kubernetes.github.io/ingress-nginx") - (version "4.11.2") - (values - (controller - (replicaCount ($ (if (eq? (attr 'tier) 'prod) 3 1))) - (ingressClassResource (default #t)) - (service (type LoadBalancer)) - (config (use-proxy-protocol "true") - (enable-real-ip "true")) - (metrics (enabled #t)))))) - - (cert-manager - (chart - (url "https://charts.jetstack.io") - (version "v1.15.3") - (values - (installCRDs #t) - (replicaCount ($ (if (eq? (attr 'tier) 'prod) 2 1))) - (extraArgs ("--dns01-recursive-nameservers-only")) - (prometheus (enabled #t))))) - - (external-dns - (chart - (url "https://kubernetes-sigs.github.io/external-dns") - (version "1.15.0") - (values - (provider openstack) - (txtOwnerId ($ (symbol->string (attr 'region)))) - (domainFilters ($ (list (string-append (symbol->string (attr 'region)) "." - (symbol->string (attr 'dc)) ".example.com")))) - (policy sync)))))) - (hx-append packages ingress-nginx) - (hx-append packages cert-manager) - (hx-append packages external-dns) - - ;; ---------- Monitoring (all regions) ---------- - (hx-merge - (apps - (kube-prometheus-stack - (chart - (url "https://prometheus-community.github.io/helm-charts") - (version "62.6.0") - (values - (grafana - (enabled #t) - (adminPassword ($ (string-append "admin-" (symbol->string (attr 'region))))) - (ingress (enabled #t) - (hosts ($ (list (string-append "grafana." - (symbol->string (attr 'region)) - ".example.com")))))) - (prometheus - (prometheusSpec - (retention ($ (if (eq? (attr 'tier) 'prod) "30d" "7d"))) - (replicas ($ (if (eq? (attr 'tier) 'prod) 2 1))) - (storageSpec (volumeClaimTemplate - (spec (storageClassName "fast") - (resources (requests (storage "200Gi")))))))) - (alertmanager - (alertmanagerSpec - (replicas ($ (if (eq? (attr 'tier) 'prod) 3 1)))))))) - - (loki - (chart - (url "https://grafana.github.io/helm-charts") - (version "6.16.0") - (values - (deploymentMode ($ (if (eq? (attr 'tier) 'prod) 'SimpleScalable 'SingleBinary))) - (loki - (auth_enabled #t) - (storage - (type s3) - (s3 (endpoint ($ (string-append "s3." (symbol->string (attr 'region)) ".example.com"))) - (bucketNames (chunks ($ (string-append "loki-chunks-" (symbol->string (attr 'region)))))))))))) - - (promtail - (chart - (url "https://grafana.github.io/helm-charts") - (version "6.16.0") - (values - (config - (clients ($ (list "http://loki.observability.svc:3100/loki/api/v1/push"))))))))) - (hx-append packages kube-prometheus-stack) - (hx-append packages loki) - (hx-append packages promtail) - - ;; ---------- OpenStack add-ons (all regions) ---------- - (hx-merge - (apps - (openstack-exporter - (chart - (url "https://openstack-exporter.github.io/helm-charts") - (version "0.6.0") - (values - (cloudName ($ (symbol->string (attr 'region)))) - (cloudsYaml - (clouds (default (auth (auth_url ($ (string-append "https://auth." - (symbol->string (attr 'region)) - ".example.com/v3"))) - (region_name ($ (symbol->string (attr 'region)))))))) - (serviceMonitor (enabled #t))))) - - (keystone-federation - (chart - (url "https://charts.openstack.local") - (version "2.4.1") - (values - (identityProvider - (region ($ (symbol->string (attr 'region)))) - (issuer ($ (string-append "https://sso." (symbol->string (attr 'geo)) ".example.com"))) - (entityId ($ (string-append "keystone-" (symbol->string (attr 'region))))))))) - - (rally - (chart - (url "https://charts.openstack.local") - (version "1.8.0") - (values - (schedule ($ (if (eq? (attr 'tier) 'prod) "0 */6 * * *" "0 4 * * *"))) - (targetRegion ($ (symbol->string (attr 'region)))) - (concurrency ($ (if (eq? (attr 'tier) 'prod) 8 2)))))))) - (hx-append packages openstack-exporter) - (hx-append packages keystone-federation) - (hx-append packages rally) - - ;; ---------- Backup (skip dev tier — no SLO) ---------- - (hx-when (lambda (s) (not (eq? (attr 'tier) 'dev))) - (hx-merge - (apps - (velero - (chart - (url "https://vmware-tanzu.github.io/helm-charts") - (version "7.2.1") - (values - (configuration - (backupStorageLocation - ((name default) - (provider aws) - (bucket ($ (string-append "velero-" (symbol->string (attr 'region))))) - (config (region ($ (symbol->string (attr 'region)))) - (s3Url ($ (string-append "https://s3." - (symbol->string (attr 'region)) - ".example.com")))))) - (volumeSnapshotLocation - ((name default) - (provider aws) - (config (region ($ (symbol->string (attr 'region)))))))) - (schedules - (daily - (schedule "0 1 * * *") - (template (ttl ($ (if (eq? (attr 'tier) 'prod) "720h" "168h"))))))))))) - (hx-append packages velero)) - - ;; ---------- GPU stack (hw-profile=gpu-dense only) ---------- - (hx-when (attrs (hw-profile gpu-dense)) - (hx-merge - (apps - (gpu-operator - (chart - (url "https://nvidia.github.io/gpu-operator") - (version "v24.6.1") - (values - (driver (enabled #t)) - (toolkit (enabled #t)) - (devicePlugin (enabled #t)) - (mig (strategy mixed)) - (nodeSelector (nvidia.com/gpu "present")) - (operator (defaultRuntime containerd))))) - (kserve - (chart - (url "https://kserve.github.io/helm-charts") - (version "0.13.1") - (values - (kserve - (controller (gateway (ingressGateway (className "kserve-ingress-gateway")))) - (modelmesh (config (defaultModelDomain - ($ (string-append "models." - (symbol->string (attr 'region)) - ".example.com"))))))))))) - (hx-append packages gpu-operator) - (hx-append packages kserve)) - - ;; ---------- Sovereign audit stack (sovereignty=strict only) ---------- - (hx-when (attrs (sovereignty strict)) - (hx-merge - (apps - (falco - (chart - (url "https://falcosecurity.github.io/charts") - (version "4.8.4") - (values - (driver (kind ebpf)) - (collectors (kubernetes (enabled #t))) - (falcosidekick - (enabled #t) - (config (webhook (address ($ (string-append "https://siem." - (symbol->string (attr 'geo)) - ".example.com/ingest")))))) - (tty 120)))) - (gatekeeper - (chart - (url "https://open-policy-agent.github.io/gatekeeper/charts") - (version "3.17.1") - (values - (replicas 3) - (auditInterval 60) - (constraintViolationsLimit 200)))) - (vault - (chart - (url "https://helm.releases.hashicorp.com") - (version "0.28.1") - (values - (server (ha (enabled #t) (replicas 5)) - (auditStorage (enabled #t)) - (dataStorage (size "100Gi") (storageClass "fast"))) - (injector (enabled #t))))))) - (hx-append packages falco) - (hx-append packages gatekeeper) - (hx-append packages vault) - (hx-append compliance-controls audit-all-syscalls) - (hx-append compliance-controls deny-by-default-netpol))) diff --git a/cmdb/libraries/v1.scm b/cmdb/libraries/v1.scm deleted file mode 100644 index 76a9d5c..0000000 --- a/cmdb/libraries/v1.scm +++ /dev/null @@ -1,21 +0,0 @@ -;;; cmdb/libraries/v1.scm — version 1 of the CMDB op library. -;;; -;;; Library versions are selected from facts via (bump-lib ""). For -;;; the POC is a short tag like "v1" -> module (cmdb libraries v1) -;;; at cmdb/libraries/v1.scm. - -(define-module (cmdb libraries v1) - #:use-module (hexol kernel) - #:use-module (cmdb region-render) - #:export (merge region promote)) - -(define (merge subtree) - (list (op:merge subtree '(merge)))) - -(define (region name attrs) - (let ((subtree (render-region attrs))) - (list (op:set (list 'regions name) subtree `(region ,name))))) - -(define (promote region path value) - (let ((full-path (cons 'regions (cons region path)))) - (list (op:set full-path value `(promote ,region ,path ,value))))) diff --git a/cmdb/libraries/v2.scm b/cmdb/libraries/v2.scm deleted file mode 100644 index 7d9b6c7..0000000 --- a/cmdb/libraries/v2.scm +++ /dev/null @@ -1,28 +0,0 @@ -;;; cmdb/libraries/v2.scm — version 2. -;;; -;;; Like v1, but `region` patches EU NTP pool from "europe.pool.ntp.org" -;;; (v1's shared region-body value) to "paris.pool.ntp.org". -;;; -;;; Demonstrates a library bump as an in-log event: facts before -;;; `(bump-lib "v2")` keep the v1 pool, facts after get v2. Replay is -;;; contemporaneous — each fact applies through the then-current library. - -(define-module (cmdb libraries v2) - #:use-module (hexol kernel) - #:use-module (cmdb region-render) - #:export (merge region promote)) - -(define (merge subtree) - (list (op:merge subtree '(merge)))) - -(define (region name attrs) - (let* ((subtree (render-region attrs)) - (subtree (if (eq? (assq-ref attrs 'geo) 'eu) - (deep-merge subtree - '((ntp (pool . "paris.pool.ntp.org")))) - subtree))) - (list (op:set (list 'regions name) subtree `(region ,name))))) - -(define (promote region path value) - (let ((full-path (cons 'regions (cons region path)))) - (list (op:set full-path value `(promote ,region ,path ,value))))) diff --git a/cmdb/region-body.scm b/cmdb/region-body.scm deleted file mode 100644 index 86f3549..0000000 --- a/cmdb/region-body.scm +++ /dev/null @@ -1,172 +0,0 @@ -;;; cmdb/region-body.scm — per-region rendering body for the CMDB. -;;; -;;; `region-body-ops` returns the ops that build one region's subtree -;;; from its attr alist; region-render.scm runs (resolve (region-body-ops) -;;; attrs) per `(region )` fact. Lives in the CMDB, not the -;;; examples — examples stay independent of this subsystem. - -(define-module (cmdb region-body) - #:use-module (hexol kernel) - #:use-module (hexol surface) - #:export (region-body-ops)) - -(define (region-body-ops) - (hx-ops - - ;; ---------- Per-region defaults ---------- - (hx-merge - (helm - (repos - (jetstack "https://charts.jetstack.io") - (ingress-nginx "https://kubernetes.github.io/ingress-nginx") - (prometheus "https://prometheus-community.github.io/helm-charts") - (grafana "https://grafana.github.io/helm-charts") - (nvidia "https://nvidia.github.io/gpu-operator") - (falco "https://falcosecurity.github.io/charts") - (hashicorp "https://helm.releases.hashicorp.com") - (vmware-tanzu "https://vmware-tanzu.github.io/helm-charts") - (openstack-exporter "https://openstack-exporter.github.io/helm-charts") - (kserve "https://kserve.github.io/helm-charts") - (gatekeeper "https://open-policy-agent.github.io/gatekeeper/charts"))) - (kubernetes - (version "1.33.0") - (control-plane (replicas 3) (etcd-backup-schedule "0 */4 * * *")) - (runtime containerd))) - - ;; ---------- Computed identifiers ---------- - (hx-merge - (cluster-name ($ (string-append "k8s-" (symbol->string (attr 'region))))) - (kubernetes - (api-endpoint ($ (string-append "https://api." - (symbol->string (attr 'region)) - ".example.com:6443")))) - (mirror ($ (string-append "rpm." (symbol->string (attr 'dc)) ".example.com"))) - (network - (region-domain ($ (string-append (symbol->string (attr 'region)) - "." (symbol->string (attr 'dc)) - ".example.com"))))) - - ;; ---------- Geo defaults ---------- - (hx-case (attr 'geo) - ((eu) (hx-merge (locale (timezone "Europe/Paris")) - (ntp (pool "europe.pool.ntp.org")) - (cdn (edge "edge-eu.example.com")))) - ((na) (hx-merge (locale (timezone "America/Toronto")) - (ntp (pool "north-america.pool.ntp.org")) - (cdn (edge "edge-na.example.com")))) - ((apac) (hx-merge (locale (timezone "Asia/Singapore")) - (ntp (pool "asia.pool.ntp.org")) - (cdn (edge "edge-apac.example.com")))) - ((latam) (hx-merge (locale (timezone "America/Sao_Paulo")) - (ntp (pool "south-america.pool.ntp.org")) - (cdn (edge "edge-latam.example.com")))) - ((me) (hx-merge (locale (timezone "Asia/Dubai")) - (ntp (pool "asia.pool.ntp.org")) - (cdn (edge "edge-me.example.com"))))) - - ;; ---------- Hardware profiles ---------- - (hx-case (attr 'hw-profile) - ((standard) - (hx-merge - (hardware - (cpu (sockets 2) (cores-per-socket 32) (smt #t)) - (memory (total-gb 256)) - (storage (kind nvme) (size-gb 1920) (raid 1)) - (nic (model "Mellanox CX-5") (speed-gbps 25) (count 2))) - (kubernetes - (node-pool (default (machine-type s4-32-256) (min-size 3) (max-size 50)))))) - - ((gpu-dense) - (hx-merge - (hardware - (cpu (sockets 2) (cores-per-socket 48) (smt #t)) - (memory (total-gb 1024)) - (storage (kind nvme) (size-gb 7680) (raid 0)) - (nic (model "Mellanox CX-7") (speed-gbps 200) (count 2)) - (gpu (model "NVIDIA H100") (count 8) (mig-enabled #t))) - (kubernetes - (node-pool - (default (machine-type s4-48-512) (min-size 3) (max-size 30)) - (gpu (machine-type g5-h100-8) (min-size 2) (max-size 16) - (taints ("nvidia.com/gpu=present:NoSchedule")))))) - (hx-append features gpu-acceleration)) - - ((storage-heavy) - (hx-merge - (hardware - (cpu (sockets 2) (cores-per-socket 24) (smt #t)) - (memory (total-gb 512)) - (storage (kind hdd-jbod) (size-gb 192000) (disks 24)) - (nic (model "Mellanox CX-6") (speed-gbps 100) (count 2))) - (kubernetes - (node-pool - (default (machine-type s4-24-512) (min-size 3) (max-size 20)) - (storage (machine-type x-storage-192t) (min-size 6) (max-size 60) - (taints ("workload=storage:NoSchedule")))))) - (hx-append features bulk-storage)) - - ((compute-optimized) - (hx-merge - (hardware - (cpu (sockets 2) (cores-per-socket 64) (smt #f) (turbo-pinned #t)) - (memory (total-gb 384)) - (storage (kind nvme) (size-gb 3840) (raid 1)) - (nic (model "Mellanox CX-6") (speed-gbps 100) (count 2))) - (kubernetes - (node-pool (default (machine-type c4-64-384) (min-size 3) (max-size 80))))))) - - ;; ---------- Network profiles ---------- - (hx-case (attr 'network-profile) - ((basic) - (hx-merge - (network - (cni flannel) - (pod-cidr "10.244.0.0/16") - (svc-cidr "10.96.0.0/12") - (mtu 1500) - (egress (mode shared-nat))))) - - ((advanced) - (hx-merge - (network - (cni cilium) - (pod-cidr "10.42.0.0/16") - (svc-cidr "10.96.0.0/12") - (mtu 9000) - (encryption wireguard) - (bgp (enabled #t) (asn 64512) (peers ("10.0.0.1" "10.0.0.2"))) - (egress (mode bgp-direct)) - (load-balancer (mode l2-announcement)))) - (hx-append features advanced-networking)) - - ((sovereign) - (hx-merge - (network - (cni cilium) - (pod-cidr "10.42.0.0/16") - (svc-cidr "10.96.0.0/12") - (mtu 9000) - (encryption mtls-mandatory) - (egress (mode allow-list) (peers ("internal-peer.sovereign.local"))) - (egress-default deny) - (audit-all-flows #t))) - (hx-append features sovereign-networking))) - - ;; ---------- Apps (only on Kubernetes > 1.32.4) ---------- - ;; load-inventory-file returns the fragment's ops; hx-when folds them - ;; when the predicate holds. - (hx-when (lambda (s) (semver> (get '(kubernetes version)) "1.32.4")) - (load-inventory-file "cmdb/apps.scm")) - - ;; ---------- Cross-cutting: sovereign regions label + annotate every - ;; k8s resource for compliance/audit, regardless of source. - (hx-when (attrs (sovereignty strict)) - (annotate-all '((audit.example.com/required . "true"))) - (label-all '((compliance . "strict")))) - - ;; ---------- Derived summaries ---------- - (hx-when (lambda (s) (pair? (get '(packages)))) - (hx-merge - (provisioning - (app-count ($ (length (get '(packages))))) - (feature-count ($ (length (or (get '(features)) '()))))))))) diff --git a/cmdb/region-render.scm b/cmdb/region-render.scm deleted file mode 100644 index b8ede9a..0000000 --- a/cmdb/region-render.scm +++ /dev/null @@ -1,12 +0,0 @@ -;;; cmdb/region-render.scm — render one region's subtree from attributes. -;;; -;;; Resolves region-body.scm against a fact's attr alist, landing a -;;; `(region )` fact's subtree under `(regions …)`. - -(define-module (cmdb region-render) - #:use-module (hexol kernel) - #:use-module (cmdb region-body) - #:export (render-region)) - -(define (render-region attrs) - (resolve (region-body-ops) attrs)) diff --git a/cmdb/server.scm b/cmdb/server.scm deleted file mode 100644 index 9a26da6..0000000 --- a/cmdb/server.scm +++ /dev/null @@ -1,143 +0,0 @@ -;;; cmdb/server.scm — HTTP front-end for the CMDB. -;;; -;;; Routes: -;;; GET /health -> "ok" -;;; GET /state -> entire materialized state as a sexp -;;; GET /state/ -> subtree or leaf at path; 404 if missing -;;; GET /facts -> sexp list of all facts -;;; POST /facts -> body is one fact sexp; appended + applied -;;; -;;; Bodies in/out are application/scheme (s-expressions); pass -;;; `Accept: application/json` or `?fmt=json` for JSON out. Server is -;;; single-threaded — the CMDB store isn't safe for concurrent writes. - -(define-module (cmdb server) - #:use-module (cmdb store) - #:use-module (hexol json) - #:use-module (web server) - #:use-module (web request) - #:use-module (web response) - #:use-module (web uri) - #:use-module (rnrs bytevectors) - #:use-module (ice-9 textual-ports) - #:use-module (ice-9 match) - #:use-module (srfi srfi-1) - #:export (make-handler - start-server - path-string->keys)) - -(define (sexp->bv obj) - (string->utf8 (call-with-output-string (lambda (p) (write obj p) (newline p))))) - -(define (json->bv obj) - (string->utf8 (string-append (sexp->json-string obj) "\n"))) - -(define (text-bv s) (string->utf8 s)) - -;; Output format from request: ?fmt=json or Accept: application/json -;; -> 'json, else 'sexp. ?fmt wins over Accept (curl-friendly). -(define (uri-query-pairs uri) - (let ((q (uri-query uri))) - (if (or (not q) (string=? q "")) - '() - (map (lambda (pair) - (let ((idx (string-index pair #\=))) - (if idx - (cons (substring pair 0 idx) (substring pair (+ idx 1))) - (cons pair "")))) - (string-split q #\&))))) - -(define (request-format request) - (let* ((uri (request-uri request)) - (params (uri-query-pairs uri)) - (fmt (assoc-ref params "fmt")) - (accept (request-headers request)) - (accept-hdr (assq-ref accept 'accept))) - (cond - ((and fmt (string=? fmt "json")) 'json) - ((and fmt (string=? fmt "sexp")) 'sexp) - ((and accept-hdr - (any (lambda (a) - ;; guile parses "application/json" to the symbol - ;; `application/json`; entry is a one-element list. - (and (pair? a) (eq? (car a) 'application/json))) - accept-hdr)) - 'json) - (else 'sexp)))) - -(define (read-sexp-body request body) - (let ((s (cond - ((not body) "") - ((bytevector? body) (utf8->string body)) - ((string? body) body) - (else (error "unexpected body type" body))))) - (call-with-input-string s read))) - -(define (response code content-type body-bv) - (values (build-response - #:code code - #:headers `((content-type . (,content-type)))) - body-bv)) - -(define (sexp-response code obj) - (response code 'application/scheme (sexp->bv obj))) - -(define (json-response code obj) - (response code 'application/json (json->bv obj))) - -(define (data-response request code obj) - (case (request-format request) - ((json) (json-response code obj)) - (else (sexp-response code obj)))) - -(define (text-response code s) - (response code 'text/plain (text-bv s))) - -(define (path-string->keys s) - ;; "regions.alpha5.apps.api.image.tag" -> '(regions alpha5 apps api image tag) - (if (string=? s "") - '() - (map string->symbol (string-split s #\.)))) - -(define (split-path uri-path) - ;; "/state/regions.alpha5" -> ("state" "regions.alpha5"); drop empties. - (filter (lambda (s) (not (string=? s ""))) - (string-split uri-path #\/))) - -(define (handle-get-state cmdb request keys) - (let ((v (cmdb-get cmdb keys))) - (cond - ((and (null? keys) (null? v)) - (data-response request 200 '())) - ((not v) - (text-response 404 (format #f "not found: ~a\n" keys))) - (else - (data-response request 200 v))))) - -(define (handle-post-fact cmdb request body) - (let ((fact (read-sexp-body request body))) - (cmdb-append-fact! cmdb fact) - (data-response request 200 `((ok . #t) (fact . ,fact))))) - -(define (handle-get-facts cmdb request) - (data-response request 200 (cmdb-facts cmdb))) - -(define (make-handler cmdb) - (lambda (request body) - (let* ((method (request-method request)) - (uri (request-uri request)) - (path (uri-path uri)) - (parts (split-path path))) - (match (cons method parts) - (('GET) (text-response 200 "cmdb\n")) - (('GET "health") (text-response 200 "ok\n")) - (('GET "state") (handle-get-state cmdb request '())) - (('GET "state" rest) (handle-get-state cmdb request (path-string->keys rest))) - (('GET "facts") (handle-get-facts cmdb request)) - (('POST "facts") (handle-post-fact cmdb request body)) - (_ (text-response 404 (format #f "no route: ~a ~a\n" method path))))))) - -(define* (start-server cmdb #:key (port 8080) (addr "127.0.0.1")) - (format #t "cmdb: listening on http://~a:~a/~%" addr port) - (run-server (make-handler cmdb) 'http - `(#:port ,port #:addr ,(inet-pton AF_INET addr)))) diff --git a/cmdb/store.scm b/cmdb/store.scm deleted file mode 100644 index 92f9a6e..0000000 --- a/cmdb/store.scm +++ /dev/null @@ -1,141 +0,0 @@ -;;; cmdb/store.scm — fact-log CMDB with versioned library. -;;; -;;; A fact `( ...)` is looked up in the active library -;;; module, called with , and the returned ops folded into state. -;;; -;;; The reserved op `(bump-lib "")` swaps the active library to -;;; module `(cmdb libraries )` (cmdb/libraries/.scm) for every -;;; subsequent fact, at append and refold alike — replay is -;;; contemporaneous: each fact applies through the then-current library. -;;; -;;; Refold starts from the `initial-library` SHA (make-cmdb arg); the -;;; first bump-lib overrides it for facts after it. - -(define-module (cmdb store) - #:use-module (hexol kernel) - #:use-module (ice-9 rdelim) - #:use-module (ice-9 textual-ports) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) - #:export (make-cmdb - cmdb? - cmdb-state - cmdb-log-path - cmdb-initial-library - cmdb-current-library - cmdb-get - cmdb-append-fact! - cmdb-facts - cmdb-refold! - fact->ops)) - -(define-record-type - (%make-cmdb initial-lib log-path state-box library-box) - cmdb? - (initial-lib cmdb-initial-library) - (log-path cmdb-log-path) - (state-box cmdb-state-box) - (library-box cmdb-library-box)) - -(define (cmdb-state c) (car (cmdb-state-box c))) -(define (set-cmdb-state! c s) (set-car! (cmdb-state-box c) s)) -(define (cmdb-current-library c) (car (cmdb-library-box c))) -(define (set-cmdb-library! c m) (set-car! (cmdb-library-box c) m)) - -;; ---------- library loading ---------- - -(define (sha->module-name sha) - (list 'cmdb 'libraries (string->symbol sha))) - -(define (load-library-by-sha sha) - (let ((mod-name (sha->module-name sha))) - (or (resolve-interface mod-name) - (error "could not load library for sha:" sha)))) - -;; ---------- fact log ---------- - -(define (read-fact-log log-path) - (if (file-exists? log-path) - (let ((port (open-input-file log-path))) - (let loop ((acc '())) - (let ((form (read port))) - (if (eof-object? form) - (begin (close-port port) (reverse acc)) - (loop (cons form acc)))))) - '())) - -(define (append-fact-to-log! log-path fact) - (let ((port (open-file log-path "a"))) - (write fact port) - (newline port) - (close-port port))) - -;; ---------- fact application ---------- - -(define (bump-lib-fact? fact) - (and (pair? fact) (eq? (car fact) 'bump-lib))) - -(define (fact->ops cmdb fact) - ;; Look up op-name in the active library, apply args, normalize to ops. - (unless (and (pair? fact) (symbol? (car fact))) - (error "invalid fact (expected (op-name args ...)):" fact)) - (let* ((name (car fact)) - (args (cdr fact)) - (var (module-variable (cmdb-current-library cmdb) name))) - (unless var - (error "unknown op in active library:" name - 'library (module-name (cmdb-current-library cmdb)))) - (let ((proc (variable-ref var))) - (unless (procedure? proc) - (error "library binding is not a procedure:" name)) - (let ((result (apply proc args))) - (cond - ((op? result) (list result)) - ((and (list? result) (every op? result)) result) - (else (error "library op did not return ops:" name result))))))) - -(define (apply-fact! cmdb fact) - ;; Mutating: bump-lib swaps the active library; ordinary facts fold - ;; their ops into state. - (cond - ((bump-lib-fact? fact) - (let ((sha (cadr fact))) - (set-cmdb-library! cmdb (load-library-by-sha sha)))) - (else - (let ((ops (fact->ops cmdb fact))) - (set-cmdb-state! cmdb - (fold (lambda (op s) (apply-op op s)) - (cmdb-state cmdb) - ops)))))) - -;; ---------- public ---------- - -(define* (make-cmdb log-path #:key (initial-library "v1")) - (let ((cmdb (%make-cmdb - initial-library - log-path - (list '()) - (list (load-library-by-sha initial-library))))) - (cmdb-refold! cmdb) - cmdb)) - -(define (cmdb-refold! cmdb) - ;; Reset to initial library + empty state, then replay all facts. - (set-cmdb-library! cmdb (load-library-by-sha (cmdb-initial-library cmdb))) - (set-cmdb-state! cmdb '()) - (for-each (lambda (fact) (apply-fact! cmdb fact)) - (read-fact-log (cmdb-log-path cmdb))) - (cmdb-state cmdb)) - -(define (cmdb-get cmdb path) - (state-get (cmdb-state cmdb) path)) - -(define (cmdb-append-fact! cmdb fact) - ;; Append to log first, then apply. If apply throws the log stays - ;; consistent (next refold hits the bad fact at the same point). - (append-fact-to-log! (cmdb-log-path cmdb) fact) - (apply-fact! cmdb fact) - (cmdb-state cmdb)) - -(define (cmdb-facts cmdb) - (read-fact-log (cmdb-log-path cmdb))) diff --git a/docs/cmdb.md b/docs/cmdb.md deleted file mode 100644 index 8808f05..0000000 --- a/docs/cmdb.md +++ /dev/null @@ -1,125 +0,0 @@ -# CMDB (as built) - -A small configuration-management database on the same fold-of-ops kernel as the -inventory engine. **Why:** instead of storing current state behind a REST API -with bolted-on audit, every change is a **fact** appended to a log, and state -is the **fold** of those facts. Provenance, time-travel, and replay come for -free, and the *meaning* of a fact is itself versioned in the log. - -This documents what ships in `cmdb/` and `bin/`. It is a POC. - -## The fact log - -A fact is one sexp on its own line in a log file (default `cmdb.log`): - -```scheme -(region alpha5 ((region . alpha5) (dc . alpha) (geo . eu) (tier . prod) ...)) -(promote alpha5 (apps ingress-nginx chart version) "4.11.3") -(bump-lib "v2") -``` - -To apply a fact, the store looks up its head symbol (`region`, `promote`, …) in -the **currently active library module**, calls that procedure with the fact's -args, and folds the ops it returns into in-memory state (`cmdb/store.scm`). -State is rebuilt by replaying the whole log — `cmdb-refold!`. - -Append is log-first: the fact is written to disk, then applied. A bad fact -leaves the log consistent (the next refold fails at the same point). - -## Versioned libraries — why a fact can mean different things over time - -The active library is controlled *by a fact*. The reserved op - -```scheme -(bump-lib "v2") -``` - -switches the active library to module `(cmdb libraries v2)` (file -`cmdb/libraries/v2.scm`) for every **subsequent** fact. Replay is -**contemporaneous**: each fact applies through whichever library was current -when it was appended. So bumping the library is an in-log event with an audit -trail — facts written before the bump keep their old rendering. - -`cmdb/libraries/v1.scm` and `v2.scm` each export three ops: - -| op | effect | -|----|--------| -| `(merge )` | `op:merge` a literal subtree into state | -| `(region )` | render the whole per-region subtree and `op:set` it under `(regions )` | -| `(promote )`| `op:set` one path under `(regions …)` — a surgical override | - -`v2` differs from `v1` only in that `region` rewrites EU regions' NTP pool — -the canonical demo of evolving an op's meaning under audit. - -## How `region` renders — reusing the engine - -`region` doesn't store its attrs; it computes the region's full config by -`resolve`-ing a hexol inventory against them (`cmdb/region-render.scm` → -`cmdb/region-body.scm`). That body is an ordinary hexol inventory: `hx-case` on -the `geo` / `hw-profile` / `network-profile` axes, `hx-when` gating the Helm app -load (`cmdb/apps.scm`) and sovereign-region cross-cuts (`annotate-all` / -`label-all`). So facts stay ~100 bytes while the materialized subtree is large. - -## Why the snapshot is the API - -Every op writes directly to the canonical path a consumer reads — -`(regions …)`. There is no per-query re-fold and no rendering layer: the -snapshot **is** the consumed shape. A tool like ArgoCD pulls a subtree -(`/state/regions.alpha5`) without knowing whether it was set by `region`, by -`promote`, or by hand. Adding a region is a data change (`sync-inventory`), not -a code change. - -## HTTP server - -`bin/cmdb-server [initial-library=v1] [log=cmdb.log] [port=8080]` boots -`cmdb/server.scm`: - -| route | does | -|-------|------| -| `GET /state` | entire materialized state | -| `GET /state/` | subtree/leaf at path (`regions.alpha5.apps`); 404 if missing | -| `GET /facts` | the full fact list | -| `POST /facts` | body is one fact sexp; appended + applied | -| `GET /health` | `ok` | - -Bodies are s-expressions (`application/scheme`); pass `?fmt=json` or -`Accept: application/json` for JSON out (`cmdb/json.scm`). Single-threaded; the -store is not safe for concurrent writes. - -## Drivers - -- **`bin/sync-inventory [regions=…] [url=…]`** — load a region table (a module - exporting `regions`) and POST one `(region )` fact per entry. - Seeds or refreshes the fleet. -- **`bin/promote app= tag= waves= [kind=image|chart] [gate=]`** — - progressive rollout. For each wave it POSTs a `promote` fact per region, - reads the path back to verify, then runs an optional shell `gate`; non-zero - exit aborts. Waves are `:`-separated, regions within a wave `,`-separated. - -```sh -./bin/cmdb-server & -./bin/sync-inventory regions=examples/regions.scm -./bin/promote app=ingress-nginx kind=chart tag=4.11.3 \ - waves=alpha5:bravo1,charlie6 gate='./smoke-test.sh' -curl -s localhost:8080/state/regions.alpha5.network.cni -``` - -## Layout - -``` -cmdb/ - store.scm fact log, library lookup, refold (the kernel of the CMDB) - server.scm HTTP front-end - json.scm sexp -> JSON for the `?fmt=json` path - region-render.scm resolve the per-region body against a fact's attrs - region-body.scm the per-region hexol inventory (hx-case/hx-when) - apps.scm Helm releases per region, loaded by region-body - libraries/ - v1.scm merge / region / promote - v2.scm same, EU NTP pool patched (library-bump demo) -bin/cmdb-server boot the server -bin/sync-inventory push a region table as facts -bin/promote waved image/chart rollouts -test/cmdb-store.scm store + refold + bump-lib replay -test/cmdb-server.scm route + format tests -``` diff --git a/docs/model.md b/docs/model.md index cbb4160..8f0e8f8 100644 --- a/docs/model.md +++ b/docs/model.md @@ -71,5 +71,4 @@ exists *at that point in the fold*. So order matters twice: - No reverse index ("all nodes with feature X") — predicates are arbitrary functions, decidable only by running them against a concrete query. -See the [README](../README.md) for the shipping API and `docs/cmdb.md` for the -event-sourced CMDB built on this same kernel. +See the [README](../README.md) for the shipping API. diff --git a/examples/inventory.scm b/examples/inventory.scm index 346567a..7bcdbed 100644 --- a/examples/inventory.scm +++ b/examples/inventory.scm @@ -11,7 +11,7 @@ ;;; The body is a pure function of the attributes: `hx-case` on geo/hardware/ ;;; network selects config, `hx-when` gates the k8s load and sovereign cross-cuts, ;;; `$` computes derived ids. The three regions exercise the branches -;;; (gpu/advanced/prod, sovereign/strict, standard/basic/dev). No CMDB needed. +;;; (gpu/advanced/prod, sovereign/strict, standard/basic/dev). (use-modules (hexol)) diff --git a/examples/regions.scm b/examples/regions.scm deleted file mode 100644 index 9830e43..0000000 --- a/examples/regions.scm +++ /dev/null @@ -1,22 +0,0 @@ -;;; examples/regions.scm — the region table as an importable module. -;;; -;;; Same three regions as examples/inventory.scm, exported as a module so the -;;; CMDB driver `bin/sync-inventory` can load them and POST one -;;; `(region )` fact per entry. The CMDB library expands each -;;; fact into the full per-region subtree via `cmdb/region-render.scm` (which -;;; shares its body with the inventory example). See docs/cmdb.md. -;;; -;;; Dispatch axes as data: dc, geo, hw-profile, network-profile, tier, -;;; sovereignty. Each cdr is the attribute seed. The three entries exercise -;;; the body's branches (gpu/advanced/prod, sovereign/strict, standard/basic/dev). - -(define-module (examples regions) - #:export (regions)) - -(define regions - '((alpha5 (region . alpha5) (dc . alpha) (geo . eu) (hw-profile . gpu-dense) - (network-profile . advanced) (tier . prod) (sovereignty . none)) - (bravo1 (region . bravo1) (dc . bravo) (geo . eu) (hw-profile . standard) - (network-profile . sovereign) (tier . prod) (sovereignty . strict)) - (charlie6 (region . charlie6) (dc . charlie) (geo . na) (hw-profile . standard) - (network-profile . basic) (tier . dev) (sovereignty . none)))) diff --git a/hexol/ansible.scm b/hexol/ansible.scm index 538db13..c383fe0 100644 --- a/hexol/ansible.scm +++ b/hexol/ansible.scm @@ -13,10 +13,10 @@ ;;; NOT here: fanning a role over a group (one play per host) is an ;;; *example's* structure, built from kernel compose-ops/map — see ;;; examples/ansible.scm. *Rendering* is the CLI's job: `hexol render -o -;;; ansible` JSON-encodes `(ansible_plays)` (a playbook is valid JSON). No -;;; CMDB, no HTTP — state is a nested alist built once from inventory.yml. +;;; ansible` JSON-encodes `(ansible_plays)` (a playbook is valid JSON). +;;; State is a nested alist built once from inventory.yml. ;;; -;;; State shape (mirrors what we'd put in the CMDB if we did): +;;; State shape: ;;; ;;; ((hosts ( (vars ( . ) ...)) ...) ;;; (groups ( (hosts

...) diff --git a/manifest.scm b/manifest.scm index 1088328..7501525 100644 --- a/manifest.scm +++ b/manifest.scm @@ -1,7 +1,7 @@ ;; Dependencies for building, testing, and running hexol. ;; guile — the interpreter (3.x) ;; guile-json — the (json) module, imported by (hexol k8s), terraform, -;; secrets, and the cmdb +;; secrets, and (hexol json) ;; guile-libyaml — the (yaml) module, imported by (hexol ansible) ;; jq — used by the secrets tooling ;; This manifest is the source of truth for dependencies: `guix shell -m diff --git a/test/cmdb-server.scm b/test/cmdb-server.scm deleted file mode 100644 index 6a8c3d1..0000000 --- a/test/cmdb-server.scm +++ /dev/null @@ -1,204 +0,0 @@ -;;; test/cmdb-server.scm — integration tests for the HTTP server. -;;; -;;; Forks a child that runs the server on a high port, exercises the -;;; routes from the parent via Guile's web client, then kills the child. - -(add-to-load-path (dirname (dirname (current-filename)))) - -(use-modules (cmdb store) - (cmdb server) - ((web client) #:renamer (lambda (s) - (case s - ((http-post) 'web:http-post) - ((http-get) 'web:http-get) - (else s)))) - (web response) - (rnrs bytevectors) - (json) - (ice-9 format)) - -(define failures 0) -(define port (+ 19000 (modulo (getpid) 1000))) -(define base-url (format #f "http://127.0.0.1:~a" port)) -(define tmp-log - (string-append "/tmp/cmdb-server-test-" (number->string (getpid)) ".log")) - -(define-syntax check - (syntax-rules () - ((_ desc expected actual) - (let ((e expected) (a actual)) - (if (equal? e a) - (format #t " ok ~a~%" desc) - (begin - (set! failures (+ failures 1)) - (format #t " FAIL ~a~% expected: ~s~% got: ~s~%" - desc e a))))))) - -(define (decode-body body) - (cond ((not body) "") - ((bytevector? body) (utf8->string body)) - (else body))) - -(define (get-status+body url) - (call-with-values (lambda () (web:http-get url)) - (lambda (r b) (values (response-code r) (decode-body b))))) - -(define (get-json url) - (call-with-values - (lambda () (web:http-get url - #:headers '((accept . ((application/json)))))) - (lambda (r b) - (values (response-code r) - (assq-ref (response-headers r) 'content-type) - (decode-body b))))) - -(define (post-sexp url sexp) - (call-with-values - (lambda () - (web:http-post url - #:body (string->utf8 - (call-with-output-string - (lambda (p) (write sexp p)))) - #:headers '((content-type . (application/scheme))))) - (lambda (r b) (values (response-code r) (decode-body b))))) - -(define (sexp-of s) (call-with-input-string s read)) - -(define (wait-for-server max-attempts) - (let loop ((n max-attempts)) - (cond - ((zero? n) (error "server didn't come up")) - (else - (let ((up? (catch #t - (lambda () - (call-with-values - (lambda () (web:http-get (string-append base-url "/health"))) - (lambda (r b) (= (response-code r) 200)))) - (lambda _ #f)))) - (if up? - #t - (begin (usleep 100000) (loop (- n 1))))))))) - -(when (file-exists? tmp-log) (delete-file tmp-log)) - -(format #t "~%cmdb/server: forking server on port ~a~%" port) -(define child-pid (primitive-fork)) -(cond - ((zero? child-pid) - ;; child: run the server - (let ((c (make-cmdb tmp-log))) - (start-server c #:port port)) - (exit 0)) - (else - ;; parent: run tests - (wait-for-server 50) - - (format #t "~%cmdb/server: GET /health~%") - (call-with-values (lambda () (get-status+body (string-append base-url "/health"))) - (lambda (code body) - (check "health 200" 200 code) - (check "health body" "ok\n" body))) - - (format #t "~%cmdb/server: POST /facts + GET /state~%") - (call-with-values - (lambda () (post-sexp (string-append base-url "/facts") - '(merge ((regions (alpha5 (attributes (dc . alpha) (geo . eu)))))))) - (lambda (code body) - (check "post merge (attrs) 200" 200 code) - (let ((reply (sexp-of body))) - (check "post reply ok" #t (assq-ref reply 'ok))))) - - (call-with-values - (lambda () (post-sexp (string-append base-url "/facts") - '(merge ((apps (api (image (tag . "v1.0.0")))))))) - (lambda (code body) (check "post merge (default) 200" 200 code))) - - (call-with-values - (lambda () (post-sexp (string-append base-url "/facts") - '(merge ((regions (alpha5 (apps (api (image (tag . "v2.0.0")))))))))) - (lambda (code body) (check "post merge (override) 200" 200 code))) - - (call-with-values - (lambda () (get-status+body - (string-append base-url "/state/regions.alpha5.apps.api.image.tag"))) - (lambda (code body) - (check "get path 200" 200 code) - (check "get path returns promoted tag" "v2.0.0" (sexp-of body)))) - - (call-with-values - (lambda () (get-status+body - (string-append base-url "/state/apps.api.image.tag"))) - (lambda (code body) - (check "get default tag" "v1.0.0" (sexp-of body)))) - - (call-with-values - (lambda () (get-status+body - (string-append base-url "/state/regions.alpha5.attributes"))) - (lambda (code body) - (check "get region attrs as sexp" - '((dc . alpha) (geo . eu)) - (sexp-of body)))) - - (format #t "~%cmdb/server: 404 on missing path~%") - (call-with-values - (lambda () (get-status+body (string-append base-url "/state/nope.nope"))) - (lambda (code body) (check "missing path -> 404" 404 code))) - - (format #t "~%cmdb/server: GET /facts~%") - (call-with-values - (lambda () (get-status+body (string-append base-url "/facts"))) - (lambda (code body) - (check "facts 200" 200 code) - (check "facts has 3 entries" 3 (length (sexp-of body))))) - - (format #t "~%cmdb/server: json output~%") - (call-with-values - (lambda () (get-json (string-append base-url "/state/regions.alpha5.attributes"))) - (lambda (code ctype body) - (check "json 200" 200 code) - (check "json content-type" '(application/json) - (and ctype (list (car ctype)))) - (check "json parses + correct value" "alpha" - (assoc-ref (json-string->scm body) "dc")))) - - ;; symbol leaf -> JSON string - (call-with-values - (lambda () (get-json (string-append base-url "/state/regions.alpha5.attributes.dc"))) - (lambda (code ctype body) - (check "json scalar (symbol -> string)" "alpha" - (json-string->scm body)))) - - ;; array (list of symbols) -> JSON array of strings - (post-sexp (string-append base-url "/facts") - '(merge ((regions (alpha5 (packages a b c)))))) - (call-with-values - (lambda () (get-json (string-append base-url "/state/regions.alpha5.packages"))) - (lambda (code ctype body) - (check "json array of symbols" '#("a" "b" "c") - (json-string->scm body)))) - - (call-with-values - (lambda () (get-json (string-append base-url "/facts"))) - (lambda (code ctype body) - (let ((v (json-string->scm body))) - (check "json /facts is array" #t (vector? v)) - (check "json /facts entry count" 4 (vector-length v))))) - - ;; ?fmt=json query param - (call-with-values - (lambda () (get-status+body - (string-append base-url - "/state/regions.alpha5.attributes.dc?fmt=json"))) - (lambda (code body) - (check "?fmt=json works without Accept" "alpha" (json-string->scm body)))) - - ;; teardown - (kill child-pid SIGTERM) - (waitpid child-pid) - (when (file-exists? tmp-log) (delete-file tmp-log)) - - (format #t "~%~a~%" - (if (zero? failures) - "all cmdb-server checks passed" - (format #f "~a cmdb-server failure(s)" failures))) - (exit (if (zero? failures) 0 1)))) diff --git a/test/cmdb-store.scm b/test/cmdb-store.scm deleted file mode 100644 index a2be046..0000000 --- a/test/cmdb-store.scm +++ /dev/null @@ -1,167 +0,0 @@ -;;; test/cmdb-store.scm — unit tests for the CMDB store + library. - -(add-to-load-path (dirname (dirname (current-filename)))) - -(use-modules (cmdb store) - (hexol kernel) - (ice-9 format)) - -(define failures 0) - -(define-syntax check - (syntax-rules () - ((_ desc expected actual) - (let ((e expected) (a actual)) - (if (equal? e a) - (format #t " ok ~a~%" desc) - (begin - (set! failures (+ failures 1)) - (format #t " FAIL ~a~% expected: ~s~% got: ~s~%" - desc e a))))))) - -(define tmp-log - (string-append "/tmp/cmdb-store-test-" - (number->string (getpid)) ".log")) - -(when (file-exists? tmp-log) (delete-file tmp-log)) - -(format #t "~%cmdb/store: append + get~%") -(define c (make-cmdb tmp-log)) -(check "fresh state is empty" '() (cmdb-state c)) -(check "get on empty" #f (cmdb-get c '(regions alpha5))) - -(cmdb-append-fact! c '(merge ((regions (alpha5 (attributes (dc . alpha) (geo . eu))))))) -(check "merge writes nested attrs" - '((dc . alpha) (geo . eu)) - (cmdb-get c '(regions alpha5 attributes))) - -(cmdb-append-fact! c '(merge ((apps (api (image (tag . "v1.0.0"))))))) -(check "merge writes default app tag" - "v1.0.0" - (cmdb-get c '(apps api image tag))) - -(cmdb-append-fact! c '(merge ((regions (alpha5 (apps (api (image (tag . "v2.0.0"))))))))) -(check "per-region merge overrides at the leaf" - "v2.0.0" - (cmdb-get c '(regions alpha5 apps api image tag))) -(check "default unchanged after per-region merge" - "v1.0.0" - (cmdb-get c '(apps api image tag))) -(check "sibling attrs survive per-region merge" - 'alpha - (cmdb-get c '(regions alpha5 attributes dc))) - -(format #t "~%cmdb/store: fact log persistence + refold~%") -(check "fact log has 3 entries" 3 (length (cmdb-facts c))) - -(define c2 (make-cmdb tmp-log)) -(check "refold reproduces region attrs" - '((dc . alpha) (geo . eu)) - (cmdb-get c2 '(regions alpha5 attributes))) -(check "refold reproduces overridden tag" - "v2.0.0" - (cmdb-get c2 '(regions alpha5 apps api image tag))) - -(format #t "~%cmdb/store: high-level region + promote ops~%") -(define tmp-log2 - (string-append "/tmp/cmdb-store-test2-" (number->string (getpid)) ".log")) -(when (file-exists? tmp-log2) (delete-file tmp-log2)) -(define c3 (make-cmdb tmp-log2)) - -(cmdb-append-fact! - c3 '(region alpha5 - ((region . alpha5) (dc . alpha) (geo . eu) - (hw-profile . gpu-dense) (network-profile . advanced) - (tier . prod) (sovereignty . none)))) - -(check "region op renders network from advanced profile" - 'cilium (cmdb-get c3 '(regions alpha5 network cni))) -(check "region op renders hw from gpu-dense profile" - 8 (cmdb-get c3 '(regions alpha5 hardware gpu count))) -(check "region op renders apps (k8s 1.33 > 1.32.4)" - "4.11.2" (cmdb-get c3 '(regions alpha5 apps ingress-nginx chart version))) -(check "region op renders geo defaults" - "Europe/Paris" (cmdb-get c3 '(regions alpha5 locale timezone))) - -(cmdb-append-fact! - c3 '(promote alpha5 (apps ingress-nginx chart version) "4.12.0")) -(check "promote overrides at the leaf" - "4.12.0" (cmdb-get c3 '(regions alpha5 apps ingress-nginx chart version))) -(check "promote leaves siblings intact" - 'cilium (cmdb-get c3 '(regions alpha5 network cni))) - -;; refold: facts replay should reproduce the same end state -(define c4 (make-cmdb tmp-log2)) -(check "refold reproduces region body + promotion" - "4.12.0" (cmdb-get c4 '(regions alpha5 apps ingress-nginx chart version))) -(check "refold reproduces gpu count" - 8 (cmdb-get c4 '(regions alpha5 hardware gpu count))) -(when (file-exists? tmp-log2) (delete-file tmp-log2)) - -(format #t "~%cmdb/store: bump-lib (library versioning via fact)~%") -(define tmp-log3 - (string-append "/tmp/cmdb-store-test3-" (number->string (getpid)) ".log")) -(when (file-exists? tmp-log3) (delete-file tmp-log3)) -(define c5 (make-cmdb tmp-log3 #:initial-library "v1")) - -;; Region added under v1: EU NTP pool is the legacy europe pool. -(cmdb-append-fact! - c5 '(region alpha5 - ((region . alpha5) (dc . alpha) (geo . eu) - (hw-profile . standard) (network-profile . basic) - (tier . prod) (sovereignty . none)))) -(check "v1 region: EU ntp pool is europe.pool.ntp.org" - "europe.pool.ntp.org" - (cmdb-get c5 '(regions alpha5 ntp pool))) - -;; Bump the library mid-log. -(cmdb-append-fact! c5 '(bump-lib "v2")) - -;; New region added after the bump: NTP pool is the v2-patched one. -(cmdb-append-fact! - c5 '(region delta1 - ((region . delta1) (dc . delta) (geo . eu) - (hw-profile . standard) (network-profile . basic) - (tier . prod) (sovereignty . none)))) -(check "v2 region: EU ntp pool is paris.pool.ntp.org" - "paris.pool.ntp.org" - (cmdb-get c5 '(regions delta1 ntp pool))) -(check "v1 region untouched by later library bump" - "europe.pool.ntp.org" - (cmdb-get c5 '(regions alpha5 ntp pool))) - -;; Refold from scratch: same contemporaneous interpretation. -(define c6 (make-cmdb tmp-log3 #:initial-library "v1")) -(check "refold preserves v1-rendered alpha5" - "europe.pool.ntp.org" - (cmdb-get c6 '(regions alpha5 ntp pool))) -(check "refold preserves v2-rendered delta1" - "paris.pool.ntp.org" - (cmdb-get c6 '(regions delta1 ntp pool))) - -;; NA region rendered under v2 stays unaffected (v2 only patches EU). -(cmdb-append-fact! - c6 '(region charlie1 - ((region . charlie1) (dc . charlie) (geo . na) - (hw-profile . standard) (network-profile . basic) - (tier . prod) (sovereignty . none)))) -(check "v2 NA region unaffected by EU patch" - "north-america.pool.ntp.org" - (cmdb-get c6 '(regions charlie1 ntp pool))) - -(when (file-exists? tmp-log3) (delete-file tmp-log3)) - -(format #t "~%cmdb/store: error paths~%") -(check "unknown op raises" - #t - (catch #t - (lambda () (cmdb-append-fact! c '(no-such-op 1 2)) #f) - (lambda _ #t))) - -(when (file-exists? tmp-log) (delete-file tmp-log)) - -(format #t "~%~a~%" - (if (zero? failures) - "all cmdb-store checks passed" - (format #f "~a cmdb-store failure(s)" failures))) -(exit (if (zero? failures) 0 1))