From f56b03bd4ae81dfe260eb8bad690be4bb1249270 Mon Sep 17 00:00:00 2001 From: Polyedre Date: Sun, 5 Jul 2026 18:15:40 +0200 Subject: [PATCH 01/12] guix.scm: package hexol the guix way (guile-build-system) guix build -f guix.scm; guix shell -f guix.scm -- hexol --- guix.scm | 51 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 51 insertions(+) create mode 100644 guix.scm diff --git a/guix.scm b/guix.scm new file mode 100644 index 0000000..aefe4c6 --- /dev/null +++ b/guix.scm @@ -0,0 +1,51 @@ +(use-modules (guix packages) + (guix build-system guile) + (guix licenses) + (guix gexp) + (gnu packages guile) + (gnu packages guile-xyz)) + +(package + (name "hexol") + (version "0.1") + (source (local-file "." "hexol-source" + #:recursive? #t + #:select? (lambda (f s) + (and (not (or (string-suffix? ".go" f) + (string-suffix? "~" f) + (string-contains f "/.git/") + (string-contains f "/.venv/") + (string-contains f "/deploy/") + (string-contains f "/examples/") + (string-contains f "/test/") + (string-contains f "/docs/") + (string-contains f "/openrc/"))) + (not (member (basename f) '("test.scm" "guix.scm" "Makefile" "README.md" "PONYTAIL-AUDIT.md" "CONTEXT.md"))))))) + (build-system guile-build-system) + (arguments + (list + #:source-directory "." + #:phases + #~(modify-phases %standard-phases + (add-after 'install-documentation 'install-bin + (lambda* (#:key outputs #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (bin (string-append out "/bin")) + (site (string-append out "/share/guile/site/3.0")) + (store-script (string-append out "/share/hexol/hexol"))) + ;; keep the real guile script outside bin so the shebang -L . doesn't matter + (mkdir-p (string-append out "/share/hexol")) + (copy-file "bin/hexol" store-script) + (mkdir-p bin) + (let ((wrapper (string-append bin "/hexol"))) + (call-with-output-file wrapper + (lambda (port) + (format port "#!/bin/sh\nexec guile -L ~a -e main -s ~a \"$@\"\n" + site store-script))) + (chmod wrapper #o755)))))))) + (propagated-inputs + (list guile-3.0 guile-json-4 guile-libyaml)) + (home-page "https://github.com/polyedre/hexol") + (synopsis "Extensible inventory engine") + (description "Hexol resolves layered inventories into concrete configurations.") + (license gpl3+)) From fb7e399c3136fc135dd869eaf2de01525a6ece82 Mon Sep 17 00:00:00 2001 From: Polyedre Date: Sun, 5 Jul 2026 17:54:21 +0200 Subject: [PATCH 02/12] ledger: pad-account min 2 spaces (35-char accounts got 1, invalid ledger fmt) --- hexol/ledger.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hexol/ledger.scm b/hexol/ledger.scm index e14daea..fca1a70 100644 --- a/hexol/ledger.scm +++ b/hexol/ledger.scm @@ -351,7 +351,7 @@ examples end with (tls-all)." (n (string-length s))) (if (>= n account-column) (string-append s " ") - (string-append s (make-string (- account-column n) #\space))))) + (string-append s (make-string (max 2 (- account-column n)) #\space))))) (define (render-post p) (let ((account (assq-ref p 'account)) From 50f2e2cdd99ee77c15df6b1572961a1641ca3775 Mon Sep 17 00:00:00 2001 From: Polyedre Date: Thu, 3 Sep 2026 14:01:30 +0200 Subject: [PATCH 03/12] kernel: attribute nested-fold (hx-each) deltas to their outer path; add hexol lint MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit for-each-into now binds a fold frame (prefix . outer-state) around each entry's resolve, and apply-op re-embeds traced after-states through the frames, so explain/show see (regions alpha5 …) paths instead of a bare sub-state that never matched. Flat paths are unaffected. Add an access log (resolve-with-access, note-read!): surface get/attr record the (prefixed) paths they read, and (hexol lint) walks one fold to warn on a path read before its last write — the stale-$ case model.md defers to a lint pass. New `hexol lint` verb, exit 1 on any warning. k8s: declare `rule` under #:replace, silencing the core-binding warning every inventory importing (hexol k8s) printed. --- Makefile | 3 +- bin/hexol | 19 ++++++++++++ docs/authoring.md | 7 +++++ hexol/k8s.scm | 7 +++-- hexol/kernel.scm | 58 ++++++++++++++++++++++++++++++++--- hexol/lint.scm | 77 +++++++++++++++++++++++++++++++++++++++++++++++ hexol/surface.scm | 2 ++ test.scm | 45 +++++++++++++++++++++++++++ 8 files changed, 211 insertions(+), 7 deletions(-) create mode 100644 hexol/lint.scm diff --git a/Makefile b/Makefile index 7bbe88c..9b85944 100644 --- a/Makefile +++ b/Makefile @@ -14,6 +14,7 @@ help: @echo " ./bin/hexol tree [-i INVENTORY]" @echo " ./bin/hexol explain [--query K=V,…] PATH|HASH [-i INVENTORY]" @echo " ./bin/hexol show HASH [-i INVENTORY]" + @echo " ./bin/hexol lint [-i INVENTORY]" test: $(GUILE) -L . test.scm @@ -24,7 +25,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) (hexol 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) (hexol lint)) (display "build ok\n"))' clean: rm -rf ~/.cache/guile/ccache/*$(CURDIR)* diff --git a/bin/hexol b/bin/hexol index 50454f5..c75d337 100755 --- a/bin/hexol +++ b/bin/hexol @@ -15,6 +15,8 @@ ;;; (-v: + per-op fold time) ;;; hexol explain PATH|HASH [-i INV] ops that touched PATH ;;; (or every path an op changed) +;;; hexol lint [-i INV] warn on $ reads that precede +;;; the write they depend on ;;; ;;; Inventory is -i/--inventory (or $HEXOL_INVENTORY), never a positional. ;;; @@ -47,6 +49,7 @@ ;; CLI needs only the kernel — it reads inventories into ops and folds them, ;; never authors ops (so the hx-prefixed author surface isn't imported). (use-modules (hexol kernel) + (hexol lint) (hexol cache) (hexol yaml) (hexol terraform) @@ -607,6 +610,19 @@ (for-each (lambda (path) (explain-path final trace path)) paths))) (explain-path final trace (parse-path target))))))) +;; --------------------------------------------------------------------------- +;; lint — reads that precede the write they depend on (see hexol/lint.scm) +;; --------------------------------------------------------------------------- + +(define (cmd-lint args) + (let* ((inv (inventory-only "lint" args)) + (warnings (lint-ops (load-ops inv)))) + (for-each (lambda (w) (format (current-error-port) "~a~%" (e-red (string-append "warning: " w)))) + warnings) + (format (current-error-port) "~a~%" + (e-dim (format #f "hexol lint: ~a: ~a warning~p" inv (length warnings) (length warnings)))) + (exit (if (null? warnings) 0 1)))) + ;; --------------------------------------------------------------------------- ;; show — one op by its content hash (the hash `tree` prints) ;; --------------------------------------------------------------------------- @@ -889,6 +905,9 @@ The inventory comes from -i/--inventory or $HEXOL_INVENTORY.") (register-verb! (make-verb "explain" (cmd-is "explain") (delegating-runner cmd-explain) "explain PATH|HASH [-i INVENTORY]")) +(register-verb! + (make-verb "lint" (cmd-is "lint") (delegating-runner cmd-lint) + "lint [-i INVENTORY]")) (register-verb! (make-verb "show" (cmd-is "show") (delegating-runner cmd-show) "show HASH [-i INVENTORY]")) diff --git a/docs/authoring.md b/docs/authoring.md index d2618af..558f2a8 100644 --- a/docs/authoring.md +++ b/docs/authoring.md @@ -159,6 +159,13 @@ Resolution is a left fold in source order. Two consequences: `(nginx workers)`, place the derivation *after* every op that may write `workers`, otherwise you'll see a stale value. +`hexol lint -i INVENTORY` catches the second case: it folds the inventory +once, recording what each op reads (`get`/`attr`) and writes, and warns +`path P read by op X (file:line) before its last write by op Y (file:line)` +for every read that precedes the last write to that path (or to a parent or +child of it). Exit status is 1 when anything is reported, 0 otherwise, so it +slots into CI. Paths under `hx-each` are reported at their full outer path. + See [`model.md`](model.md) for the "load-bearing ordering" discussion. ## Secrets (inline, sops-backed) diff --git a/hexol/k8s.scm b/hexol/k8s.scm index 17ee0f5..9a5fff5 100644 --- a/hexol/k8s.scm +++ b/hexol/k8s.scm @@ -67,7 +67,7 @@ ;; volume / env source refs cm sec pvc mount host-path ;; RBAC - service-account role role-binding rule + service-account role role-binding cluster-role cluster-role-binding cluster-rbac ;; external manifests (render-time splice) json-manifests cached-json-manifests remote-manifest @@ -80,7 +80,10 @@ compliance-check compliance-all check-resources-set check-cpu-limit-ge-request check-memory-limit-equals-request check-image-registry - check-no-privileged)) + check-no-privileged) + ;; `rule` shadows a core binding; declare the override so importing this + ;; module into an inventory doesn't warn about it. + #:replace (rule)) ;; --------------------------------------------------------------------------- ;; namespace scope diff --git a/hexol/kernel.scm b/hexol/kernel.scm index 5c3566e..9a22ea5 100644 --- a/hexol/kernel.scm +++ b/hexol/kernel.scm @@ -23,6 +23,8 @@ path->string ;; tracing (explain support) current-trace resolve-with-trace path-get + ;; read/write access log (lint support) + current-access note-read! resolve-with-access ;; per-op fold timing (tree -v support) current-timings resolve-with-timings ;; loader (exposed so other modules can override path resolution) @@ -166,21 +168,56 @@ from its kind, source form, label, and the content hashes of its children." ;; (folds children through apply-op). Unbound -> zero timing overhead. (define current-timings (make-parameter #f)) +;; Nested-fold frames, innermost first: (prefix . outer-state). for-each-into +;; pushes one per table entry while its body resolves, so the trace and the +;; access log see the body's states re-embedded at their outer path +;; ((regions alpha5 …)) and its read paths prefixed — a nested fold's deltas +;; are attributed where the author addresses them, not to a bare sub-state. +(define current-fold-frames (make-parameter '())) + +(define (embed-state s) + (fold (lambda (frame s) (state-set (cdr frame) (car frame) s)) + s (current-fold-frames))) + +(define (full-path path) + (append (append-map car (reverse (current-fold-frames))) path)) + +;; When bound to a box, collects every apply-op call's (op reads after-state) +;; entry in fire order — like the trace, plus the state paths the effect read +;; via note-read! (surface `get`/`attr`). current-reads is the per-effect box +;; apply-op binds so reads land on the innermost op firing. +(define current-access (make-parameter #f)) +(define current-reads (make-parameter #f)) + +(define (note-read! path) + "Record PATH as read by the op currently firing, when an access log is +being collected (`resolve-with-access'). A no-op otherwise." + (let ((box (current-reads))) + (when box (set-car! box (cons (full-path path) (car box)))))) + (define (apply-op op state) "Apply OP's effect to STATE and return the new state. When `current-trace' is bound to a box, records the (op . after-state) pair; when +`current-access' is bound to a box, records (op reads after-state); when `current-timings' is bound to a hash table, accumulates OP's elapsed real-time (inclusive of children) keyed by op identity." (let* ((timings (current-timings)) (start (and timings (get-internal-real-time))) - (new-state ((op-effect op) state))) + (log (current-access)) + (reads (and log (list '()))) + (new-state (if reads + (parameterize ((current-reads reads)) ((op-effect op) state)) + ((op-effect op) state)))) (when timings (hashq-set! timings op (+ (- (get-internal-real-time) start) (or (hashq-ref timings op) 0)))) (let ((box (current-trace))) (when box - (set-car! box (cons (cons op new-state) (car box))))) + (set-car! box (cons (cons op (embed-state new-state)) (car box))))) + (when log + (set-car! log (cons (list op (reverse (car reads)) (embed-state new-state)) + (car log)))) new-state)) (define (resolve ops attributes) @@ -199,6 +236,15 @@ a list of (op . after-state) pairs in fire order." (resolve ops attributes)))) (values result (reverse (car box)))))) +(define (resolve-with-access ops attributes) + "Like `resolve', but return two values: the final state and the access log +as a list of (op reads after-state) entries in fire order, READS being the +paths the op's effect read via `note-read!'." + (let ((box (list '()))) + (let ((result (parameterize ((current-access box)) + (resolve ops attributes)))) + (values result (reverse (car box)))))) + (define (resolve-with-timings ops attributes table) "Like `resolve', but record each op's fold time into TABLE (a hash table keyed by op identity, via hashq), accumulating across calls. Times are @@ -408,8 +454,12 @@ children for introspection." `(for-each-into ,base ,(map car table)) (lambda (state) (fold (lambda (entry s) - (state-set s (append base (list (car entry))) - (resolve body (cdr entry)))) + (let ((prefix (append base (list (car entry))))) + (state-set s prefix + (parameterize ((current-fold-frames + (cons (cons prefix s) + (current-fold-frames)))) + (resolve body (cdr entry)))))) state table)) (format #f "for-each-into ~a (~a)" (string-join (map symbol->string base) ".") diff --git a/hexol/lint.scm b/hexol/lint.scm new file mode 100644 index 0000000..5416249 --- /dev/null +++ b/hexol/lint.scm @@ -0,0 +1,77 @@ +;;; hexol/lint.scm — ordering lint over one resolve. +;;; +;;; docs/model.md: a computed ($ …) value placed before the writes it depends +;;; on silently reads a stale value, and "mitigation belongs in a lint pass". +;;; This is that pass. It folds the inventory once under the kernel's access +;;; log (`resolve-with-access'): every op firing yields the paths its effect +;;; read (surface `get`/`attr`) and, by diffing states, the leaf paths it +;;; wrote. A read of P at step i whose last write (to P, a parent, or a child +;;; of P) lands at a later step j is the stale read. Reads by hx-when/hx-case +;;; predicates count too — a gate on a not-yet-written path is the same bug. + +(define-module (hexol lint) + #:use-module (hexol kernel) + #:use-module (srfi srfi-1) + #:use-module (ice-9 format) + #:export (lint-ops)) + +(define (alist? x) (and (list? x) (every pair? x))) + +;; Leaf paths whose value differs between state nodes A and B, under PATH. +;; Alists recurse key-by-key; anything else is compared whole. +(define (changed-paths a b path) + (cond + ((equal? a b) '()) + ((and (alist? a) (alist? b) (pair? a) (pair? b)) + (let ((keys (delete-duplicates (append (map car a) (map car b)) eq?))) + (append-map (lambda (k) + (changed-paths (assq-ref a k) (assq-ref b k) + (append path (list k)))) + keys))) + (else (list path)))) + +;; A write to W touches a read of P when either is a prefix of the other: +;; reading (nginx) sees a later (nginx workers) write; reading (nginx workers) +;; sees a later (nginx) overwrite. +(define (prefix? a b) + (or (null? a) (and (pair? b) (equal? (car a) (car b)) (prefix? (cdr a) (cdr b))))) +(define (touches? w p) (or (prefix? w p) (prefix? p w))) + +(define (op-display op) (or (op-label op) (symbol->string (op-kind op)))) +(define (loc->string loc) + (if (pair? loc) (format #f "~a:~a" (car loc) (cdr loc)) "unknown")) + +(define (lint-ops ops) + "Resolve OPS once (empty query) and return the list of warning strings: +one per path read by an op before that path's last write in the fold." + (call-with-values (lambda () (resolve-with-access ops '())) + (lambda (final log) + ;; Walk fire order collecting (step op path) for every leaf write and + ;; every read; then each read is checked against later writes. + (let loop ((prev '((attributes))) (entries log) (i 0) (writes '()) (reads '())) + (if (pair? entries) + (let* ((e (car entries)) + (op (car e)) + (after (caddr e)) + (leaf? (null? (op-children op)))) + (loop after (cdr entries) (+ i 1) + (if leaf? + (append (map (lambda (p) (list i op p)) + (changed-paths prev after '())) + writes) + writes) + (append (map (lambda (p) (list i op p)) (cadr e)) reads))) + (filter-map + (lambda (r) + (let* ((step (car r)) (op (cadr r)) (path (caddr r)) + ;; latest write touching PATH after this read, if any + ;; (writes is newest-first, so `find` is the last one). + (late (find (lambda (w) (and (> (car w) step) + (touches? (caddr w) path))) + writes))) + (and late + (format #f "path ~a read by op ~a (~a) before its last write by op ~a (~a)" + (path->string path) + (op-display op) (loc->string (op-loc op)) + (op-display (cadr late)) (loc->string (op-loc (cadr late))))))) + (reverse (delete-duplicates reads)))))))) diff --git a/hexol/surface.scm b/hexol/surface.scm index a4ba28c..1ebeff9 100644 --- a/hexol/surface.scm +++ b/hexol/surface.scm @@ -55,6 +55,7 @@ current fold state. Valid only inside a computed value ($ …) or an hx-when/hx-case predicate; errors otherwise." (let ((s (current-state))) (unless s (error "(attr) used outside a computed value or predicate")) + (note-read! (list 'attributes k)) (state-get s (list 'attributes k)))) (define (get p) @@ -63,6 +64,7 @@ state. Valid only inside a computed value ($ …) or an hx-when/hx-case predicate; errors otherwise." (let ((s (current-state))) (unless s (error "(get) used outside a computed value or predicate")) + (note-read! p) (state-get s p))) ;; ---------- string building for computed ($ …) values ---------- diff --git a/test.scm b/test.scm index 7428c32..ad4d293 100644 --- a/test.scm +++ b/test.scm @@ -4,6 +4,7 @@ (use-modules (hexol kernel) (hexol surface) + (hexol lint) (srfi srfi-1) (ice-9 format)) @@ -127,6 +128,50 @@ (when-hit (resolve (hx-ops (hx-when (lambda (s) (eq? (state-get s '(attributes role)) 'web)) (hx-merge (hit yes)))) '((role . web))))) +(format #t "~%kernel: nested-fold provenance (hx-each) + access log~%") + +;; The trace records each nested op's after-state re-embedded at its outer +;; path, so explain-style walks over the full path (regions r1 x) find the +;; leaf op that wrote it — not just the for-each-into wrapper. +(define inv-each + (hx-ops (hx-each '((r1 (n . 1)) (r2 (n . 2))) #:into regions + (hx-merge (x ($ (* 10 (attr 'n)))))))) +(call-with-values (lambda () (resolve-with-trace inv-each '())) + (lambda (final trace) + (define (writer path) + (let loop ((prev '((attributes))) (steps trace)) + (cond ((null? steps) #f) + ((and (null? (op-children (caar steps))) + (not (equal? (path-get prev path) (path-get (cdar steps) path)))) + (op-kind (caar steps))) + (else (loop (cdar steps) (cdr steps)))))) + (check "hx-each: final value" 20 (path-get final '(regions r2 x))) + (check "hx-each: leaf op blamed for r1.x" 'merge (writer '(regions r1 x))) + (check "hx-each: leaf op blamed for r2.x" 'merge (writer '(regions r2 x))) + (check "hx-each: trace tail is the full state" final (cdr (last trace))))) +;; Read paths are prefixed the same way. +(call-with-values (lambda () (resolve-with-access inv-each '())) + (lambda (final log) + (check "hx-each: reads prefixed" '((regions r1 attributes n)) + (cadr (car log))))) + +(format #t "~%lint: stale reads~%") +(define (lint-count ops) (length (lint-ops ops))) +(check "lint: read after write is clean" 0 + (lint-count (hx-ops (hx-merge (a (n 4))) + (hx-merge (a (m ($ (* 2 (get '(a n)))))))))) +(check "lint: read before later write warns" 1 + (lint-count (hx-ops (hx-merge (a (n 4))) + (hx-merge (a (m ($ (* 2 (get '(a n))))))) + (hx-merge (a (n 8)))))) +(check "lint: predicate read before write warns" 1 + (lint-count (hx-ops (hx-when (get '(flag)) (hx-merge (hit yes))) + (hx-merge (flag #t))))) +(check "lint: message names path and ops" #t + (string-prefix? "path a.n read by op merge" + (car (lint-ops (hx-ops (hx-merge (m ($ (get '(a n))))) + (hx-merge (a (n 8)))))))) + (format #t "~%example inventory: 3-region fleet (single render)~%") ;; One fold renders every region. No per-query attributes; pull each From 253c40a8762ecd4578a6e2aa564573ffa359904e Mon Sep 17 00:00:00 2001 From: Polyedre Date: Thu, 3 Sep 2026 14:00:17 +0200 Subject: [PATCH 04/12] docs: scrub the last CMDB references, point to the cmdb branch The CMDB subsystem was deleted in fc804d8 but docs/authoring.md still listed its layout and .gitignore its log. Remove both and add a README Documentation pointer to the cmdb branch where the prototype survives. --- .gitignore | 1 - README.md | 1 + docs/authoring.md | 14 -------------- 3 files changed, 1 insertion(+), 15 deletions(-) diff --git a/.gitignore b/.gitignore index 2d7be40..9d6e1e5 100644 --- a/.gitignore +++ b/.gitignore @@ -1,6 +1,5 @@ .direnv/ *.go -cmdb.log openrc *.tf.json .terraform/ diff --git a/README.md b/README.md index c8e901e..822f366 100644 --- a/README.md +++ b/README.md @@ -154,6 +154,7 @@ 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. +- The event-sourced CMDB prototype lives on the `cmdb` branch. ## License diff --git a/docs/authoring.md b/docs/authoring.md index 558f2a8..e8a2bb0 100644 --- a/docs/authoring.md +++ b/docs/authoring.md @@ -297,7 +297,6 @@ hexol/ bin/hexol # the CLI: render / tree / ops / explain / secret examples/ # one self-contained file each inventory.scm # region table + per-region body + hx-each (the engine itself) - regions.scm # the region table as an importable module (CMDB sync source) kubernetes.scm # consumer of (hexol k8s): namespaced apps + compliance demo helm-kube-prometheus-stack.scm # the Helm chart converted to (hexol k8s) ops terraform.scm # consumer of (hexol terraform): AWS + OpenStack, one combined config @@ -310,17 +309,4 @@ docs/ model.md # the fold-of-ops engine model authoring.md # this guide extending.md # building target libraries + worked examples - cmdb.md # the event-sourced CMDB (as built) -cmdb/ # the event-sourced CMDB built on the same kernel (see docs/cmdb.md) - store.scm # fact log, library lookup, refold - server.scm # HTTP front-end - json.scm # sexp -> JSON - region-render.scm # resolve the per-region body against a fact's attrs - region-body.scm # the per-region hexol inventory - apps.scm # Helm releases per region - libraries/ # versioned op vocabularies (v1, v2 — the library-bump demo) -bin/cmdb-server # boot the CMDB HTTP server -bin/sync-inventory # push a region table as facts -bin/promote # waved image/chart rollouts -test/cmdb-store.scm test/cmdb-server.scm # CMDB tests ``` From 38953616b40c3c4b93b0c19327c9dd82ae7f4a7a Mon Sep 17 00:00:00 2001 From: Polyedre Date: Thu, 3 Sep 2026 13:59:45 +0200 Subject: [PATCH 05/12] hexol doc: introspect define-construct schemas from the CLI MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit define-construct now registers each construct's schema (name, module, head, fields with required/default/flag/doc, construct doc) in (hexol construct) at definition time — one register-construct! call in the expansion, call semantics unchanged. New #:doc keyword at construct and field level. New (hexol doc) formats the registry; `hexol doc [CONSTRUCT] [-i INV]` lists every loaded construct or prints one's signature, fields table and a minimal example. k8s constructs get one-line docs. Test covers the registry. --- Makefile | 1 + README.md | 4 + bin/hexol | 30 +++++++ docs/authoring.md | 14 ++- hexol/construct.scm | 52 ++++++++++- hexol/doc.scm | 95 ++++++++++++++++++++ hexol/k8s.scm | 215 +++++++++++++++++++++++++++++++------------- test/construct.scm | 27 ++++++ 8 files changed, 371 insertions(+), 67 deletions(-) create mode 100644 hexol/doc.scm diff --git a/Makefile b/Makefile index 9b85944..6d73dba 100644 --- a/Makefile +++ b/Makefile @@ -15,6 +15,7 @@ help: @echo " ./bin/hexol explain [--query K=V,…] PATH|HASH [-i INVENTORY]" @echo " ./bin/hexol show HASH [-i INVENTORY]" @echo " ./bin/hexol lint [-i INVENTORY]" + @echo " ./bin/hexol doc [CONSTRUCT] [-i INVENTORY]" test: $(GUILE) -L . test.scm diff --git a/README.md b/README.md index 822f366..ba891a7 100644 --- a/README.md +++ b/README.md @@ -95,6 +95,10 @@ use them: `helm`/`yq` to expand charts, `sops` for inline secrets, and ./bin/hexol tree -i examples/kubernetes.scm # op tree (with hashes) ./bin/hexol show OP_HASH -i examples/kubernetes.scm # one op: source + delta ./bin/hexol explain regions.alpha5.network.cni -i examples/inventory.scm # what touched a path + +# discover the library: which (key value) entries a construct accepts +./bin/hexol doc # every construct (built-in libs) +./bin/hexol doc app -i examples/kubernetes.scm # one construct: fields + example ``` ## The Library diff --git a/bin/hexol b/bin/hexol index c75d337..827f847 100755 --- a/bin/hexol +++ b/bin/hexol @@ -55,6 +55,8 @@ (hexol terraform) (hexol secret-tool) (hexol json) + (hexol construct) + (hexol doc) (srfi srfi-1) (srfi srfi-9) (ice-9 match) @@ -780,6 +782,31 @@ (() (usage-error "show: missing HASH")) (_ (usage-error "show: want a single HASH (inventory is -i/--inventory)")))))) +;; --------------------------------------------------------------------------- +;; doc — what `(key value)` entries a define-construct accepts +;; --------------------------------------------------------------------------- +;; +;; Reads the schema registry (hexol construct) fills at definition time, so it +;; documents whatever is *loaded*: with -i (or $HEXOL_INVENTORY) the inventory +;; is loaded for its `use-modules` side effect — its own constructs included; +;; without one, the built-in libraries are. +(define (cmd-doc args) + (call-with-values (lambda () (extract-inventory "doc" args)) + (lambda (inv rest) + (let ((inv (or inv (env-inventory)))) + (if inv + (load-ops inv) + (for-each resolve-module '((hexol k8s) (hexol terraform) (hexol ansible) + (hexol sql) (hexol ledger))))) + (match rest + (() (print-construct-index)) + ((name) + (when (string-prefix? "-" name) (usage-error "doc: unknown flag ~a" name)) + (let ((found (find-constructs (string->symbol name)))) + (when (null? found) (die "doc: no construct named ~a (`hexol doc' lists them)" name)) + (for-each (lambda (s) (print-construct-doc s) (newline)) found))) + (_ (usage-error "doc: want a single CONSTRUCT (inventory is -i/--inventory)")))))) + ;; --------------------------------------------------------------------------- ;; secret — manage the inline (secrets-store …) in an inventory ;; --------------------------------------------------------------------------- @@ -911,6 +938,9 @@ The inventory comes from -i/--inventory or $HEXOL_INVENTORY.") (register-verb! (make-verb "show" (cmd-is "show") (delegating-runner cmd-show) "show HASH [-i INVENTORY]")) +(register-verb! + (make-verb "doc" (cmd-is "doc") (delegating-runner cmd-doc) + "doc [CONSTRUCT] [-i INVENTORY]")) (register-verb! (make-verb "secret" (cmd-is "secret") (delegating-runner cmd-secret) "secret … [-i INVENTORY]")) diff --git a/docs/authoring.md b/docs/authoring.md index e8a2bb0..3058111 100644 --- a/docs/authoring.md +++ b/docs/authoring.md @@ -263,6 +263,17 @@ pass db/password | hexol secret set db/password inventory.scm # seal a value f hexol secret ls inventory.scm # confirm ``` +## Discovering a library's constructs + +Every typed constructor (`deployment`, `app`, `varchar`, …) is a +`define-construct`, and its schema — positional head, fields, which are +required, their defaults, flags and one-line docs — is recorded when the +module loads. `hexol doc` prints it: `hexol doc` alone lists every construct +of the built-in libraries (name, module, one-line doc); `hexol doc app` +prints `app`'s signature, a fields table and a minimal example built from its +required fields; add `-i inventory.scm` to document whatever that inventory +loads, its own `define-construct`s included. No need to read `k8s.scm`. + ## Repository layout The engine ships as a Guile module named `hexol`; target libraries are @@ -288,13 +299,14 @@ hexol/ # transform-terraform-resources + *.tf.json emitter ledger.scm # (hexol ledger) — personal-ledger writing UX + ledger-cli render sql.scm # (hexol sql) — table/column/constraint/index DSL + SQL DDL render + doc.scm # (hexol doc) — `hexol doc`: formats the define-construct schema registry ansible.scm # (hexol ansible) — inventory.yml bridge + state helpers, task/handler # (macros over block/body) / as, `play` sink op secrets.scm # (hexol secrets) — inline sops-backed store: (secrets-store …), # (secret-ref 'k), (resolve-secret-refs) render op secret-tool.scm # (hexol secret-tool) — engine behind `hexol secret`: position-aware # reader + sops seal/decrypt + in-place form rewrite -bin/hexol # the CLI: render / tree / ops / explain / secret +bin/hexol # the CLI: render / tree / ops / explain / secret / doc examples/ # one self-contained file each inventory.scm # region table + per-region body + hx-each (the engine itself) kubernetes.scm # consumer of (hexol k8s): namespaced apps + compliance demo diff --git a/hexol/construct.scm b/hexol/construct.scm index d4cf184..68ef6f2 100644 --- a/hexol/construct.scm +++ b/hexol/construct.scm @@ -46,7 +46,37 @@ (define-module (hexol construct) #:use-module (srfi srfi-1) #:use-module (ice-9 match) - #:export (define-construct %expand-call construct-flag construct-map-entries)) + #:export (define-construct %expand-call construct-flag construct-map-entries + register-construct! construct-schemas find-constructs)) + +;; ---------- schema registry ---------- +;; +;; Every `define-construct` records its schema here at definition time (one +;; `register-construct!` call spliced into the expansion, so a construct's +;; call semantics are untouched). `hexol doc` reads it. A schema is an alist: +;; ((name . SYM) (module . (hexol k8s)) (head . (name …)) (doc . "…"|#f) +;; (fields . (FIELD …))) +;; and each FIELD an alist: ((name . SYM) (kind . plain|flag|list|map|construct) +;; (required? . BOOL) (repeated? . BOOL) (construct . SYM|#f) +;; (default . DATUM|#f) ; the #:default expression as written, or #f +;; (doc . "…"|#f)) +;; Keyed by name only loosely — the same name can live in two modules (sql's +;; `references`, k8s's `rule`), so `find-constructs` returns every match. +(define *constructs* '()) + +(define (register-construct! schema) + (set! *constructs* + (cons schema (filter (lambda (s) + (not (and (equal? (assq-ref s 'name) (assq-ref schema 'name)) + (equal? (assq-ref s 'module) (assq-ref schema 'module))))) + *constructs*)))) + +;; All registered schemas, in definition order. +(define (construct-schemas) (reverse *constructs*)) + +;; Every schema named NAME (a symbol), in definition order. +(define (find-constructs name) + (filter (lambda (s) (eq? (assq-ref s 'name) name)) (construct-schemas))) ;; Sentinel a valueless #:flag field carries: `(unique)` means `(unique #t)`. ;; Exposed so generated code can reference it. @@ -120,7 +150,9 @@ ;; #:default E value when the field is absent (else #f, or '() for list/map) ;; #:coerce P wrap the resolved value in (P …) ;; #:wire W (advisory; the builder decides output keys) +;; #:doc "…" one-line description, shown by `hexol doc` ;; +;; `#:doc "…"` at the construct level documents the construct itself. ;; #:head is one symbol or a list of positional params; #:open? #t passes ;; unknown keys through as evaluated `(k v)`/`(k a …)` attributes into the ;; `extra` local (an alist); #:build is the result expression with head params, @@ -153,6 +185,7 @@ (let* ((open? (kw-get (syntax->datum #'(kw ...)) #:open? #f)) (build (kw-syntax #'(kw ...) #:build #'(error "construct: no #:build"))) (fields-stx (stx->list (kw-syntax #'(kw ...) #:fields #'()))) + (doc (kw-get (syntax->datum #'(kw ...)) #:doc #f)) ;; head identifiers kept as original syntax (with marks) so they ;; are the *same* bindings #:build references. (head-stx (kw-syntax #'(kw ...) #:head #'())) @@ -184,12 +217,18 @@ ((flag) #'#f) ((list map) #''()) ((construct) (if rep? #''() #'#f)) (else #'#f)))) - (coerce (opt-syntax-after opts #:coerce))) + (coerce (opt-syntax-after opts #:coerce)) + (fdoc (and (has? #:doc) (syntax->datum (opt-syntax-after opts #:doc)))) + (schema `((name . ,fname) (kind . ,kind) (required? . ,req?) + (repeated? . ,rep?) (construct . ,cname) + (default . ,(and (has? #:default) + (syntax->datum (opt-syntax-after opts #:default)))) + (doc . ,fdoc)))) ;; field-id is the ORIGINAL name identifier (car parts), marks ;; intact, so it is the very binding #:build references — correct ;; even when define-construct is itself produced by another macro ;; (e.g. SQL's type sugar). - (list fname (car parts) kind cname rep? req? deflt coerce))) + (list fname (car parts) kind cname rep? req? deflt coerce schema))) (let* ((infos (map field-info fields-stx)) (fnames (map car infos)) (field-ids (map cadr infos)) @@ -205,8 +244,13 @@ (let ((fid (cadr i)) (deflt (list-ref i 6)) (coerce (list-ref i 7))) (cons #`(#,fid (if (eq? #,fid '%hx-unset) #,deflt #,fid)) (if coerce (list #`(#,fid (#,coerce #,fid))) '())))) - infos))) + infos)) + (schema `((name . ,name-sym) (head . ,head) (doc . ,doc) + (fields . ,(map (lambda (i) (list-ref i 8)) infos))))) #`(begin + (register-construct! + (cons (cons 'module (module-name (current-module))) + '#,(datum->syntax #'name schema))) (define (#,impl #,@head-ids #,@field-ids #,extra-id) (let* #,prologue #,build)) (define-syntax name diff --git a/hexol/doc.scm b/hexol/doc.scm new file mode 100644 index 0000000..ea997b7 --- /dev/null +++ b/hexol/doc.scm @@ -0,0 +1,95 @@ +;;; hexol/doc.scm — `hexol doc`: render the define-construct schema registry. +;;; +;;; Authors shouldn't have to read k8s.scm to learn which `(key value)` entries +;;; `(app …)` accepts. `define-construct` already records every construct's +;;; schema in (hexol construct)'s registry at definition time; this module only +;;; formats it: an index (one line per construct) or one construct's signature, +;;; fields table and a minimal example built from its required fields. + +(define-module (hexol doc) + #:use-module (hexol construct) + #:use-module (srfi srfi-1) + #:use-module (ice-9 format) + #:export (print-construct-index print-construct-doc)) + +;; A datum as the author wrote it: `(quote x)` back to `'x`. +(define (datum->string d) + (if (and (pair? d) (eq? (car d) 'quote) (pair? (cdr d)) (null? (cddr d))) + (string-append "'" (datum->string (cadr d))) + (format #f "~s" d))) + +(define (module->string m) (format #f "~a" m)) + +;; The "kind" column: what the field needs / how it reads. +(define (field-shape f) + (let ((kind (assq-ref f 'kind)) (default (assq-ref f 'default))) + (cond + ((assq-ref f 'required?) "required") + ((eq? kind 'flag) "flag") + ((eq? kind 'list) (if default (format #f "list, default ~a" (datum->string default)) "list")) + ((eq? kind 'map) "map") + ((eq? kind 'construct) (format #f "~a(~a …)" (if (assq-ref f 'repeated?) "repeated " "") + (assq-ref f 'construct))) + (default (format #f "default ~a" (datum->string default))) + (else "optional")))) + +;; How one entry for F reads in a call: `(image …)`, `(debug)`, `(env …)`. +(define (field-form f) + (let ((n (assq-ref f 'name))) + (case (assq-ref f 'kind) + ((flag) (format #f "(~a)" n)) + ((list) (format #f "(~a a b …)" n)) + ((map) (format #f "(~a (k v) …)" n)) + ((construct) (format #f "(~a …)" n)) + (else (format #f "(~a v)" n))))) + +(define (head-placeholders s) + (map (lambda (h) (string-upcase (symbol->string h))) (assq-ref s 'head))) + +(define (signature s) + (format #f "(~a~{ ~a~}~{ ~a~})" (assq-ref s 'name) (head-placeholders s) + (map field-form (assq-ref s 'fields)))) + +;; A minimal valid call: every head param as a placeholder, every required +;; field with a placeholder value. +(define (example s) + (format #f "(~a~{ ~a~}~{ ~a~})" (assq-ref s 'name) (head-placeholders s) + (map (lambda (f) (format #f "(~a ~a)" (assq-ref f 'name) + (string-upcase (symbol->string (assq-ref f 'name))))) + (filter (lambda (f) (assq-ref f 'required?)) (assq-ref s 'fields))))) + +(define (pad s n) (string-pad-right s (max n (string-length s)))) +(define (widest strings) (apply max 0 (map string-length strings))) + +;; One line per registered construct: name, module, one-line doc. +(define (print-construct-index) + (let* ((schemas (construct-schemas)) + (names (map (lambda (s) (symbol->string (assq-ref s 'name))) schemas)) + (mods (map (lambda (s) (module->string (assq-ref s 'module))) schemas)) + (w-name (widest names)) + (w-mod (widest mods))) + (for-each (lambda (s name mod) + (format #t "~a ~a ~a~%" (pad name w-name) (pad mod w-mod) + (or (assq-ref s 'doc) ""))) + schemas names mods))) + +;; Full doc of one schema: signature, head, fields table, example. +(define (print-construct-doc s) + (let* ((fields (assq-ref s 'fields)) + (names (map (lambda (f) (symbol->string (assq-ref f 'name))) fields)) + (shapes (map field-shape fields)) + (w-name (widest names)) + (w-shape (widest shapes))) + (format #t "~a ~a~%" (assq-ref s 'name) (module->string (assq-ref s 'module))) + (when (assq-ref s 'doc) (format #t " ~a~%" (assq-ref s 'doc))) + (format #t "~%signature:~% ~a~%" (signature s)) + (format #t "~%head (positional): ~a~%" + (if (null? (assq-ref s 'head)) "none" + (string-join (map symbol->string (assq-ref s 'head)) " "))) + (unless (null? fields) + (format #t "~%fields:~%") + (for-each (lambda (f name shape) + (format #t " ~a ~a ~a~%" (pad name w-name) (pad shape w-shape) + (or (assq-ref f 'doc) ""))) + fields names shapes)) + (format #t "~%example:~% ~a~%" (example s)))) diff --git a/hexol/k8s.scm b/hexol/k8s.scm index 9a5fff5..b7b35f6 100644 --- a/hexol/k8s.scm +++ b/hexol/k8s.scm @@ -98,7 +98,8 @@ (define-construct namespace #:head name - #:fields ((labels #:map)) + #:doc "a Namespace resource (see also with-namespace)" + #:fields ((labels #:map #:doc "extra metadata.labels")) #:build (%namespace name #:labels labels)) ;; Build-time scope over `scope-ops`; prepends the Namespace resource so @@ -267,12 +268,20 @@ alist. Each side is \"req\" or \"req-lim\"; `*' or empty omits a bound." (define-construct deployment #:head name - #:fields ((image #:required) (port #:default 8080) (replicas #:default 1) - (namespace #:default (current-k8s-namespace)) - (env #:list) (env-from #:list) (volumes #:list) - (resources #:default '()) (privileged #:flag) - (args #:list) (command #:list) - (service-account #:default #f) (labels #:map)) + #:doc "a Deployment with one container" + #:fields ((image #:required #:doc "container image ref") + (port #:default 8080 #:doc "containerPort") + (replicas #:default 1 #:doc "pod replicas") + (namespace #:default (current-k8s-namespace) #:doc "target namespace (with-namespace scope)") + (env #:list #:doc "env vars, (NAME \"value\") pairs") + (env-from #:list #:doc "envFrom sources (configmap/secret names)") + (volumes #:list #:doc "volume specs (mounted in the container)") + (resources #:default '() #:doc "requests/limits alist; `res' parses \"cpu/mem\"") + (privileged #:flag #:doc "privileged securityContext") + (args #:list #:doc "container args") + (command #:list #:doc "container command (entrypoint override)") + (service-account #:default #f #:doc "serviceAccountName") + (labels #:map #:doc "extra metadata.labels")) #:build (%deployment #:name name #:image image #:port port #:replicas replicas #:namespace namespace #:env env #:env-from env-from #:volumes volumes #:resources resources #:privileged privileged #:args args #:command command @@ -280,13 +289,24 @@ alist. Each side is \"req\" or \"req-lim\"; `*' or empty omits a bound." (define-construct daemonset #:head name - #:fields ((image #:required) (port #:default 0) - (namespace #:default (current-k8s-namespace)) - (env #:list) (env-from #:list) (volumes #:list) - (resources #:default '()) (privileged #:flag) - (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)) + #:doc "a DaemonSet with one container (one pod per node)" + #:fields ((image #:required #:doc "container image ref") + (port #:default 0 #:doc "containerPort (0: none)") + (namespace #:default (current-k8s-namespace) #:doc "target namespace (with-namespace scope)") + (env #:list #:doc "env vars, (NAME \"value\") pairs") + (env-from #:list #:doc "envFrom sources (configmap/secret names)") + (volumes #:list #:doc "volume specs (mounted in the container)") + (resources #:default '() #:doc "requests/limits alist; `res' parses \"cpu/mem\"") + (privileged #:flag #:doc "privileged securityContext") + (args #:list #:doc "container args") + (command #:list #:doc "container command (entrypoint override)") + (service-account #:default #f #:doc "serviceAccountName") + (host-network #:flag #:doc "hostNetwork: true") + (host-pid #:flag #:doc "hostPID: true") + (labels #:map #:doc "extra metadata.labels") + (capabilities #:list #:doc "securityContext.capabilities.add") + (host-port #:default #f #:doc "hostPort for the container port") + (protocol #:default #f #:doc "port protocol (TCP/UDP)")) #: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 @@ -296,9 +316,14 @@ alist. Each side is \"req\" or \"req-lim\"; `*' or empty omits a bound." (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)) + #:doc "a Service selecting app=NAME (see also expose)" + #:fields ((port #:required #:doc "service port") + (target-port #:default port #:doc "pod port (defaults to port)") + (port-name #:default "http" #:doc "port name") + (namespace #:default (current-k8s-namespace) #:doc "target namespace (with-namespace scope)") + (type #:default #f #:doc "ClusterIP/NodePort/LoadBalancer") + (selector-name #:default #f #:doc "app label to select (defaults to NAME)") + (labels #:map #:doc "extra metadata.labels")) #:build (let ((sel (or selector-name name))) (resource `((apiVersion . "v1") @@ -322,14 +347,20 @@ alist. Each side is \"req\" or \"req-lim\"; `*' or empty omits a bound." (define-construct ingress #:head name - #:fields ((port #:required) (host #:default #f) - (namespace #:default (current-k8s-namespace)) (path #:default "/") (labels #:map)) + #:doc "an Ingress routing HOST/PATH to service NAME:PORT" + #:fields ((port #:required #:doc "backend service port") + (host #:default #f #:doc "hostname (default NAME.example.com)") + (namespace #:default (current-k8s-namespace) #:doc "target namespace (with-namespace scope)") + (path #:default "/" #:doc "path prefix") + (labels #:map #:doc "extra metadata.labels")) #:build (%ingress #:name name #:port port #:host host #:namespace namespace #:path path #:labels labels)) (define-construct configmap #:head name - #:fields ((data #:map) (namespace #:default (current-k8s-namespace)) (labels #:map)) + #:doc "a ConfigMap" + #:fields ((data #:map #:doc "data entries, (key \"value\"); string keys ok (\"nginx.conf\")") + (namespace #:default (current-k8s-namespace) #:doc "target namespace (with-namespace scope)") (labels #:map #:doc "extra metadata.labels")) #:build (resource `((apiVersion . "v1") (kind . "ConfigMap") @@ -338,8 +369,12 @@ alist. Each side is \"req\" or \"req-lim\"; `*' or empty omits a bound." (define-construct secret #:head name - #:fields ((data #:map) (string-data #:map) (namespace #:default (current-k8s-namespace)) - (type #:default "Opaque") (labels #:map)) + #:doc "a Secret" + #:fields ((data #:map #:doc "base64 data entries") + (string-data #:map #:doc "plaintext stringData entries") + (namespace #:default (current-k8s-namespace) #:doc "target namespace (with-namespace scope)") + (type #:default "Opaque" #:doc "secret type") + (labels #:map #:doc "extra metadata.labels")) #:build (resource `((apiVersion . "v1") (kind . "Secret") @@ -354,9 +389,14 @@ alist. Each side is \"req\" or \"req-lim\"; `*' or empty omits a bound." (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)) + #:doc "a StorageClass (cluster-scoped)" + #:fields ((provisioner #:required #:doc "provisioner name") + (default #:flag #:doc "mark as the default class") + (volume-binding-mode #:default #f #:doc "Immediate/WaitForFirstConsumer") + (reclaim-policy #:default #f #:doc "Delete/Retain") + (allow-volume-expansion #:flag #:doc "allowVolumeExpansion: true") + (parameters #:map #:doc "provisioner parameters") + (labels #:map #:doc "extra metadata.labels")) #:build (resource `((apiVersion . "storage.k8s.io/v1") (kind . "StorageClass") @@ -372,8 +412,12 @@ alist. Each side is \"req\" or \"req-lim\"; `*' or empty omits a bound." (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)) + #:doc "a PersistentVolumeClaim" + #:fields ((size #:required #:doc "requested storage (\"10Gi\")") + (namespace #:default (current-k8s-namespace) #:doc "target namespace (with-namespace scope)") + (access-mode #:default "ReadWriteOnce" #:doc "access mode") + (storage-class #:default #f #:doc "storageClassName") + (labels #:map #:doc "extra metadata.labels")) #:build (resource `((apiVersion . "v1") (kind . "PersistentVolumeClaim") @@ -391,16 +435,22 @@ alist. Each side is \"req\" or \"req-lim\"; `*' or empty omits a bound." (define-construct custom-resource #:head name - #:fields ((api #:required) (kind #:required) - (namespace #:default (current-k8s-namespace)) - (spec #:default '()) (labels #:map)) ; spec: raw alist escape hatch + #:doc "any resource by apiVersion/kind, spec as a raw alist" + #:fields ((api #:required #:doc "apiVersion") + (kind #:required #:doc "kind") + (namespace #:default (current-k8s-namespace) #:doc "target namespace (with-namespace scope)") + (spec #:default '() #:doc "spec alist (raw escape hatch, use `body')") + (labels #:map #:doc "extra metadata.labels")) #:build (%custom-resource #:api api #:kind kind #:name name #:namespace namespace #:spec spec #:labels labels)) (define-construct service-monitor #:head name - #:fields ((port #:default "http") (path #:default "/metrics") (interval #:default "30s") - (namespace #:default (current-k8s-namespace)) (labels #:map)) + #:doc "a Prometheus ServiceMonitor scraping app=NAME" + #:fields ((port #:default "http" #:doc "service port name to scrape") + (path #:default "/metrics" #:doc "metrics path") + (interval #:default "30s" #:doc "scrape interval") + (namespace #:default (current-k8s-namespace) #:doc "target namespace (with-namespace scope)") (labels #:map #:doc "extra metadata.labels")) #:build (%custom-resource #:api "monitoring.coreos.com/v1" #:kind "ServiceMonitor" #:name name #:namespace namespace #:labels labels @@ -413,7 +463,8 @@ alist. Each side is \"req\" or \"req-lim\"; `*' or empty omits a bound." (define-construct gateway-class #:head name - #:fields ((controller-name #:required) (labels #:map)) + #:doc "a Gateway API GatewayClass (cluster-scoped)" + #:fields ((controller-name #:required #:doc "controllerName") (labels #:map #:doc "extra metadata.labels")) #:build (resource `((apiVersion . "gateway.networking.k8s.io/v1") (kind . "GatewayClass") @@ -424,8 +475,12 @@ alist. Each side is \"req\" or \"req-lim\"; `*' or empty omits a bound." ;; Secrets → a Terminate-mode tls block; absent → a plain listener. (define-construct listener #:head name - #:fields ((protocol #:default "HTTP") (port #:required) (hostname #:default #f) - (tls-certificate #:list) (allowed-routes-from #:default "All")) + #:doc "a Gateway listener (sub-construct of gateway)" + #:fields ((protocol #:default "HTTP" #:doc "HTTP/HTTPS/TCP") + (port #:required #:doc "listener port") + (hostname #:default #f #:doc "hostname to match") + (tls-certificate #:list #:doc "Secret names; sets Terminate-mode tls") + (allowed-routes-from #:default "All" #:doc "allowedRoutes.namespaces.from")) #:build (filter pair? (list (cons 'name name) (cons 'protocol protocol) @@ -441,18 +496,25 @@ alist. Each side is \"req\" or \"req-lim\"; `*' or empty omits a bound." (define-construct gateway #:head name - #:fields ((gateway-class-name #:required) (namespace #:default (current-k8s-namespace)) - (listener #:repeated #:construct listener) (labels #:map)) + #:doc "a Gateway API Gateway with listeners" + #:fields ((gateway-class-name #:required #:doc "gatewayClassName") + (namespace #:default (current-k8s-namespace) #:doc "target namespace (with-namespace scope)") + (listener #:repeated #:construct listener #:doc "one (listener NAME …) per entry") + (labels #:map #:doc "extra metadata.labels")) #: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 - #:fields ((namespace #:default (current-k8s-namespace)) - (parent-name #:required) (parent-namespace #:default #f) - (hostnames #:list) (backend-service #:required) (backend-port #:required) - (labels #:map)) + #:doc "a Gateway API HTTPRoute to one backend service" + #:fields ((namespace #:default (current-k8s-namespace) #:doc "target namespace (with-namespace scope)") + (parent-name #:required #:doc "parent Gateway name") + (parent-namespace #:default #f #:doc "parent Gateway namespace") + (hostnames #:list #:doc "hostnames to match") + (backend-service #:required #:doc "backend Service name") + (backend-port #:required #:doc "backend Service port") + (labels #:map #:doc "extra metadata.labels")) #:build (%custom-resource #:api "gateway.networking.k8s.io/v1" #:kind "HTTPRoute" #:name name #:namespace namespace #:labels labels #:spec `((parentRefs ((name . ,parent-name) @@ -470,8 +532,12 @@ alist. Each side is \"req\" or \"req-lim\"; `*' or empty omits a bound." (define-construct rule #:head () - #:fields ((api-groups #:list) (resources #:list) (non-resource-urls #:list) - (resource-names #:list) (verbs #:list)) + #:doc "an RBAC policy rule (sub-construct of role/cluster-role/cluster-rbac)" + #:fields ((api-groups #:list #:doc "apiGroups (\"\" for core)") + (resources #:list #:doc "resources") + (non-resource-urls #:list #:doc "nonResourceURLs") + (resource-names #:list #:doc "resourceNames") + (verbs #:list #:doc "verbs (get list watch …)")) #:build (filter pair? (list (and (pair? api-groups) (cons 'apiGroups api-groups)) (and (pair? resources) (cons 'resources resources)) @@ -487,13 +553,15 @@ alist. Each side is \"req\" or \"req-lim\"; `*' or empty omits a bound." (define-construct service-account #:head name - #:fields ((namespace #:default (current-k8s-namespace)) (labels #:map)) + #:doc "a ServiceAccount" + #:fields ((namespace #:default (current-k8s-namespace) #:doc "target namespace (with-namespace scope)") (labels #:map #:doc "extra metadata.labels")) #:build (%service-account #:name name #:namespace namespace #:labels labels)) (define-construct role #:head name - #:fields ((rule #:repeated #:construct rule) - (namespace #:default (current-k8s-namespace)) (labels #:map)) + #:doc "a Role from (rule …) entries" + #:fields ((rule #:repeated #:construct rule #:doc "one (rule …) per policy rule") + (namespace #:default (current-k8s-namespace) #:doc "target namespace (with-namespace scope)") (labels #:map #:doc "extra metadata.labels")) #:build (resource `((apiVersion . "rbac.authorization.k8s.io/v1") (kind . "Role") @@ -502,8 +570,12 @@ alist. Each side is \"req\" or \"req-lim\"; `*' or empty omits a bound." (define-construct role-binding #:head name - #:fields ((namespace #:default (current-k8s-namespace)) (role #:required) - (service-account #:required) (sa-namespace #:default namespace) (labels #:map)) + #:doc "a RoleBinding of a Role to a ServiceAccount" + #:fields ((namespace #:default (current-k8s-namespace) #:doc "target namespace (with-namespace scope)") + (role #:required #:doc "Role name") + (service-account #:required #:doc "ServiceAccount name") + (sa-namespace #:default namespace #:doc "ServiceAccount namespace (defaults to namespace)") + (labels #:map #:doc "extra metadata.labels")) #:build (resource `((apiVersion . "rbac.authorization.k8s.io/v1") (kind . "RoleBinding") @@ -520,7 +592,8 @@ alist. Each side is \"req\" or \"req-lim\"; `*' or empty omits a bound." (define-construct cluster-role #:head name - #:fields ((rule #:repeated #:construct rule) (labels #:map)) + #:doc "a ClusterRole from (rule …) entries" + #:fields ((rule #:repeated #:construct rule #:doc "one (rule …) per policy rule") (labels #:map #:doc "extra metadata.labels")) #:build (%cluster-role #:name name #:rules rule #:labels labels)) (define* (%cluster-role-binding #:key name role service-account @@ -534,15 +607,19 @@ alist. Each side is \"req\" or \"req-lim\"; `*' or empty omits a bound." (define-construct cluster-role-binding #:head name - #:fields ((role #:required) (service-account #:required) - (sa-namespace #:default (current-k8s-namespace)) (labels #:map)) + #:doc "a ClusterRoleBinding of a ClusterRole to a ServiceAccount" + #:fields ((role #:required #:doc "ClusterRole name") + (service-account #:required #:doc "ServiceAccount name") + (sa-namespace #:default (current-k8s-namespace) #:doc "ServiceAccount namespace") + (labels #:map #:doc "extra metadata.labels")) #:build (%cluster-role-binding #:name name #:role role #:service-account service-account #:sa-namespace sa-namespace #:labels labels)) (define-construct cluster-rbac #:head name - #:fields ((rule #:repeated #:construct rule) - (namespace #:default (current-k8s-namespace)) (labels #:map)) + #:doc "ServiceAccount + ClusterRole + ClusterRoleBinding, all named NAME" + #:fields ((rule #:repeated #:construct rule #:doc "one (rule …) per policy rule") + (namespace #:default (current-k8s-namespace) #:doc "target namespace (with-namespace scope)") (labels #:map #:doc "extra metadata.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) @@ -617,10 +694,17 @@ JSON with yq, and appends every manifest it yields to (kubernetes_resources)." (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)) + #:doc "Deployment + Service (expose) for one container" + #:fields ((image #:required #:doc "container image ref") + (port #:default 8080 #:doc "containerPort (and Service port)") + (replicas #:default 2 #:doc "pod replicas") + (namespace #:default (current-k8s-namespace) #:doc "target namespace (with-namespace scope)") + (env #:list #:doc "env vars, (NAME \"value\") pairs") + (env-from #:list #:doc "envFrom sources (configmap/secret names)") + (volumes #:list #:doc "volume specs (mounted in the container)") + (resources #:default '() #:doc "requests/limits alist; `res' parses \"cpu/mem\"") + (privileged #:flag #:doc "privileged securityContext") + (service-account #:default #f #:doc "serviceAccountName")) #:build (compose-ops 'app `(app ,name) (list (expose (%deployment #:name name #:image image #:port port #:replicas replicas @@ -630,11 +714,18 @@ JSON with yq, and appends every manifest it yields to (kubernetes_resources)." (define-construct public-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) - (host #:default #f)) + #:doc "app plus an Ingress on HOST" + #:fields ((image #:required #:doc "container image ref") + (port #:default 8080 #:doc "containerPort (and Service port)") + (replicas #:default 2 #:doc "pod replicas") + (namespace #:default (current-k8s-namespace) #:doc "target namespace (with-namespace scope)") + (env #:list #:doc "env vars, (NAME \"value\") pairs") + (env-from #:list #:doc "envFrom sources (configmap/secret names)") + (volumes #:list #:doc "volume specs (mounted in the container)") + (resources #:default '() #:doc "requests/limits alist; `res' parses \"cpu/mem\"") + (privileged #:flag #:doc "privileged securityContext") + (service-account #:default #f #:doc "serviceAccountName") + (host #:default #f #:doc "ingress hostname (default NAME.example.com)")) #:build (compose-ops 'public-app `(public-app ,name) (list (expose (%deployment #:name name #:image image #:port port #:replicas replicas diff --git a/test/construct.scm b/test/construct.scm index b3c7832..cbe71ad 100644 --- a/test/construct.scm +++ b/test/construct.scm @@ -80,6 +80,33 @@ '("z" "X" ((foo . "bar") (nums 1 2 3))) (openrec "z" (kind "X") (foo "bar") (nums 1 2 3))) +;; ---- schema registry (what `hexol doc` reads) ---- +(define-construct documented + #:head name + #:doc "a documented construct" + #:fields ((image #:required #:doc "container image") (port #:default 8080) + (debug #:flag) (tags #:list) (rule #:repeated #:construct rule)) + #:build (list name image port debug tags rule)) +(format #t "~%construct: schema registry~%") +(let ((s (car (find-constructs 'documented)))) + (check "registered under its name, with head and doc" + '((name) "a documented construct") + (list (assq-ref s 'head) (assq-ref s 'doc))) + (check "field names in definition order" + '(image port debug tags rule) + (map (lambda (f) (assq-ref f 'name)) (assq-ref s 'fields))) + (check "required / doc / default / flag / repeated construct recorded" + '((#t "container image") 8080 flag (construct #t rule)) + (let ((f (lambda (n) (find (lambda (f) (eq? (assq-ref f 'name) n)) (assq-ref s 'fields))))) + (list (list (assq-ref (f 'image) 'required?) (assq-ref (f 'image) 'doc)) + (assq-ref (f 'port) 'default) + (assq-ref (f 'debug) 'kind) + (list (assq-ref (f 'rule) 'kind) (assq-ref (f 'rule) 'repeated?) + (assq-ref (f 'rule) 'construct)))))) +(check "every construct of this file is registered, in order" + '(widget coerced rule policy sized openrec documented) + (map (lambda (s) (assq-ref s 'name)) (construct-schemas))) + (format #t "~%~a~%" (if (zero? failures) "all construct checks passed" (format #f "~a CONSTRUCT CHECK(S) FAILED" failures))) (exit (if (zero? failures) 0 1)) From 270953688e9e94b5e5aeeaddce85eec7167f4eac Mon Sep 17 00:00:00 2001 From: Polyedre Date: Thu, 3 Sep 2026 14:07:19 +0200 Subject: [PATCH 06/12] =?UTF-8?q?import:=20new=20`hexol=20import`=20verb?= =?UTF-8?q?=20=E2=80=94=20wrap=20existing=20k8s=20YAML=20/=20Terraform=20J?= =?UTF-8?q?SON?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Migration on-ramp: `hexol import -f manifests.yaml` (or `-` for stdin) emits an inventory with one `(resource '…)` per document; `--sugar` lifts Namespace/ConfigMap/Secret/Service/Deployment to the typed constructs when the candidate form, evaluated, rebuilds the object exactly. Server-populated fields of a `kubectl get` dump are stripped by default (`--no-clean` keeps). `--from terraform` reads *.tf.json into terraform-settings/-provider/ -resource/-data/-output forms (terraform-block for the rest); HCL text is out of scope. (hexol import) drives the (yaml libyaml) bindings directly because read-yaml-file reads one document from a file and drops scalar style — plain scalars get core-schema typing, quoted ones stay strings, so a ConfigMap's "8080" survives the trip. test/import.scm round-trips examples/kubernetes.scm (plain and --sugar) and examples/terraform.scm through import + render, comparing resolved state with maps order-insensitive. --- Makefile | 6 +- README.md | 10 + bin/hexol | 72 +++++++- docs/authoring.md | 43 ++++- hexol/import.scm | 457 ++++++++++++++++++++++++++++++++++++++++++++++ test/import.scm | 161 ++++++++++++++++ 6 files changed, 745 insertions(+), 4 deletions(-) create mode 100644 hexol/import.scm create mode 100644 test/import.scm diff --git a/Makefile b/Makefile index 6d73dba..e4c22f9 100644 --- a/Makefile +++ b/Makefile @@ -4,7 +4,7 @@ GUILE ?= guile help: @echo "targets:" - @echo " make test run the smoke tests (kernel, surface, res, k8s)" + @echo " make test run the smoke tests (kernel, surface, res, k8s, import)" @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" @@ -16,17 +16,19 @@ help: @echo " ./bin/hexol show HASH [-i INVENTORY]" @echo " ./bin/hexol lint [-i INVENTORY]" @echo " ./bin/hexol doc [CONSTRUCT] [-i INVENTORY]" + @echo " ./bin/hexol import -f FILE|- [--from yaml|terraform] [--sugar] [--no-clean]" test: $(GUILE) -L . test.scm $(GUILE) -L . test/construct.scm $(GUILE) -L . test/k8s-res.scm + $(GUILE) -L . test/import.scm 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) (hexol json) (hexol lint)) (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) (hexol lint) (hexol import)) (display "build ok\n"))' clean: rm -rf ~/.cache/guile/ccache/*$(CURDIR)* diff --git a/README.md b/README.md index ba891a7..46d20e0 100644 --- a/README.md +++ b/README.md @@ -101,6 +101,16 @@ use them: `helm`/`yq` to expand charts, `sops` for inline secrets, and ./bin/hexol doc app -i examples/kubernetes.scm # one construct: fields + example ``` +**Migrating.** You don't rewrite what you already have — you wrap it. +`hexol import -f manifests.yaml > app.scm` turns a k8s manifest stream (or a +`kubectl get -o yaml` dump; server-populated fields are stripped) into an +inventory with one `(resource …)` per document that renders back to the same +YAML; `--sugar` lifts objects to the typed constructs (`deployment`, +`service`, `configmap`, …) wherever they fit exactly. `hexol import -f +main.tf.json --from terraform` does the same for a Terraform JSON config +(HCL text is out of scope). From there you refactor at your own pace. See +[`docs/authoring.md`](docs/authoring.md#migrating-hexol-import). + ## The Library While the kernel is target-agnostic, the library provide a few syntaxic sugar helpers: diff --git a/bin/hexol b/bin/hexol index 827f847..45d146f 100755 --- a/bin/hexol +++ b/bin/hexol @@ -17,6 +17,8 @@ ;;; (or every path an op changed) ;;; hexol lint [-i INV] warn on $ reads that precede ;;; the write they depend on +;;; hexol import -f FILE [--from FMT] existing k8s YAML / Terraform +;;; JSON -> an inventory (stdout) ;;; ;;; Inventory is -i/--inventory (or $HEXOL_INVENTORY), never a positional. ;;; @@ -54,6 +56,7 @@ (hexol yaml) (hexol terraform) (hexol secret-tool) + (hexol import) (hexol json) (hexol construct) (hexol doc) @@ -61,7 +64,8 @@ (srfi srfi-9) (ice-9 match) (ice-9 pretty-print) - (ice-9 format)) + (ice-9 format) + (ice-9 textual-ports)) ;; --------------------------------------------------------------------------- ;; shared helpers @@ -871,6 +875,69 @@ The inventory comes from -i/--inventory or $HEXOL_INVENTORY.") (secret-error "secret ~a: wrong arguments — see usage" v) (secret-error "secret: unknown verb ~a" v)))))))))) +;; --------------------------------------------------------------------------- +;; import — existing manifests -> an inventory file (stdout) +;; --------------------------------------------------------------------------- +;; +;; hexol import -f FILE|- [--from yaml|terraform] [--sugar] [--no-clean] +;; +;; The migration on-ramp: wrap what you have, refactor later. Takes no +;; inventory — it *produces* one. --from defaults by extension (`.json` → +;; terraform, else yaml). YAML: one op per document, `resource` by default, +;; --sugar lifts exact fits to the typed constructs, --no-clean keeps the +;; server-populated fields of a `kubectl get` dump. Terraform: JSON config +;; only — HCL text is out of scope. + +(define import-usage "\ +usage: + hexol import -f FILE|- [--from yaml|terraform] [--sugar] [--no-clean] + + -f FILE|- the manifests to wrap (- reads stdin) + --from FMT yaml (k8s manifest stream) or terraform (JSON config, + *.tf.json — HCL text is NOT parsed); default by extension + --sugar lift Namespace/ConfigMap/Secret/Service/Deployment to the + typed (hexol k8s) constructs when they fit exactly + --no-clean keep status/managedFields/uid/resourceVersion/… (default: strip) + +Writes the inventory to stdout: hexol import -f app.yaml > app.scm") + +(define (cmd-import args) + (let loop ((args args) (file #f) (from #f) (sugar? #f) (clean? #t)) + (match args + (() (do-import file from sugar? clean?)) + (((or "-f" "--file") f . rest) (loop rest f from sugar? clean?)) + (("--from" f . rest) (loop rest file f sugar? clean?)) + (("--sugar" . rest) (loop rest file from #t clean?)) + (("--clean" . rest) (loop rest file from sugar? #t)) + (("--no-clean" . rest) (loop rest file from sugar? #f)) + ((arg . rest) + (cond + ((string-prefix? "--file=" arg) (loop rest (flag-value "--file=" arg) from sugar? clean?)) + ((string-prefix? "--from=" arg) (loop rest file (flag-value "--from=" arg) sugar? clean?)) + (else (format (current-error-port) "~a~%~a~%" + (e-red (format #f "import: unexpected argument ~a" arg)) + (e-dim import-usage)) + (exit 2))))))) + +(define (do-import file from sugar? clean?) + (unless file + (format (current-error-port) "~a~%~a~%" (e-red "import: missing -f FILE") (e-dim import-usage)) + (exit 2)) + (when (string-suffix? ".tf" file) + (die "import: ~a looks like HCL — only Terraform JSON config (*.tf.json) is parsed" file)) + (let* ((stdin? (string=? file "-")) + (from (or from (if (string-suffix? ".json" file) "terraform" "yaml"))) + (text (cond (stdin? (get-string-all (current-input-port))) + ((file-exists? file) (call-with-input-file file get-string-all)) + (else (die "import: no such file: ~a" file)))) + (source (if stdin? "stdin" file))) + (cond + ((string=? from "yaml") + (display (import-yaml text #:sugar? sugar? #:clean? clean? #:source source))) + ((string=? from "terraform") + (display (import-terraform-json text #:source source))) + (else (die "import: unknown --from ~s (want yaml | terraform)" from))))) + ;; --------------------------------------------------------------------------- ;; verbs — the dispatch registry ;; --------------------------------------------------------------------------- @@ -944,6 +1011,9 @@ The inventory comes from -i/--inventory or $HEXOL_INVENTORY.") (register-verb! (make-verb "secret" (cmd-is "secret") (delegating-runner cmd-secret) "secret … [-i INVENTORY]")) +(register-verb! + (make-verb "import" (cmd-is "import") (delegating-runner cmd-import) + "import -f FILE|- [--from yaml|terraform] [--sugar] [--no-clean] (→ inventory on stdout)")) ;; "|"-joined verb list for terse usage lines. (define (verb-list) (string-join (map verb-name *verbs*) "|")) diff --git a/docs/authoring.md b/docs/authoring.md index 3058111..2fb0fda 100644 --- a/docs/authoring.md +++ b/docs/authoring.md @@ -148,6 +148,45 @@ needed, since `hx-ops`/`hx-when` already flatten the returned list. See `examples/inventory.scm` for a worked split: it pulls in `examples/kubernetes.scm` via `load-inventory-file`, gated by an `hx-when`. +## Migrating: `hexol import` + +An existing deployment is the inventory's first draft. `hexol import` wraps +what you have instead of asking for a rewrite: + +```sh +./bin/hexol import -f manifests.yaml > app.scm # k8s manifest stream (or `-` for stdin) +./bin/hexol import -f main.tf.json --from terraform > infra.scm +./bin/hexol render -o yaml -i app.scm # renders back to the same objects +``` + +The YAML import emits `(use-modules (hexol k8s))` and one op per document, in +order — by default a generic `(resource '((apiVersion . "v1") (kind . …) …))` +holding the object as a quoted alist. Plain scalars are typed (`replicas: 2` +is the number 2), quoted ones stay strings (`PORT: "8080"` stays `"8080"`), +so a ConfigMap survives the trip. Fields the API server fills in on a +`kubectl get` dump — `status`, `metadata.managedFields`, `uid`, +`resourceVersion`, `creationTimestamp`, `generation`, the +last-applied-configuration annotation — are stripped; `--no-clean` keeps +them. A `kind: List` envelope is unwrapped. + +`--sugar` lifts an object to its typed construct — `namespace`, `configmap`, +`secret`, `service`, `deployment` — when the object is *exactly* what that +construct would build. The check is by construction: the candidate form is +evaluated and its resource compared to the imported object (maps +order-insensitively). Anything the construct can't express — a second +container, an extra annotation — stays a `resource`, so `--sugar` never +changes what renders; it only makes the file shorter where it can. + +The Terraform import reads JSON config (`*.tf.json`, the format `render -o +terraform` writes) and emits `terraform-settings` / `terraform-provider` / +`terraform-resource` / `terraform-data` / `terraform-output` forms, with +`terraform-block` for anything else (`variable`, `locals`, `module`). HCL +text is not parsed — there is no HCL reader here. + +Either way the result is a plain inventory. Refactor from there: pull the +repeated `resource` into a helper, gate a block with `hx-when`, replace a +verbatim alist with the construct once you're ready. + ## Ordering matters Resolution is a left fold in source order. Two consequences: @@ -294,6 +333,8 @@ hexol/ # `res` compact limits, app/public-app, # tls-all, checksum, compliance yaml.scm # (hexol yaml) — state -> YAML emitter (the k8s render back-end) + import.scm # (hexol import) — `hexol import`: k8s YAML / Terraform JSON -> + # inventory file (resource ops, --sugar lifts) terraform.scm # (hexol terraform)— terraform-resource/-provider/-settings/-output # (macros w/ block/ref body), tf-ref/tf-output, # transform-terraform-resources + *.tf.json emitter @@ -306,7 +347,7 @@ hexol/ # (secret-ref 'k), (resolve-secret-refs) render op secret-tool.scm # (hexol secret-tool) — engine behind `hexol secret`: position-aware # reader + sops seal/decrypt + in-place form rewrite -bin/hexol # the CLI: render / tree / ops / explain / secret / doc +bin/hexol # the CLI: render / tree / ops / explain / secret / doc / lint / import examples/ # one self-contained file each inventory.scm # region table + per-region body + hx-each (the engine itself) kubernetes.scm # consumer of (hexol k8s): namespaced apps + compliance demo diff --git a/hexol/import.scm b/hexol/import.scm new file mode 100644 index 0000000..c66b54b --- /dev/null +++ b/hexol/import.scm @@ -0,0 +1,457 @@ +;;; hexol/import.scm — `hexol import`: existing manifests -> a hexol inventory. +;;; +;;; Lowers the migration cost from "rewrite" to "wrap": feed what you already +;;; have and get a Scheme inventory file back, one op per object, that renders +;;; to the same thing. From there you refactor at your own pace — pull a +;;; repeated `resource` into a helper, swap a `(resource …)` for its typed +;;; construct, gate a block with `hx-when`. +;;; +;;; (import-yaml text #:sugar? #:clean? #:source) k8s manifest stream +;;; (import-terraform-json text #:source) Terraform JSON config +;;; +;;; Both return the inventory file as a string (`(use-modules …)` + `(hx-ops +;;; …)`), documents in input order. +;;; +;;; YAML: the (yaml) module's `read-yaml-file` reads one document, from a +;;; file, and drops scalar style — so `"true"` and `true` come back the same +;;; string. Manifests need all three (multi-doc streams, stdin, and a +;;; ConfigMap's `"256"` staying a string while `replicas: 2` becomes a +;;; number), so `read-yaml-documents` drives the same (yaml libyaml) bindings +;;; directly: plain scalars get YAML core-schema typing, quoted/block scalars +;;; stay strings. Values land in the (hexol yaml) model — symbol-keyed alists +;;; for maps, lists for sequences, string/number/boolean leaves — which is +;;; what `resource` consumes and `hexol render -o yaml` emits. +;;; +;;; `--sugar` lifts an object to its typed (hexol k8s) construct (namespace / +;;; configmap / secret / service / deployment) when the object is exactly what +;;; that construct would build: the candidate form is *evaluated* and its +;;; resource compared (maps order-insensitively) to the imported object; +;;; anything else — an extra annotation, a second container — stays a +;;; `resource`. So sugar never changes what renders. +;;; +;;; Terraform: JSON config only (`*.tf.json`, what `render -o terraform` +;;; emits). HCL text is out of scope — there is no HCL parser here. + +(define-module (hexol import) + #:use-module (hexol kernel) + #:use-module ((hexol yaml) #:select (object-shape?)) + #:autoload (hexol k8s) (res) + #:use-module (yaml libyaml) + #:use-module (system ffi-help-rt) + #:use-module (bytestructures guile) + #:use-module ((system foreign) #:prefix ffi:) + #:use-module (rnrs bytevectors) + #:use-module (json) + #:use-module (srfi srfi-1) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (ice-9 pretty-print) + #:use-module (ice-9 format) + #:export (read-yaml-documents clean-k8s-object + k8s-object->form terraform-config->forms + import-yaml import-terraform-json + same-shape?)) + +;; --------------------------------------------------------------------------- +;; YAML reader — multi-document, style-aware +;; --------------------------------------------------------------------------- + +;; Plain-scalar typing (YAML 1.2 core schema, plus the 1.1 spellings k8s +;; tooling still emits). Quoted scalars never reach this. +(define number-rx + (make-regexp "^[-+]?([0-9]+\\.?[0-9]*|\\.[0-9]+)([eE][-+]?[0-9]+)?$")) + +(define (plain-scalar->scm s) + (cond + ((member s '("" "~" "null" "Null" "NULL")) 'null) + ((member s '("true" "True" "TRUE")) #t) + ((member s '("false" "False" "FALSE")) #f) + ((regexp-exec number-rx s) (string->number s)) + (else s))) + +;; libyaml node -> (hexol yaml) value. Mappings become symbol-keyed alists +;; in source order; a `null` value drops its key (there is no null in the +;; state model — an absent key renders the same as YAML's absence). Sequences +;; become lists; a null item becomes '() (renders `{}`). +(define (convert-tree root stack) + (define (scalar node) + (let ((style (wrap-yaml_scalar_style_t (bytestructure-ref node 'data 'scalar 'style))) + (text (ffi:pointer->string + (ffi:make-pointer (bytestructure-ref node 'data 'scalar 'value))))) + (if (eq? style 'YAML_PLAIN_SCALAR_STYLE) (plain-scalar->scm text) text))) + ;; Walk a libyaml stack (items or pairs) from TOP back to START, SIZE bytes + ;; per slot, collecting (f slot-address) in order. + (define (slots start top size f) + (let loop ((acc '()) (addr (- top size))) + (if (>= addr start) + (loop (cons (f addr) acc) (- addr size)) + acc))) + (define (node-at index) (bytestructure-ref stack (1- index))) + (define (convert node) + (case (wrap-yaml_node_type_t (bytestructure-ref node 'type)) + ((YAML_SCALAR_NODE) (scalar node)) + ((YAML_SEQUENCE_NODE) + (map (lambda (v) (if (eq? v 'null) '() v)) + (slots (bytestructure-ref node 'data 'sequence 'items 'start) + (bytestructure-ref node 'data 'sequence 'items 'top) + (bytestructure-descriptor-size yaml_node_item_t-desc) + (lambda (addr) + (convert (node-at (bytestructure-ref (bytestructure int*-desc addr) '*))))))) + ((YAML_MAPPING_NODE) + (filter-map + (lambda (kv) (and (not (eq? (cdr kv) 'null)) kv)) + (slots (bytestructure-ref node 'data 'mapping 'pairs 'start) + (bytestructure-ref node 'data 'mapping 'pairs 'top) + (bytestructure-descriptor-size yaml_node_pair_t-desc) + (lambda (addr) + (let ((pair (bytestructure yaml_node_pair_t*-desc addr))) + (cons (string->symbol + (let ((k (convert (node-at (bytestructure-ref pair '* 'key))))) + (if (string? k) k (format #f "~a" k)))) + (convert (node-at (bytestructure-ref pair '* 'value))))))))) + (else (error "yaml: unexpected node type")))) + (convert root)) + +(define (read-yaml-documents text) + "Parse TEXT, a YAML stream, into a list of documents in stream order. +Maps are symbol-keyed alists, sequences lists; plain scalars are typed +(number / boolean), quoted and block scalars stay strings." + (let* ((parser (make-yaml_parser_t)) + (&parser (pointer-to parser)) + (bv (string->utf8 text))) + (yaml_parser_initialize &parser) + (yaml_parser_set_input_string &parser (ffi:bytevector->pointer bv) (bytevector-length bv)) + (let loop ((docs '())) + (let* ((document (make-yaml_document_t)) + (&document (pointer-to document))) + (when (zero? (yaml_parser_load &parser &document)) + (let ((problem (fh-object-ref parser 'problem)) + (line (fh-object-ref parser 'problem_mark 'line))) + (yaml_parser_delete &parser) + (error (format #f "yaml: line ~a: ~a" (1+ line) + (if (zero? problem) "parse error" + (ffi:pointer->string (ffi:make-pointer problem))))))) + (let ((root (yaml_document_get_root_node &document))) + (if (zero? (fh-object-ref root)) ; NULL root: end of stream + (begin (yaml_document_delete &document) + (yaml_parser_delete &parser) + (reverse docs)) + (let* ((stack (bytestructure yaml_node_t*-desc + (fh-object-ref document 'nodes 'start))) + (tree (convert-tree (fh-object-val root) stack))) + (yaml_document_delete &document) + (loop (cons tree docs))))))))) + +;; --------------------------------------------------------------------------- +;; alist helpers +;; --------------------------------------------------------------------------- + +;; Nested lookup; #f when any step is missing or not a map. +(define (ref obj . keys) + (let loop ((obj obj) (keys keys)) + (cond ((null? keys) obj) + ((and (object-shape? obj) (assq (car keys) obj)) + => (lambda (e) (loop (cdr e) (cdr keys)))) + (else #f)))) + +(define (without alist . keys) + (remove (lambda (e) (memq (car e) keys)) alist)) + +(define (same-shape? a b) + "Structural equality where maps compare order-insensitively (sequences +stay ordered) and a symbol equals the string of its name." + (cond + ((and (object-shape? a) (object-shape? b)) + (and (= (length a) (length b)) + (every (lambda (e) + (let ((o (assq (car e) b))) + (and o (same-shape? (cdr e) (cdr o))))) + a))) + ((and (pair? a) (pair? b)) + (and (= (length a) (length b)) (every same-shape? a b))) + ((and (symbol? a) (string? b)) (string=? (symbol->string a) b)) + ((and (string? a) (symbol? b)) (string=? a (symbol->string b))) + (else (equal? a b)))) + +;; --------------------------------------------------------------------------- +;; k8s: cleaning and the generic form +;; --------------------------------------------------------------------------- + +;; Server-populated fields a `kubectl get -o yaml` dump carries; none belong +;; in a manifest you apply. A `kind: List` wrapper is unwrapped by the caller. +(define runtime-metadata + '(managedFields uid resourceVersion creationTimestamp generation selfLink)) + +(define (clean-k8s-object obj) + "Strip status, managedFields and the other server-populated metadata +(uid, resourceVersion, creationTimestamp, generation, selfLink, the +last-applied-configuration annotation) from a k8s object alist." + (map (lambda (e) + (if (eq? (car e) 'metadata) + (cons 'metadata + (filter-map + (lambda (m) + (if (eq? (car m) 'annotations) + (let ((kept (without (cdr m) 'kubectl.kubernetes.io/last-applied-configuration))) + (and (pair? kept) (cons 'annotations kept))) + m)) + (apply without (cdr e) runtime-metadata))) + e)) + (without obj 'status))) + +;; kubectl's `kind: List` envelope holds the real objects under `items`. +(define (unwrap-list doc) + (if (and (equal? (ref doc 'kind) "List") (list? (ref doc 'items))) + (ref doc 'items) + (list doc))) + +(define (resource-form obj) `(resource ',obj)) + +;; --------------------------------------------------------------------------- +;; k8s: sugar — lift to a typed construct when it rebuilds the same object +;; --------------------------------------------------------------------------- + +;; A map-field key: the bare symbol when it reads back as itself, else the +;; string form (construct-map-entries accepts both). +(define (map-key sym) + (let ((name (symbol->string sym))) + (if (string=? (object->string sym) name) sym name))) + +(define (map-entries alist) + (map (lambda (e) (list (map-key (car e)) (cdr e))) alist)) + +;; `(labels …)` for the labels beyond the construct's own `app`/name label. +(define (extra-labels obj own) + (let ((extra (apply without (or (ref obj 'metadata 'labels) '()) own))) + (if (null? extra) '() `((labels ,@(map-entries extra)))))) + +(define (opt key val default) + (if (equal? val default) '() `((,key ,val)))) + +;; envFrom entry -> (cm "n") / (sec "n"); #f when it is anything else. +(define (env-from-form e) + (cond ((ref e 'configMapRef 'name) => (lambda (n) `(cm ,n))) + ((ref e 'secretRef 'name) => (lambda (n) `(sec ,n))) + (else #f))) + +;; (volumeMount . volume) -> (mount "/path" [#:read-only #t]). +(define (mount-form vm vol) + (let ((source (cond ((ref vol 'secret 'secretName) => (lambda (n) `(sec ,n))) + ((ref vol 'configMap 'name) => (lambda (n) `(cm ,n))) + ((ref vol 'persistentVolumeClaim 'claimName) => (lambda (n) `(pvc ,n))) + ((ref vol 'hostPath 'path) => (lambda (p) `(host-path ,p))) + (else #f)))) + (and source (equal? (ref vm 'name) (ref vol 'name)) + `(mount ,source ,(ref vm 'mountPath) + ,@(if (ref vm 'readOnly) '(#:read-only #t) '()))))) + +;; The compact "cpu/mem" spec when `res` parses it back to RESOURCES; else +;; the alist itself, quoted. +(define (resources-field resources) + (let* ((side (lambda (k) (cons (ref resources 'requests k) (ref resources 'limits k)))) + (cpu (side 'cpu)) + (mem (side 'memory)) + (bound (lambda (b single-means-lim?) + (match b + ((#f . #f) "*") + ((r . #f) (if single-means-lim? (string-append r "-*") r)) + ((#f . l) (string-append "*-" l)) + ((r . l) (if (and single-means-lim? (equal? r l)) r + (string-append r "-" l)))))) + (spec (let ((c (bound cpu #f)) (m (bound mem #t))) + (if (string=? m "*") c (string-append c "/" m))))) + (if (same-shape? (res spec) resources) spec `',resources))) + +;; Candidate construct form for OBJ, or #f when the kind has no construct or +;; the object is structurally out of reach (several containers, an envFrom +;; that isn't a ConfigMap/Secret …). Verified by `lifted` before use. +(define (candidate-form obj) + (let* ((kind (ref obj 'kind)) + (name (ref obj 'metadata 'name)) + (ns (ref obj 'metadata 'namespace)) + (namespaced (lambda (forms) ; the constructs always emit one + (and ns `(,@forms (namespace ,ns)))))) + (and + (string? name) + (match kind + ("Namespace" + `(namespace ,name + ,@(extra-labels obj '(kubernetes.io/metadata.name)))) + ("ConfigMap" + (namespaced + `(configmap ,name + ,@(let ((d (ref obj 'data))) (if (pair? d) `((data ,@(map-entries d))) '())) + ,@(extra-labels obj '(app))))) + ("Secret" + (namespaced + `(secret ,name + ,@(opt 'type (ref obj 'type) "Opaque") + ,@(let ((d (ref obj 'data))) (if (pair? d) `((data ,@(map-entries d))) '())) + ,@(let ((d (ref obj 'stringData))) (if (pair? d) `((string-data ,@(map-entries d))) '())) + ,@(extra-labels obj '(app))))) + ("Service" + (let* ((ports (ref obj 'spec 'ports)) + (p (and (pair? ports) (null? (cdr ports)) (car ports))) + (sel (ref obj 'spec 'selector 'app))) + (and p sel + (namespaced + `(service ,name + (port ,(ref p 'port)) + ,@(opt 'target-port (ref p 'targetPort) (ref p 'port)) + ,@(opt 'port-name (ref p 'name) "http") + ,@(opt 'type (ref obj 'spec 'type) #f) + ,@(opt 'selector-name sel name) + ,@(extra-labels obj '(app))))))) + ("Deployment" + (let* ((pod (ref obj 'spec 'template 'spec)) + (cs (ref pod 'containers)) + (c (and (pair? cs) (null? (cdr cs)) (car cs))) + (ports (ref c 'ports)) + (port (if (pair? ports) (ref (car ports) 'containerPort) 0)) + (env-from (map env-from-form (or (ref c 'envFrom) '()))) + (mounts (or (ref c 'volumeMounts) '())) + (vols (or (ref pod 'volumes) '())) + (mounts (if (= (length mounts) (length vols)) + (map mount-form mounts vols) + '(#f))) + (list-field (lambda (key val) (if (pair? val) `((,key ,@val)) '())))) + (and c (every identity env-from) (every identity mounts) + (namespaced + `(deployment ,name + (image ,(ref c 'image)) + ,@(opt 'port port 8080) + ,@(opt 'replicas (ref obj 'spec 'replicas) 1) + ,@(opt 'service-account (ref pod 'serviceAccountName) #f) + ,@(list-field 'command (ref c 'command)) + ,@(list-field 'args (ref c 'args)) + ,@(list-field 'env (map (lambda (e) `',e) (or (ref c 'env) '()))) + ,@(list-field 'env-from env-from) + ,@(list-field 'volumes mounts) + ,@(let ((r (ref c 'resources))) + (if (pair? r) `((resources ,(resources-field r))) '())) + ,@(if (eq? (ref c 'securityContext 'privileged) #t) '((privileged)) '()) + ,@(extra-labels obj '(app))))))) + (_ #f))))) + +;; Evaluate a construct FORM as an inventory would and return the resource +;; it appends — the ground truth for "fits exactly". +(define (form->resource form) + (let ((m (make-fresh-user-module))) + (module-use! m (resolve-interface '(hexol k8s))) + (let ((op (eval form m))) + (car (state-get (resolve (list op) '()) '(kubernetes_resources)))))) + +(define (lifted obj) + (let ((form (candidate-form obj))) + (and form + (same-shape? (form->resource form) obj) + form))) + +(define* (k8s-object->form obj #:key sugar?) + "The op form for one k8s object alist: its typed construct when SUGAR? and +the construct rebuilds OBJ exactly, else `(resource ')`." + (or (and sugar? (lifted obj)) + (resource-form obj))) + +;; --------------------------------------------------------------------------- +;; Terraform JSON config -> block forms +;; --------------------------------------------------------------------------- + +;; guile-json hands objects back as alists in reverse key order and arrays as +;; vectors. Restore order and make arrays lists; drop nulls (unset). +(define (json->scm v) + (cond + ((vector? v) (map json->scm (vector->list v))) + ((and (pair? v) (every pair? v)) + (filter-map (lambda (e) (and (not (eq? (cdr e) 'null)) + (cons (string->symbol (car e)) (json->scm (cdr e))))) + (reverse v))) + (else v))) + +;; One `body` entry per attribute: a nested object is a `(block k …)`, a list +;; of scalars `(k (list …))`, anything else a quoted datum. +(define (body-entries alist) + (map (lambda (e) + (let ((k (car e)) (v (cdr e))) + (cond ((object-shape? v) `(block ,k ,@(body-entries v))) + ((and (pair? v) (every (lambda (x) (not (pair? x))) v)) `(,k (list ,@v))) + ((pair? v) `(,k ',v)) + (else `(,k ,v))))) + alist)) + +;; How many labels each top-level keyword carries in the JSON object model. +(define (label-depth keyword) + (case keyword + ((resource data) 2) + ((provider output variable module) 1) + (else 0))) + +;; The construct for a block: the named macro where (hexol terraform) has +;; one, else the `terraform-block` escape hatch with labels as a list. +(define (block-form keyword labels body) + (let ((entries (body-entries body))) + (match (cons keyword labels) + (('terraform) `(terraform-settings ,@entries)) + (('provider n) `(terraform-provider ,n ,@entries)) + (('resource t n) `(terraform-resource ,t ,n ,@entries)) + (('data t n) `(terraform-data ,t ,n ,@entries)) + (('output n) `(terraform-output ,n ,@entries)) + (_ `(terraform-block ,(symbol->string keyword) ',labels ,@entries))))) + +;; Walk DEPTH label levels under KEYWORD; a body that is a list (provider +;; aliases, repeated blocks) yields one form per element. +(define (block-forms keyword labels depth v) + (cond + ((and (> depth 0) (object-shape? v)) + (append-map (lambda (e) + (block-forms keyword (append labels (list (symbol->string (car e)))) + (1- depth) (cdr e))) + v)) + ((object-shape? v) (list (block-form keyword labels v))) + ((null? v) (list (block-form keyword labels '()))) + ((pair? v) (append-map (lambda (b) (block-forms keyword labels 0 b)) v)) + (else (error "terraform import: unexpected value under" keyword labels)))) + +(define (terraform-config->forms text) + "Parse TEXT, a Terraform JSON config, into (hexol terraform) block forms in +source order." + (let ((config (json->scm (json-string->scm text)))) + (append-map (lambda (e) + (block-forms (car e) '() (label-depth (car e)) (cdr e))) + config))) + +;; --------------------------------------------------------------------------- +;; file assembly +;; --------------------------------------------------------------------------- + +(define (inventory-text header module forms) + (call-with-output-string + (lambda (port) + (format port ";;; ~a~%~%(use-modules ~s)~%~%(hx-ops~%" header module) + (let loop ((fs forms)) + (let ((text (call-with-output-string + (lambda (p) (pretty-print (car fs) p #:per-line-prefix " "))))) + (if (null? (cdr fs)) + (format port "~a)~%" (string-trim-right text)) + (begin (display text port) (newline port) (loop (cdr fs))))))))) + +(define* (import-yaml text #:key sugar? (clean? #t) (source "stdin")) + "Return a hexol inventory file (as a string) equivalent to the k8s manifest +stream TEXT: one op per document, in order. CLEAN? strips server-populated +fields; SUGAR? lifts objects to typed constructs where they fit exactly." + (let* ((objs (append-map unwrap-list (read-yaml-documents text))) + (objs (if clean? (map clean-k8s-object objs) objs)) + (forms (map (lambda (o) (k8s-object->form o #:sugar? sugar?)) objs))) + (when (null? forms) (error "import: no documents in" source)) + (inventory-text (format #f "imported by `hexol import` from ~a — ~a object~p" + source (length forms) (length forms)) + '(hexol k8s) forms))) + +(define* (import-terraform-json text #:key (source "stdin")) + "Return a hexol inventory file (as a string) equivalent to the Terraform +JSON config TEXT: one op per block, in order." + (let ((forms (terraform-config->forms text))) + (when (null? forms) (error "import: no blocks in" source)) + (inventory-text (format #f "imported by `hexol import --from terraform` from ~a — ~a block~p" + source (length forms) (length forms)) + '(hexol terraform) forms))) diff --git a/test/import.scm b/test/import.scm new file mode 100644 index 0000000..63e1b53 --- /dev/null +++ b/test/import.scm @@ -0,0 +1,161 @@ +;;; test/import.scm — round-trip tests for `hexol import` ((hexol import)). +;;; Run: guile -L . test/import.scm (or `make test`) +;;; +;;; An imported inventory must render to what it was imported from: +;;; examples/kubernetes.scm -> yaml -> import (plain and --sugar) -> resolve +;;; examples/terraform.scm -> tf.json -> import -> resolve +;;; and the resolved accumulators compare equal with maps order-insensitive +;;; (`same-shape?`) — key order is not semantics in YAML or JSON. + +(add-to-load-path (dirname (dirname (current-filename)))) + +(use-modules (hexol kernel) + (hexol yaml) + (hexol terraform) + (hexol import) + (ice-9 format) + (ice-9 textual-ports)) + +(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))))))) + +;; Write TEXT to a fresh temp file, return its path. +(define (temp-file text suffix) + (let* ((port (mkstemp (string-append (or (getenv "TMPDIR") "/tmp") "/hexol-import-XXXXXX"))) + (tmp (port-filename port)) + (path (string-append tmp suffix))) + (display text port) + (close-port port) + (rename-file tmp path) + path)) + +;; Import TEXT with IMPORT (a text -> inventory-text proc), load the result as +;; an inventory and return the resolved state. +(define (round-trip import text) + (let* ((path (temp-file (import text) ".scm")) + (state (resolve (load-inventory-file path) '()))) + (delete-file path) + state)) + +(define (resolve-example file) + (resolve (load-inventory-file file) '())) + +;; ---------- k8s ---------- + +(format #t "~%import: k8s manifests round-trip~%") + +(define k8s-state (resolve-example "examples/kubernetes.scm")) +(define k8s-resources (state-get k8s-state '(kubernetes_resources))) +(define k8s-yaml + (call-with-output-string (lambda (p) (emit-yaml-stream p k8s-resources)))) + +(define (k8s-back . opts) + (state-get (round-trip (lambda (t) (apply import-yaml t opts)) k8s-yaml) + '(kubernetes_resources))) + +(check "yaml documents parsed = resources rendered" + (length k8s-resources) (length (read-yaml-documents k8s-yaml))) +(check "plain import resolves to the same resources" + #t (same-shape? k8s-resources (k8s-back))) +(check "--sugar import resolves to the same resources" + #t (same-shape? k8s-resources (k8s-back #:sugar? #t))) +(check "--sugar lifts exact fits to typed constructs" + #t (and (string-contains (import-yaml k8s-yaml #:sugar? #t) "(configmap") #t)) +(check "document order preserved" + (map (lambda (r) (assq-ref r 'kind)) k8s-resources) + (map (lambda (r) (assq-ref r 'kind)) (k8s-back))) + +;; A workload the constructs built verbatim lifts back to them — every +;; deployment field the lift handles, and a non-default Service. +(define lift-inventory + (temp-file "(use-modules (hexol k8s)) +(hx-ops + (with-namespace \"api\" + (deployment \"api\" (image \"ghcr.io/acme/api:1\") (port 9090) (replicas 3) + (service-account \"api\") (args \"--verbose\") (privileged) + (env '((name . \"MODE\") (value . \"prod\"))) + (env-from (cm \"api-config\") (sec \"api-secret\")) + (volumes (mount (sec \"api-tls\") \"/etc/tls\" #:read-only #t) (mount (pvc \"data\") \"/data\")) + (resources \"100m-500m/128Mi\") (labels (tier \"web\"))) + (service \"api\" (port 80) (target-port 9090) (port-name \"web\") (type \"NodePort\")) + (secret \"api-tls\" (type \"kubernetes.io/tls\") (string-data (tls.crt \"x\")))))" + ".scm")) +(define lift-resources (state-get (resolve-example lift-inventory) '(kubernetes_resources))) +(delete-file lift-inventory) +(define lift-yaml (call-with-output-string (lambda (p) (emit-yaml-stream p lift-resources)))) +(define lifted-text (import-yaml lift-yaml #:sugar? #t)) +;; (pretty-print may break the head and name onto separate lines.) +(check "--sugar lifts a construct-built Deployment" + #t (and (string-contains lifted-text "(deployment") #t)) +(check "--sugar lifts a non-default Service and a tls Secret" + #t (and (string-contains lifted-text "(service") + (string-contains lifted-text "(secret") #t)) +(check "--sugar keeps no `resource` fallback when everything fits" + #f (string-contains lifted-text "(resource\n")) +(check "lifted inventory resolves to the same resources" + #t (same-shape? lift-resources + (state-get (round-trip (lambda (t) (import-yaml t #:sugar? #t)) lift-yaml) + '(kubernetes_resources)))) + +;; Scalar typing: quoted strings stay strings, plain scalars get typed. +(define typed + (car (read-yaml-documents + "apiVersion: v1\nkind: ConfigMap\nmetadata:\n name: c\ndata:\n PORT: \"8080\"\n ON: 'true'\nreplicas: 3\nflag: true\nnothing: null\n"))) +(check "quoted number stays a string" "8080" (state-get typed '(data PORT))) +(check "quoted bool stays a string" "true" (state-get typed '(data ON))) +(check "plain integer is a number" 3 (state-get typed '(replicas))) +(check "plain bool is a boolean" #t (state-get typed '(flag))) +(check "null-valued key is dropped" #f (assq 'nothing typed)) + +;; --clean strips the server-populated fields of a `kubectl get` dump. +(define dumped + '((apiVersion . "v1") (kind . "ConfigMap") + (metadata (name . "c") (uid . "abc") (resourceVersion . "12") (creationTimestamp . "t") + (managedFields ((manager . "kubectl"))) + (annotations (kubectl.kubernetes.io/last-applied-configuration . "{}"))) + (data (K . "v")) + (status (phase . "x")))) +(check "clean strips runtime metadata and status" + '((apiVersion . "v1") (kind . "ConfigMap") (metadata (name . "c")) (data (K . "v"))) + (clean-k8s-object dumped)) + +;; ---------- terraform ---------- + +(format #t "~%import: terraform JSON round-trip~%") + +;; examples/terraform.scm reads ~/.ssh/*.pub at load; give it one if the +;; environment has none (CI). +(let ((home (or (getenv "HOME") "."))) + (unless (or (file-exists? (string-append home "/.ssh/id_ed25519.pub")) + (file-exists? (string-append home "/.ssh/id_rsa.pub"))) + (let ((fake (string-append (or (getenv "TMPDIR") "/tmp") "/hexol-import-home"))) + (system* "mkdir" "-p" (string-append fake "/.ssh")) + (call-with-output-file (string-append fake "/.ssh/id_ed25519.pub") + (lambda (p) (display "ssh-ed25519 AAAA test\n" p))) + (setenv "HOME" fake)))) + +(define tf-config (state-get (resolve-example "examples/terraform.scm") '(terraform_config))) +(define tf-back + (state-get (round-trip (lambda (t) (import-terraform-json t)) (terraform->json tf-config)) + '(terraform_config))) + +(check "terraform import resolves to the same config" + #t (same-shape? tf-config tf-back)) +(check "terraform blocks keep their kind" + (map car tf-config) (map car tf-back)) + +(format #t "~%~a~%" + (if (zero? failures) + "all checks passed" + (format #f "~a failure(s)" failures))) +(exit (if (zero? failures) 0 1)) From fd28d9bd71b6c697fc0fef5a52ff46ea58ada8d5 Mon Sep 17 00:00:00 2001 From: Polyedre Date: Thu, 3 Sep 2026 14:33:01 +0200 Subject: [PATCH 07/12] apply: applier mode (apply|plan|diff), `hexol diff [--explain]`, `render --validate` MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Applier signature becomes (state mode -> effects), mode ∈ apply | plan | diff; the old dry? boolean still works (#t → plan, #f → apply, via `mode-of`). terraform: plan/diff → `plan -detailed-exitcode` (2 = drift); kubectl: plan → --dry-run=server, diff → `kubectl diff -f -` (1 = drift); talos config-apply accepts --diff as --dry-run. wait-for/check skip under plan/diff. New `hexol diff [--only SPEC] [--explain]`: same pipeline as apply in mode diff, exit 0 clean / 1 drift / 2 error. --explain binds current-diff-explainer over the resolve trace; the kubectl applier then fetches each live object (`kubectl get -o json`), structural-diffs it against the rendered alist (new hexol/diff.scm) and prints per changed path the value change and the op that set it (label + file:line). Terraform streams its plan as-is. `hexol render -o yaml --validate` pipes the stream through kubeconform -strict -summary when on PATH (report on stderr, exit with its status); `kubeconform-check` is the same as an appliers-pipeline check. Tests: test/apply-mode.scm (mode dispatch against PATH shims in test/fixtures/bin, structural differ) and test/diff-cli.sh (exit codes, --explain output); both wired into `make test`. --- Makefile | 4 + README.md | 3 + bin/hexol | 148 ++++++++++++++---- docs/extending.md | 14 ++ examples/kubernetes.scm | 4 +- hexol/apply.scm | 275 +++++++++++++++++++++++++--------- hexol/diff.scm | 61 ++++++++ hexol/kernel.scm | 14 +- test/apply-mode.scm | 209 ++++++++++++++++++++++++++ test/diff-cli.sh | 45 ++++++ test/fixtures/bin/kubeconform | 6 + test/fixtures/bin/kubectl | 16 ++ test/fixtures/bin/tofu | 12 ++ 13 files changed, 707 insertions(+), 104 deletions(-) create mode 100644 hexol/diff.scm create mode 100644 test/apply-mode.scm create mode 100755 test/diff-cli.sh create mode 100755 test/fixtures/bin/kubeconform create mode 100755 test/fixtures/bin/kubectl create mode 100755 test/fixtures/bin/tofu diff --git a/Makefile b/Makefile index e4c22f9..32fa682 100644 --- a/Makefile +++ b/Makefile @@ -11,6 +11,8 @@ help: @echo @echo "everything else is the CLI — ./bin/hexol --help:" @echo " ./bin/hexol render [-o sexp|json|yaml|terraform|ansible] [--query K=V,…] [--path P] [-i INVENTORY]" + @echo " ./bin/hexol apply [--only SPEC] [--dry-run] [--list] [-i INVENTORY]" + @echo " ./bin/hexol diff [--only SPEC] [--explain] [-i INVENTORY]" @echo " ./bin/hexol tree [-i INVENTORY]" @echo " ./bin/hexol explain [--query K=V,…] PATH|HASH [-i INVENTORY]" @echo " ./bin/hexol show HASH [-i INVENTORY]" @@ -23,6 +25,8 @@ test: $(GUILE) -L . test/construct.scm $(GUILE) -L . test/k8s-res.scm $(GUILE) -L . test/import.scm + $(GUILE) -L . test/apply-mode.scm + GUILE=$(GUILE) ./test/diff-cli.sh test-examples: GUILE=$(GUILE) ./test/examples.sh diff --git a/README.md b/README.md index 46d20e0..875437f 100644 --- a/README.md +++ b/README.md @@ -90,6 +90,9 @@ use them: `helm`/`yq` to expand charts, `sops` for inline secrets, and # act on it (appliers an inventory registers via `applies-with`) ./bin/hexol apply --list -i examples/kubernetes.scm # show the applier pipeline ./bin/hexol apply --dry-run -i examples/kubernetes.scm # delegate to each tool's dry-run +./bin/hexol diff -i examples/kubernetes.scm # drift vs the world: exit 0 clean, 1 drift, 2 error +./bin/hexol diff --explain -i examples/kubernetes.scm # each changed field + the op that set it (kubectl) +./bin/hexol render -o yaml --validate -i examples/kubernetes.scm # pipe the stream through kubeconform (if on PATH) # introspect: rendering is not opaque ./bin/hexol tree -i examples/kubernetes.scm # op tree (with hashes) diff --git a/bin/hexol b/bin/hexol index 45d146f..c6836f8 100755 --- a/bin/hexol +++ b/bin/hexol @@ -11,6 +11,9 @@ ;;; same `resolve` fold: ;;; ;;; hexol render [-o FMT] [--path P] [-i INV] resolve + emit (default) +;;; [--validate] (yaml: pipe to kubeconform) +;;; hexol apply [--only SPEC] [--dry-run] [-i INV] run the appliers (plan) +;;; hexol diff [--only SPEC] [--explain] [-i INV] drift: 0 clean, 1 drift, 2 error ;;; hexol tree [-v] [-i INV] op tree, indented ;;; (-v: + per-op fold time) ;;; hexol explain PATH|HASH [-i INV] ops that touched PATH @@ -60,6 +63,9 @@ (hexol json) (hexol construct) (hexol doc) + ((hexol apply) #:select (current-diff-explainer)) + ((hexol sh) #:select (which-cmd)) + (ice-9 popen) (srfi srfi-1) (srfi srfi-9) (ice-9 match) @@ -264,20 +270,47 @@ (define (cmd-render args) (call-with-values (lambda () (extract-inventory "render" args)) (lambda (inv rest) - (let loop ((args rest) (fmt "sexp") (path #f)) + (let loop ((args rest) (fmt "sexp") (path #f) (validate? #f)) (match args - (() (do-render (inventory-or-default "render" inv) fmt path)) - (((or "-o" "--output") f . rest) (loop rest f path)) - (("--path" p . rest) (loop rest fmt (parse-path p))) + (() + (when (and validate? (not (string=? fmt "yaml"))) + (usage-error "render: --validate needs -o yaml (kubeconform checks manifests)")) + (if validate? + (validate-render (lambda () (do-render (inventory-or-default "render" inv) fmt path))) + (do-render (inventory-or-default "render" inv) fmt path))) + (((or "-o" "--output") f . rest) (loop rest f path validate?)) + (("--path" p . rest) (loop rest fmt (parse-path p) validate?)) + (("--validate" . rest) (loop rest fmt path #t)) ((arg . rest) (cond ((string-prefix? "--output=" arg) - (loop rest (flag-value "--output=" arg) path)) + (loop rest (flag-value "--output=" arg) path validate?)) ((string-prefix? "--path=" arg) - (loop rest fmt (parse-path (flag-value "--path=" arg)))) + (loop rest fmt (parse-path (flag-value "--path=" arg)) validate?)) ((string-prefix? "-" arg) (usage-error "render: unknown flag ~a" arg)) (else (usage-error "render: unexpected argument ~a (inventory is -i/--inventory)" arg))))))))) +;; `render --validate': run RENDER (which writes the yaml stream to stdout) with +;; stdout captured, echo it, then pipe it to `kubeconform -strict -summary' and +;; exit with its status. kubeconform's report goes to stderr so stdout stays +;; the bare stream (`… --validate | kubectl apply -f -' still works). Without +;; kubeconform on PATH the stream is printed unchecked, with a warning. +(define (validate-render render) + (let ((yaml (with-output-to-string render)) + (kc (which-cmd "kubeconform"))) + (display yaml) + (force-output) + (cond + ((not kc) + (format (current-error-port) "~a~%" + (e-dim ";; render: kubeconform not on PATH — --validate skipped"))) + (else + (let* ((port (with-output-to-port (current-error-port) + (lambda () (open-pipe* OPEN_WRITE kc "-strict" "-summary")))) + (_ (display yaml port)) + (code (status:exit-val (close-pipe port)))) + (unless (eqv? code 0) (exit code))))))) + ;; Full format list for error messages: built-ins plus `renders-with` names. (define builtin-formats '("sexp" "json" "yaml" "terraform" "ansible")) @@ -317,12 +350,21 @@ ;; --------------------------------------------------------------------------- ;; ;; hexol apply [--only SPEC] [--dry-run] [--list] [-i INVENTORY] +;; hexol diff [--only SPEC] [--explain] [-i INVENTORY] ;; ;; Resolve once, then run the `applies-with` appliers in registration order, -;; each (proc state dry?). --list prints that order. --dry-run delegates to each -;; tool's native dry-run (pair with --only; a whole-pipeline dry-run is -;; incoherent — k8s dry-run needs the cluster terraform builds). No hexol -;; prompt — appliers lean on their tool's gate (`tofu apply` prompts). +;; each (proc state mode), mode ∈ apply | plan | diff. --list prints that +;; order. --dry-run is mode `plan`: each tool's native dry-run (pair with +;; --only; a whole-pipeline dry-run is incoherent — k8s dry-run needs the +;; cluster terraform builds). No hexol prompt — appliers lean on their tool's +;; gate (`tofu apply` prompts). +;; +;; `diff` is mode `diff`: same pipeline, but each applier reports drift between +;; the rendered state and the world by returning `drift`. Exit 0 clean, 1 drift, +;; 2 error. --explain binds `current-diff-explainer` over the resolve trace, so +;; an applier with a structural diff (kubectl) prints, under each changed path, +;; the op that set it (label + file:line); terraform has no structural path and +;; streams its plan as-is. ;; ;; --only SPEC selects a subset, keeping pipeline order. SPEC is comma-separated ;; terms, each a NAME or a jj-style range: A::B (through), A:: (to end), ::B @@ -331,18 +373,40 @@ (define (cmd-apply args) (call-with-values (lambda () (extract-inventory "apply" args)) (lambda (inv rest) - (let loop ((args rest) (only #f) (dry? #f) (list? #f)) + (let loop ((args rest) (only #f) (mode 'apply) (list? #f)) (match args - (() (do-apply (inventory-or-default "apply" inv) only dry? list?)) - (("--dry-run" . rest) (loop rest only #t list?)) - (("--list" . rest) (loop rest only dry? #t)) - (("--only" spec . rest) (loop rest spec dry? list?)) + (() (do-apply (inventory-or-default "apply" inv) only mode list? #f)) + (("--dry-run" . rest) (loop rest only 'plan list?)) + (("--list" . rest) (loop rest only mode #t)) + (("--only" spec . rest) (loop rest spec mode list?)) ((arg . rest) (cond - ((string-prefix? "--only=" arg) (loop rest (flag-value "--only=" arg) dry? list?)) + ((string-prefix? "--only=" arg) (loop rest (flag-value "--only=" arg) mode list?)) ((string-prefix? "-" arg) (usage-error "apply: unknown flag ~a" arg)) (else (usage-error "apply: unexpected argument ~a (inventory is -i/--inventory)" arg))))))))) +(define (cmd-diff args) + (call-with-values (lambda () (extract-inventory "diff" args)) + (lambda (inv rest) + (let loop ((args rest) (only #f) (explain? #f)) + (match args + (() + ;; Any error in a diff is exit 2 (1 is reserved for drift), so + ;; report it here rather than letting `main` turn it into a 1. + (catch #t + (lambda () (do-apply (inventory-or-default "diff" inv) only 'diff #f explain?)) + (lambda (key . rest) + (if (eq? key 'quit) + (apply exit rest) + (begin (report-error key rest) (exit 2)))))) + (("--explain" . rest) (loop rest only #t)) + (("--only" spec . rest) (loop rest spec explain?)) + ((arg . rest) + (cond + ((string-prefix? "--only=" arg) (loop rest (flag-value "--only=" arg) explain?)) + ((string-prefix? "-" arg) (usage-error "diff: unknown flag ~a" arg)) + (else (usage-error "diff: unexpected argument ~a (inventory is -i/--inventory)" arg))))))))) + ;; Select a subset of ordered APPLIERS by SPEC (see cmd-apply), in pipeline ;; order; errors on an unknown name or reversed range. (define (select-appliers appliers spec) @@ -367,25 +431,52 @@ ((vector-ref keep i) (pick (cdr as) (1+ i) (cons (car as) acc))) (else (pick (cdr as) (1+ i) acc)))))) -(define (do-apply inv only dry? list?) +;; The `--explain` callback: given a state path a diff hunk changed, print the +;; op that last set it — label and file:line — from the resolve TRACE, reusing +;; `trace-hits`. Wrapper ops don't register hits, so this names the leaf. +(define (make-diff-explainer trace) + (lambda (path) + (let ((hits (trace-hits trace path '((attributes))))) + (if (null? hits) + (format #t " set by: ~a~%" (o-dim "(no op recorded for this path)")) + (let ((op (assq-ref (last hits) 'op))) + (format #t " set by: ~a ~a~%" + (o-bold (op-display op)) (o-dim (loc->string (op-loc op))))))))) + +;; MODE is apply | plan | diff (see the section comment). Under diff, an applier +;; returning `drift` marks the run; exit 1 once every chosen applier has run. +;; EXPLAIN? (diff only) resolves with a trace and binds `current-diff-explainer`. +(define (do-apply inv only mode list? explain?) (call-with-values (lambda () (load-ops+collected current-appliers inv)) (lambda (ops appliers) (when (null? appliers) - (die "apply: ~a registers no appliers (use applies-with in the inventory)" inv)) + (die "~a: ~a registers no appliers (use applies-with in the inventory)" + (if (eq? mode 'diff) "diff" "apply") inv)) (cond (list? (note ";; ~a appliers (pipeline order):~%" (length appliers)) (for-each (lambda (a) (format #t " ~a~%" (applier-name a))) appliers)) (else (let ((chosen (if only (select-appliers appliers only) appliers)) - (state (resolve ops '()))) ; resolve ONCE; appliers share it - (for-each - (lambda (a) - (format (current-error-port) ";; apply: ~a~a~%" - (applier-name a) (if dry? " (dry-run)" "")) - (force-output (current-error-port)) - ((applier-proc a) state dry?)) - chosen))))))) + (drift? #f)) + ;; resolve ONCE; appliers share the state (traced only for --explain) + (call-with-values + (lambda () (if explain? (resolve-with-trace ops '()) (values (resolve ops '()) #f))) + (lambda (state trace) + (parameterize ((current-diff-explainer (and trace (make-diff-explainer trace)))) + (for-each + (lambda (a) + (format (current-error-port) ";; ~a: ~a~a~%" + (if (eq? mode 'diff) "diff" "apply") + (applier-name a) (if (eq? mode 'plan) " (dry-run)" "")) + (force-output (current-error-port)) + (when (eq? 'drift ((applier-proc a) state mode)) + (set! drift? #t))) + chosen)))) + (when (eq? mode 'diff) + (format (current-error-port) "~a~%" + (if drift? (e-red ";; diff: drift detected") (e-dim ";; diff: clean"))) + (exit (if drift? 1 0))))))))) ;; --------------------------------------------------------------------------- ;; tree — concise op-tree view (walks captured source recursively) @@ -989,10 +1080,13 @@ Writes the inventory to stdout: hexol import -f app.yaml > app.scm") (register-verb! (make-verb "render" (cmd-is "render") (delegating-runner cmd-render) - "render [-o sexp|json|yaml|terraform|ansible] [--path a.b.c] [-i INVENTORY]")) + "render [-o sexp|json|yaml|terraform|ansible] [--path a.b.c] [--validate] [-i INVENTORY]")) (register-verb! (make-verb "apply" (cmd-is "apply") (delegating-runner cmd-apply) "apply [--only SPEC] [--dry-run] [--list] [-i INVENTORY]")) +(register-verb! + (make-verb "diff" (cmd-is "diff") (delegating-runner cmd-diff) + "diff [--only SPEC] [--explain] [-i INVENTORY] (exit 0 clean, 1 drift, 2 error)")) (register-verb! (make-verb "tree" (cmd-is "tree") (delegating-runner cmd-tree) "tree [-v] [-i INVENTORY]")) diff --git a/docs/extending.md b/docs/extending.md index 377b88e..26ad620 100644 --- a/docs/extending.md +++ b/docs/extending.md @@ -207,6 +207,20 @@ introspection tools descend through it transparently. `(compliance_findings)`); the renderer / CI gate reads them. - **"I want a new surface syntax"** — add a `syntax-rules` macro in `hexol/surface.scm` (the k8s sugar lives in `hexol/k8s.scm`) that expands to an existing op constructor. +- **"I want to push the state somewhere new"** — write an *applier*, a + `(state mode -> effects)` procedure, and name it in an `appliers` form + (`hexol/apply.scm`). `mode` is `'apply` (push), `'plan` (`hexol apply + --dry-run`: the tool's native dry-run) or `'diff` (`hexol diff`: compare + against the world and return the symbol `drift` when they differ — the CLI + exits 0 clean / 1 drift / 2 error). A legacy `(lambda (state dry?) …)` + still works: `#t` reads as plan, `#f` as apply. Under `hexol diff --explain` + the parameter `current-diff-explainer` holds a `(state-path -> prints)` + callback; an applier that can compute a structural diff (see + `kubectl-applier`, which uses `(hexol diff)` over `kubectl get -o json`) + calls it per changed path so each hunk names the op that set the value. + Appliers without one (terraform) ignore it and stream their plan. Checks + (`wait-for`, `check`) no-op under plan/diff; `report` and + `kubeconform-check` run in every mode. ## Worked example: the Terraform target diff --git a/examples/kubernetes.scm b/examples/kubernetes.scm index 52ddf95..cc2be8b 100644 --- a/examples/kubernetes.scm +++ b/examples/kubernetes.scm @@ -19,7 +19,9 @@ ;; ;; `hexol apply` renders (kubernetes_resources) and `kubectl apply`s it against ;; your current kubeconfig (~/.kube/config); `--dry-run` delegates to kubectl's -;; own `--dry-run=server`. The `wait-for` #:pre gates on the API answering first. +;; own `--dry-run=server`, and `hexol diff` to `kubectl diff` (`--explain` fetches +;; the live objects and names, per changed field, the op that set it). The +;; `wait-for` #:pre gates on the API answering first. (appliers ("kubernetes" (kubectl-applier diff --git a/hexol/apply.scm b/hexol/apply.scm index 2317e57..9c53ff6 100644 --- a/hexol/apply.scm +++ b/hexol/apply.scm @@ -4,10 +4,19 @@ ;;; state* and apply it. The only place hexol shells out (`tofu`, `kubectl`); ;;; `(hexol terraform)` / `(hexol k8s)` stay pure data translators. ;;; -;;; An *applier* is a `(state dry? -> effects)`: reads its slice of state and -;;; acts (under DRY?, delegates to the tool's native plan). The constructors -;;; here — `terraform-applier', `kubectl-applier', and the checks -;;; `wait-for'/`check'/`report' — only *return* one; none register. +;;; An *applier* is a `(state mode -> effects)`: reads its slice of state and +;;; acts. MODE is one of +;;; apply push (the default); +;;; plan delegate to the tool's native plan/dry-run (`hexol apply --dry-run'); +;;; diff report drift between the rendered state and the world (`hexol +;;; diff'): return the symbol `drift' when the two differ, anything +;;; else when clean; errors are errors. The runner folds these into +;;; its exit code (0 clean, 1 drift, 2 error). +;;; For compatibility MODE may also be the old DRY? boolean — #t reads as `plan', +;;; #f as `apply' (see `mode-of') — so a hand-written `(lambda (state dry?) …)' +;;; keeps working. The constructors here — `terraform-applier', +;;; `kubectl-applier', and the checks `wait-for'/`check'/`report'/ +;;; `kubeconform-check' — only *return* one; none register. ;;; Registration is the `appliers' form, naming a sequence run in textual order: ;;; ;;; (appliers @@ -20,8 +29,15 @@ ;;; ("check-apps" (check "apps Ready" my-predicate #:fatal? #f))) ;;; ;;; `hexol apply` resolves once, then runs the named appliers in order -;;; (optionally `--only NAME'), passing the shared state and `--dry-run'. Only -;;; under `apply' — elsewhere the collector is unbound and `appliers' no-ops. +;;; (optionally `--only NAME'), passing the shared state and the mode +;;; (`--dry-run' → plan; `hexol diff' → diff). Only under `apply'/`diff' — +;;; elsewhere the collector is unbound and `appliers' no-ops. +;;; +;;; `hexol diff --explain' binds `current-diff-explainer' to a (path -> prints) +;;; callback over the resolve trace; an applier that can compute a structural +;;; diff (kubectl's does, over the live objects) calls it per changed path so +;;; each hunk names the op that set the value. Appliers without one (terraform) +;;; ignore it and stream their tool's plan. ;;; ;;; Two ways to place a check: ;;; * an `appliers' entry — a visible, independently `--only'-able step; @@ -48,6 +64,7 @@ #:use-module ((hexol terraform) #:select (emit-terraform-json)) #:use-module ((hexol yaml) #:select (emit-yaml-stream)) #:use-module (hexol sh) + #:use-module ((hexol diff) #:select (structural-diff json->state)) #:use-module (ice-9 popen) #:use-module (ice-9 textual-ports) #:use-module (ice-9 format) @@ -58,13 +75,33 @@ #:re-export (state-get) #:export (terraform-applier kubectl-applier terraform-destroyer terraform-output-reporter terraform-validator talos-config-applier - appliers actions wait-for check report cmd sh-ok?)) + appliers actions wait-for check report kubeconform-check cmd sh-ok? + mode-of current-diff-explainer render-manifests)) + +;; Normalise an applier's second argument to a mode symbol: the runner passes +;; `apply'/`plan'/`diff'; a legacy caller may still pass DRY? (#t → plan, #f → +;; apply). Every constructor here reads the mode through this. +(define (mode-of m) + (cond ((eq? m #t) 'plan) ((not m) 'apply) (else m))) + +;; `hexol diff --explain' binds this to a (state-path -> prints) callback that +;; names the op which set the value at that path. #f otherwise; an applier +;; checks it under `diff' to choose the explained structural path. +(define current-diff-explainer (make-parameter #f)) ;; ---------- shell helpers ---------- (define (find-binary name) (or (which-cmd name) (error "apply: command not found on PATH:" name))) +;; Run PROG ARGS inheriting stdio, return the exit code (a signalled child +;; reads as 128+signal) — for tools whose non-zero exits carry meaning +;; (`tofu plan -detailed-exitcode', `kubectl diff'). +(define (run-status prog . args) + (force-output (current-error-port)) + (let ((st (apply system* prog args))) + (or (status:exit-val st) (+ 128 (or (status:term-sig st) 0))))) + ;; Log a progress line to stderr, flushing now. Guile block-buffers a piped ;; stderr and would emit these only at exit — *after* subprocess output on the ;; same fd. Flushing interleaves phase markers with tool output, so a failure @@ -108,11 +145,13 @@ ;; A check is an applier whose effect is *observation* (poll, assert, report), ;; not mutation. These builders return one; drop it into an `appliers' entry or ;; a #:pre/#:post. PRED is a `(state -> boolean)'; `cmd' lifts a shell command. -;; They differ only in dry-run and failure policy: -;; wait-for block until PRED holds (or time out → fatal); skipped on DRY?. +;; They differ only in plan/diff and failure policy: +;; wait-for block until PRED holds (or time out → fatal); skipped (logged) +;; under plan/diff. ;; check assert PRED once; #:fatal? (default #t) → error, else warn; -;; skipped on DRY? (nothing to check during a plan). +;; skipped under plan/diff (nothing to check during a plan). ;; report run THUNK for its side output; always, never fatal. +;; kubeconform-check schema-validate the rendered manifests; every mode. ;; Lift a shell command into a state predicate: ignores state, true iff the ;; command exits 0. (cmd "kubectl" "get" "--raw=/readyz") @@ -129,11 +168,12 @@ (define* (wait-for desc pred #:key (timeout 120) (interval 5) (needs #f)) "Return an applier that polls PRED every INTERVAL seconds until it holds, -erroring after TIMEOUT seconds. A no-op under DRY? (the infra it waits on may -not exist during a plan), or when #:needs names a binary absent from PATH." - (lambda (state dry?) +erroring after TIMEOUT seconds. A no-op under plan/diff (the infra it waits on +may not exist during a plan), or when #:needs names a binary absent from PATH." + (lambda (state mode) (cond - (dry? (log ";; apply[wait]: would wait for ~a~%" desc)) + ((not (eq? (mode-of mode) 'apply)) + (log ";; apply[wait]: would wait for ~a~%" desc)) ((not (needs-ok? 'wait desc needs)) #f) (else (let ((deadline (+ (current-time) timeout))) @@ -147,12 +187,13 @@ not exist during a plan), or when #:needs names a binary absent from PATH." (define* (check desc pred #:key (fatal? #t) (needs #f)) "Return an applier that asserts PRED once. On failure it errors when FATAL? -(the default) or warns otherwise. A no-op under DRY?, or when #:needs names a -binary absent from PATH (so a check shelling out to an optional tool skips -rather than fails when the tool is missing)." - (lambda (state dry?) +(the default) or warns otherwise. A no-op under plan/diff, or when #:needs +names a binary absent from PATH (so a check shelling out to an optional tool +skips rather than fails when the tool is missing)." + (lambda (state mode) (cond - (dry? (log ";; apply[check]: ~a (dry-run, skipped)~%" desc)) + ((not (eq? (mode-of mode) 'apply)) + (log ";; apply[check]: ~a (~a, skipped)~%" desc (mode-of mode))) ((not (needs-ok? 'check desc needs)) #f) ((pred state) (log ";; apply[check]: ~a — ok~%" desc)) (fatal? (error "apply[check]: failed:" desc)) @@ -160,19 +201,50 @@ rather than fails when the tool is missing)." (define (report desc thunk) "Return an applier that runs THUNK (state -> any) for its side output and -never fails. Runs even under DRY?." - (lambda (state dry?) +never fails. Runs under every mode." + (lambda (state mode) (log ";; apply[report]: ~a~%" desc) (thunk state))) +;; Pipe TEXT to `PROG ARGS' on stdin (stdout/stderr inherited); return the exit +;; code, letting the caller decide what a non-zero pass means. +(define (pipe-to prog args text) + (force-output (current-error-port)) + (let ((port (apply open-pipe* OPEN_WRITE prog args))) + (display text port) + (status:exit-val (close-pipe port)))) + +;; The (kubernetes_resources) manifest stream as one YAML string, Namespaces and +;; CRDs floated to the front (see `order-resources'). Shared by the kubectl +;; applier, `kubeconform-check', and `hexol render --validate'. +(define (render-manifests state) + (let ((rs (or (state-get state '(kubernetes_resources)) + (error "apply[kubernetes]: no (kubernetes_resources) in state")))) + (call-with-output-string + (lambda (p) (emit-yaml-stream p (order-resources rs)))))) + +(define* (kubeconform-check #:key (binary "kubeconform") + (args '("-strict" "-summary")) (fatal? #t)) + "Return an applier that pipes the rendered (kubernetes_resources) stream to +`BINARY ARGS' (default `kubeconform -strict -summary') and fails — errors when +FATAL?, warns otherwise — on a non-zero exit. Static validation, so it runs +under every mode; skipped with a log line when BINARY is not on PATH." + (lambda (state mode) + (cond + ((not (needs-ok? 'check "manifest schema" binary)) #f) + ((eqv? 0 (pipe-to (which-cmd binary) args (render-manifests state))) + (log ";; apply[check]: manifest schema — ok~%")) + (fatal? (error "apply[check]: kubeconform reported invalid manifests")) + (else (log ";; apply[check]: manifest schema — FAILED (non-fatal)~%"))))) + ;; #:pre/#:post accept a single check or a list; normalise to a list. (define (as-checks x) (if (procedure? x) (list x) x)) -(define (run-checks cs state dry?) (for-each (lambda (c) (c state dry?)) cs)) +(define (run-checks cs state mode) (for-each (lambda (c) (c state mode)) cs)) ;; ---------- registration ---------- ;; Name and register a sequence of appliers in textual order. Each PROC -;; evaluates to a `(state dry? -> effects)' — a deploy applier or a check. +;; evaluates to a `(state mode -> effects)' — a deploy applier or a check. ;; Expands to `applies-with' calls, so a no-op outside `hexol apply'. (define-syntax appliers (syntax-rules () @@ -208,21 +280,29 @@ never fails. Runs even under DRY?." (config-file "infra.tf.json") (output->file '()) (pre '()) (post '())) "Return an applier for the (terraform_config) subtree: write WORKDIR/CONFIG-FILE, -`BINARY -chdir=WORKDIR init`, then `plan` (when DRY?) or `apply`. After a real -apply, every (OUTPUT . FILE) pair in OUTPUT->FILE is written from `BINARY +`BINARY -chdir=WORKDIR init`, then `apply`, or under plan/diff `plan +-detailed-exitcode` (exit 2 = changes pending → `drift', 1 = error). After a +real apply, every (OUTPUT . FILE) pair in OUTPUT->FILE is written from `BINARY -chdir=WORKDIR output -raw OUTPUT` — the cred hand-off, e.g. (\"kubeconfig\" . \"deploy/kubeconfig\"). BINARY defaults to `tofu`; pass #:binary \"terraform\" 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)) - (chdir (string-append "-chdir=" workdir))) +init and after the outputs are written; name the result in an `appliers' form. +`--explain' has no structural path here: the plan streams as-is." + (lambda (state mode) + (run-checks (as-checks pre) state mode) + (let ((tf (find-binary binary)) + (chdir (string-append "-chdir=" workdir)) + (result #f)) (log ";; apply[terraform]: wrote ~a~%" (write-terraform-config state workdir config-file)) (run* tf chdir "init" "-input=false") - (cond - (dry? (run* tf chdir "plan")) + (case (mode-of mode) + ((plan diff) + (let ((code (run-status tf chdir "plan" "-detailed-exitcode"))) + (case code + ((0) (log ";; apply[terraform]: no changes~%")) + ((2) (log ";; apply[terraform]: changes pending~%") (set! result 'drift)) + (else (error "apply[terraform]: plan failed" code))))) (else (run* tf chdir "apply") ; tofu's y/N prompt gates this (for-each @@ -230,8 +310,9 @@ init and after the outputs are written; name the result in an `appliers' form." (let ((val (capture tf chdir "output" "-raw" (car pair)))) (write-file (cdr pair) val) (log ";; apply[terraform]: output ~a -> ~a~%" (car pair) (cdr pair)))) - output->file)))) - (run-checks (as-checks post) state dry?))) + output->file))) + (run-checks (as-checks post) state mode) + result))) ;; ---------- terraform destroyer (a CLI action, not a pipeline step) ---------- @@ -323,13 +404,14 @@ machine_configuration. Per node the config is fetched from terraform state, written to a temp file, and applied with `talosctl apply-config --mode MODE'; then `talosctl health' must pass — queried from a DIFFERENT node, so the probe is not aimed at a rebooting apid — before the next. TALOSCONFIG (client certs) -is refreshed from state first. With `--dry-run' in ARGS each node gets -`apply-config --dry-run' (prints the diff, changes nothing, no reboot, no gate). -Register with `defines-action'/`actions' to expose it as its own `hexol' verb." +is refreshed from state first. With `--dry-run' (or `--diff') in ARGS each +node gets `apply-config --dry-run' (prints the diff, changes nothing, no +reboot, no gate). Register with `defines-action'/`actions' to expose it as +its own `hexol' verb." (lambda (state args) (let* ((tc-bin (find-binary binary)) (tf-bin (find-binary tofu)) - (dry? (and (member "--dry-run" args) #t)) + (dry? (and (or (member "--dry-run" args) (member "--diff" args)) #t)) ;; one tofu round-trip per value; addresses up front (for the ;; observe-from-another-node health gate), configs lazily per node. (addrs (map (lambda (n) (tf-output-raw tf-bin workdir (cadr n))) nodes))) @@ -377,44 +459,98 @@ Register with `defines-action'/`actions' to expose it as its own `hexol' verb." '("Namespace" "CustomResourceDefinition")))) rs)))) -;; Pipe YAML to `kubectl ARGS` (which include `apply … -f -`); return the exit -;; code, letting the caller decide whether a non-zero pass is fatal. -(define (kubectl-pipe kubectl args yaml) - (force-output (current-error-port)) - (let ((port (apply open-pipe* OPEN_WRITE kubectl args))) - (display yaml port) - (status:exit-val (close-pipe port)))) +;; `Kind/name' (namespace-qualified when scoped) — how a diff hunk names a +;; resource. +(define (resource-id r) + (let* ((md (or (assq-ref r 'metadata) '())) + (ns (assq-ref md 'namespace))) + (format #f "~a/~a~a" (assq-ref r 'kind) (assq-ref md 'name) + (if ns (format #f " (ns ~a)" ns) "")))) + +;; `kubectl get -o json' the live counterpart of rendered resource R; #f when +;; it doesn't exist. KUBECTL-BASE is the binary plus its global flags. +(define (fetch-live kubectl-base r) + (let* ((md (or (assq-ref r 'metadata) '())) + (ns (assq-ref md 'namespace)) + (out (apply capture (append kubectl-base + (list "get" "-o" "json" "--ignore-not-found") + (if ns (list "-n" ns) '()) + (list (assq-ref r 'kind) (assq-ref md 'name)))))) + (and (not (string-null? out)) (json->state out)))) + +;; The explained diff: fetch each rendered resource's live object, structural- +;; diff the two (see (hexol diff)), and print one hunk per changed leaf — +;; value change, then the op that set it via EXPLAIN, a (state-path -> prints) +;; callback keyed on the resource's index in (kubernetes_resources). Returns +;; `drift' when anything differs. +(define (kubectl-explained-diff kubectl-base rs explain) + (let ((drift? #f)) + (for-each + (lambda (r i) + (let ((live (fetch-live kubectl-base r))) + (cond + ((not live) + (set! drift? #t) + (format #t "+ ~a (not in cluster)~%" (resource-id r)) + (explain (list 'kubernetes_resources i))) + (else + (for-each + (lambda (d) + (let ((path (car d)) (was (cadr d)) (now (caddr d))) + (set! drift? #t) + (if was + (format #t "~~ ~a ~a: ~s -> ~s~%" (resource-id r) (path->string path) was now) + (format #t "+ ~a ~a: ~s~%" (resource-id r) (path->string path) now)) + (explain (cons* 'kubernetes_resources i path)))) + (structural-diff r live)))))) + rs (iota (length rs))) + (if drift? + 'drift + (log ";; apply[kubernetes]: no drift~%")))) (define* (kubectl-applier #:key (binary "kubectl") (kubeconfig #f) (server-side #t) (passes 2) (pre '()) (post '())) "Return an applier for (kubernetes_resources): render the manifest stream — -Namespaces and CRDs floated to the front — and `kubectl apply` it. With DRY?, -runs one `--dry-run=server` pass. Otherwise applies up to PASSES times (default -2): a custom resource whose CRD is created earlier in the *same* run fails the -first pass (kubectl caches API types per invocation), so a second pass — not a -wait — lands it. CRDs created out of band (e.g. cert-manager's, installed later -by Flux) converge on a subsequent `hexol apply --only kubernetes`. #:kubeconfig +Namespaces and CRDs floated to the front — and `kubectl apply` it. Under +`plan', runs one `--dry-run=server` pass. Under `diff', runs `kubectl diff -f +-' (exit 1 = drift, not an error → returns `drift'); with +`current-diff-explainer' bound (`hexol diff --explain') it instead fetches each +live object and prints a structural diff whose every hunk names the op that +set the value. Otherwise applies up to PASSES times (default 2): a custom +resource whose CRD is created earlier in the *same* run fails the first pass +(kubectl caches API types per invocation), so a second pass — not a wait — +lands it. CRDs created out of band (e.g. cert-manager's, installed later by +Flux) converge on a subsequent `hexol apply --only kubernetes`. #:kubeconfig sets --kubeconfig; #:server-side toggles --server-side (the default — big CRD bundles exceed client-side apply's annotation-size limit). #:pre / #:post run -their checks (one or a list) before and after applying — e.g. a #:pre `wait-for' -that blocks until the API answers, so the gate travels with `--only kubernetes'." - (lambda (state dry?) - (run-checks (as-checks pre) state dry?) - (let* ((kc (find-binary binary)) - (rs (or (state-get state '(kubernetes_resources)) - (error "apply[kubernetes]: no (kubernetes_resources) in state"))) - (yaml (call-with-output-string - (lambda (p) (emit-yaml-stream p (order-resources rs))))) - (base (append (if kubeconfig (list (string-append "--kubeconfig=" kubeconfig)) '()) - (list "apply") - (if server-side '("--server-side" "--force-conflicts") '())))) - (cond - (dry? - (unless (eqv? 0 (kubectl-pipe kc (append base '("--dry-run=server" "-f" "-")) yaml)) +their checks (one or a list) before and after applying — e.g. a #:pre +`wait-for' that blocks until the API answers, so the gate travels with `--only +kubernetes'." + (lambda (state mode) + (run-checks (as-checks pre) state mode) + (let* ((kc (find-binary binary)) + (global (if kubeconfig (list (string-append "--kubeconfig=" kubeconfig)) '())) + (ss (if server-side '("--server-side" "--force-conflicts") '())) + (yaml (render-manifests state)) + (base (append global (list "apply") ss)) + (result #f)) + (case (mode-of mode) + ((plan) + (unless (eqv? 0 (pipe-to kc (append base '("--dry-run=server" "-f" "-")) yaml)) (error "apply[kubernetes]: dry-run reported errors"))) + ((diff) + (set! result + (if (current-diff-explainer) + (kubectl-explained-diff (cons kc global) + (state-get state '(kubernetes_resources)) + (current-diff-explainer)) + (case (pipe-to kc (append global (list "diff") ss '("-f" "-")) yaml) + ((0) (log ";; apply[kubernetes]: no drift~%") #f) + ((1) (log ";; apply[kubernetes]: drift~%") 'drift) + (else (error "apply[kubernetes]: kubectl diff failed")))))) (else (let loop ((n 1)) - (let ((code (kubectl-pipe kc (append base '("-f" "-")) yaml))) + (let ((code (pipe-to kc (append base '("-f" "-")) yaml))) (cond ((eqv? code 0) (log ";; apply[kubernetes]: applied (pass ~a)~%" n)) @@ -423,5 +559,6 @@ that blocks until the API answers, so the gate travels with `--only kubernetes'. (loop (+ n 1))) (else (log ";; apply[kubernetes]: pass ~a still had errors — re-run `--only kubernetes` once out-of-band CRDs (e.g. cert-manager via Flux) exist~%" - n)))))))) - (run-checks (as-checks post) state dry?))) + n))))))) + (run-checks (as-checks post) state mode) + result))) diff --git a/hexol/diff.scm b/hexol/diff.scm new file mode 100644 index 0000000..e39ea43 --- /dev/null +++ b/hexol/diff.scm @@ -0,0 +1,61 @@ +;;; hexol/diff.scm — a tiny structural differ over state-shaped alists. +;;; +;;; `hexol diff --explain' compares a *rendered* resource (the resolved alist) +;;; against its *live* counterpart (`kubectl get -o json', parsed back into the +;;; same shape) and reports each leaf that differs, as a state path — so the +;;; explain machinery can name the op that set it. Pure data; nothing here +;;; shells out. +;;; +;;; The comparison is one-sided on purpose: it walks the DESIRED side's keys +;;; only. A live object carries everything the API server defaulted or +;;; computed (status, uid, resourceVersion, managedFields…), none of which the +;;; inventory ever set, so "in live, not in desired" is noise, not drift. + +(define-module (hexol diff) + #:use-module ((hexol yaml) #:select (object-shape?)) + #:use-module (json) + #:use-module (srfi srfi-1) + #:use-module (ice-9 format) + #:export (structural-diff json->state)) + +;; Parse a JSON document into hexol's state shape: guile-json gives string +;; keys and vectors; state uses symbol keys and lists (as the yaml emitter +;; reads them). JSON null stays the symbol `null' — #f would be +;; indistinguishable from "absent" to `path-get'. +(define (json->state text) + (let loop ((v (json-string->scm text))) + (cond + ((vector? v) (map loop (vector->list v))) + ((and (list? v) (every (lambda (e) (and (pair? e) (string? (car e)))) v)) + (map (lambda (e) (cons (string->symbol (car e)) (loop (cdr e)))) v)) + (else v)))) + +;; Scalars compare by their printed form, so a rendered 80 matches a live 80 +;; and a symbol-valued field its string spelling — the YAML round-trip through +;; kubectl loses that distinction anyway. +(define (same-scalar? a b) + (or (equal? a b) + (and (not (pair? a)) (not (pair? b)) + (string=? (format #f "~a" a) (format #f "~a" b))))) + +(define (structural-diff desired live . path) + "Leaf-diff DESIRED against LIVE (both state-shaped alists); return a list of +(PATH LIVE-VALUE DESIRED-VALUE) for every leaf under DESIRED whose live value +differs — LIVE-VALUE is #f when the path is absent live. Only DESIRED's keys +are walked (see the module comment). PATH, if given, prefixes every result." + (let ((path (if (null? path) '() (car path)))) + (cond + ((and (object-shape? desired) (object-shape? live)) + (append-map (lambda (e) + (structural-diff (cdr e) (assq-ref live (car e)) + (append path (list (car e))))) + desired)) + ;; sequences of equal length compare element-wise (so a container list + ;; drills to the field); otherwise the whole sequence is the leaf. + ((and (pair? desired) (list? desired) (list? live) + (not (object-shape? desired)) (not (object-shape? live)) + (= (length desired) (length live))) + (append-map (lambda (d l i) (structural-diff d l (append path (list i)))) + desired live (iota (length desired)))) + ((same-scalar? desired live) '()) + (else (list (list path live desired)))))) diff --git a/hexol/kernel.scm b/hexol/kernel.scm index 9a22ea5..0738904 100644 --- a/hexol/kernel.scm +++ b/hexol/kernel.scm @@ -499,7 +499,7 @@ order." ;; What each collect! stores: a named record, not a positional tuple, so the ;; consumer reads named fields. A renderer carries a (state -> text) proc; an -;; applier a (state dry? -> effects) proc; an action a (state args -> effects) +;; applier a (state mode -> effects) proc; an action a (state args -> effects) ;; proc plus a one-line SYNOPSIS for --help. (define-record-type (make-renderer name proc) @@ -539,19 +539,19 @@ render -o NAME`. A no-op when no collector is bound." ;; ---------- optional per-file apply adapters (effects) ---------- ;; -;; The mirror of renders-with, but for *effects*. An applier is a (state dry? -> +;; The mirror of renders-with, but for *effects*. An applier is a (state mode -> ;; performs effects) proc: it reads its slice of resolved state and pushes it to ;; the world (tofu apply, kubectl apply). The inventory registers each by NAME ;; with applies-with; `hexol apply` runs them in *registration order* against a -;; single resolve. --only NAME filters the set (order preserved); --dry-run is -;; threaded as the applier's second arg, delegating to the tool's native -;; dry-run. The parameter is #f outside apply, so applies-with is a no-op -;; elsewhere. +;; single resolve. --only NAME filters the set (order preserved). MODE is the +;; applier's second arg: `apply` (push), `plan` (`--dry-run`: the tool's native +;; dry-run), or `diff` (`hexol diff`: report drift by returning `drift`). The +;; parameter is #f outside apply/diff, so applies-with is a no-op elsewhere. (define current-appliers (make-collector)) (define (applies-with name proc) - "Register PROC, a (state dry? -> performs effects) applier, under string + "Register PROC, a (state mode -> performs effects) applier, under string NAME. Appliers run under `hexol apply' in the order registered. A no-op when no collector is bound." (collect! current-appliers (make-applier name proc))) diff --git a/test/apply-mode.scm b/test/apply-mode.scm new file mode 100644 index 0000000..f79d7d4 --- /dev/null +++ b/test/apply-mode.scm @@ -0,0 +1,209 @@ +;;; test/apply-mode.scm — applier mode dispatch (apply | plan | diff) and the +;;; structural differ, against PATH shims in test/fixtures/bin (no cluster, no +;;; tofu). Run: guile -L . test/apply-mode.scm (or `make test`) +;;; +;;; The shims log their argv to $FAKE_LOG and exit per FAKE_*_EXIT, so a test +;;; asserts which subcommand a mode reached for and what its exit code meant. + +(add-to-load-path (dirname (dirname (current-filename)))) + +(use-modules (hexol apply) + (hexol diff) + (ice-9 textual-ports) + (ice-9 format) + (srfi srfi-1)) + +(define failures 0) + +(define-syntax expect + (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))))))) + +;; ---- harness: shims first on PATH, a fresh log per run ---- + +(define here (dirname (current-filename))) +(setenv "PATH" (string-append here "/fixtures/bin:" (getenv "PATH"))) + +(define tmp (or (getenv "TMPDIR") "/tmp")) +(define log-file (string-append tmp "/hexol-test-apply-" (number->string (getpid)) ".log")) +(define workdir (string-append tmp "/hexol-test-tf-" (number->string (getpid)))) +(setenv "FAKE_LOG" log-file) + +(define (reset-log!) (when (file-exists? log-file) (delete-file log-file))) +(define (log-lines) + (if (file-exists? log-file) + (string-split (string-trim-right (call-with-input-file log-file get-string-all)) #\newline) + '())) +(define (logged? substr) (and (any (lambda (l) (string-contains l substr)) (log-lines)) #t)) + +;; Run THUNK with stderr silenced (the appliers' progress lines) and stdout +;; captured; return (values result stdout-text). +(define (quiet thunk) + (let* ((out "") + (res (with-output-to-string + (lambda () + (set! out (with-error-to-port (open-output-string) thunk)))))) + (values out res))) + +(define (run-quiet thunk) + (call-with-values (lambda () (quiet thunk)) (lambda (res text) res))) + +(define (error-message thunk) + (catch #t + (lambda () (run-quiet thunk) #f) + (lambda (key . args) (if (eq? key 'quit) (throw key) (cadr args))))) + +(define k8s-state + '((kubernetes_resources + ((apiVersion . "apps/v1") (kind . "Deployment") + (metadata (name . "tintin") (namespace . "tintin")) + (spec (replicas . 2) + (template (spec (containers ((name . "web") (image . "nginx:1.27")))))))))) + +(define tf-state '((terraform_config (resource (null_resource (x)))))) + +(format #t "~%apply: mode-of~%") +(expect "symbol passes through" 'diff (mode-of 'diff)) +(expect "#t is plan (legacy dry?)" 'plan (mode-of #t)) +(expect "#f is apply" 'apply (mode-of #f)) + +(format #t "~%apply: kubectl applier by mode~%") +(reset-log!) +(run-quiet (lambda () ((kubectl-applier) k8s-state 'plan))) +(expect "plan -> --dry-run=server" #t (logged? "--dry-run=server")) +(reset-log!) +(run-quiet (lambda () ((kubectl-applier) k8s-state #t))) +(expect "legacy #t -> plan" #t (logged? "--dry-run=server")) +(reset-log!) +(run-quiet (lambda () ((kubectl-applier #:kubeconfig "kc") k8s-state 'apply))) +(expect "apply -> kubectl apply --server-side" #t (logged? "--kubeconfig=kc apply --server-side")) +(expect "apply never diffs" #f (logged? "kubectl diff")) + +(setenv "FAKE_DIFF_EXIT" "1") +(reset-log!) +(expect "diff exit 1 -> drift" 'drift (run-quiet (lambda () ((kubectl-applier) k8s-state 'diff)))) +(expect "diff -> kubectl diff -f -" #t (logged? "kubectl diff --server-side --force-conflicts -f -")) +(setenv "FAKE_DIFF_EXIT" "0") +(expect "diff exit 0 -> clean" #f (run-quiet (lambda () ((kubectl-applier) k8s-state 'diff)))) +(setenv "FAKE_DIFF_EXIT" "3") +(expect "diff exit >1 -> error" #t + (string? (error-message (lambda () ((kubectl-applier) k8s-state 'diff))))) +(unsetenv "FAKE_DIFF_EXIT") + +(format #t "~%apply: kubectl explained diff (structural, via kubectl get)~%") +(define live-json (string-append tmp "/hexol-test-live-" (number->string (getpid)) ".json")) +(call-with-output-file live-json + (lambda (p) + (display "{\"apiVersion\":\"apps/v1\",\"kind\":\"Deployment\", + \"metadata\":{\"name\":\"tintin\",\"namespace\":\"tintin\",\"uid\":\"abc\"}, + \"spec\":{\"replicas\":3,\"template\":{\"spec\":{\"containers\": + [{\"name\":\"web\",\"image\":\"nginx:1.26\",\"imagePullPolicy\":\"Always\"}]}}}, + \"status\":{\"readyReplicas\":3}}" p))) +(setenv "FAKE_GET_JSON" live-json) +(define explained '()) +(reset-log!) +(call-with-values + (lambda () + (quiet (lambda () + (parameterize ((current-diff-explainer + (lambda (path) (set! explained (cons path explained))))) + ((kubectl-applier) k8s-state 'diff))))) + (lambda (result text) + (expect "explained diff -> drift" 'drift result) + (expect "fetches live object with kubectl get" #t + (logged? "kubectl get -o json --ignore-not-found -n tintin Deployment tintin")) + (expect "never runs kubectl diff" #f (logged? "kubectl diff")) + (expect "hunk: replicas live -> desired" #t + (and (string-contains text "~ Deployment/tintin (ns tintin) spec.replicas: 3 -> 2") #t)) + (expect "hunk: container image drills into the list" #t + (and (string-contains text "spec.template.spec.containers.0.image: \"nginx:1.26\" -> \"nginx:1.27\"") #t)) + (expect "explainer called per changed path, indexed into kubernetes_resources" + '((kubernetes_resources 0 spec replicas) + (kubernetes_resources 0 spec template spec containers 0 image)) + (reverse explained)))) +(unsetenv "FAKE_GET_JSON") +(set! explained '()) +(call-with-values + (lambda () + (quiet (lambda () + (parameterize ((current-diff-explainer (lambda (path) (set! explained (cons path explained))))) + ((kubectl-applier) k8s-state 'diff))))) + (lambda (result text) + (expect "missing live object -> drift, whole resource" 'drift result) + (expect " reported as not in cluster" #t + (and (string-contains text "+ Deployment/tintin (ns tintin) (not in cluster)") #t)) + (expect " explained at the resource path" '((kubernetes_resources 0)) explained))) +(delete-file live-json) + +(format #t "~%apply: terraform applier by mode~%") +(setenv "FAKE_PLAN_EXIT" "2") +(reset-log!) +(expect "plan exit 2 -> drift" 'drift + (run-quiet (lambda () ((terraform-applier #:workdir workdir) tf-state 'diff)))) +(expect "plan -> tofu plan -detailed-exitcode" #t (logged? "tofu -chdir=" )) +(expect " with -detailed-exitcode" #t (logged? "plan -detailed-exitcode")) +(expect " never applies" #f (logged? " apply")) +(setenv "FAKE_PLAN_EXIT" "0") +(expect "plan exit 0 -> clean (mode plan)" #f + (run-quiet (lambda () ((terraform-applier #:workdir workdir) tf-state 'plan)))) +(setenv "FAKE_PLAN_EXIT" "1") +(expect "plan exit 1 -> error" #t + (string? (error-message (lambda () ((terraform-applier #:workdir workdir) tf-state 'plan))))) +(unsetenv "FAKE_PLAN_EXIT") +(reset-log!) +(run-quiet (lambda () ((terraform-applier #:workdir workdir) tf-state 'apply))) +(expect "apply -> tofu apply" #t (logged? " apply")) +(expect " no plan under apply" #f (logged? " plan")) + +(format #t "~%apply: checks under plan/diff~%") +(define pred-calls 0) +(define counting (lambda (state) (set! pred-calls (+ pred-calls 1)) #t)) +(run-quiet (lambda () ((check "x" counting) '() 'diff))) +(run-quiet (lambda () ((check "x" counting) '() 'plan))) +(run-quiet (lambda () ((wait-for "x" counting) '() 'diff))) +(expect "check/wait-for skip their predicate under plan/diff" 0 pred-calls) +(run-quiet (lambda () ((check "x" counting) '() 'apply))) +(expect "check runs it under apply" 1 pred-calls) +(expect "report runs under diff" "ran" + (let ((seen #f)) + (run-quiet (lambda () ((report "r" (lambda (s) (set! seen "ran"))) '() 'diff))) + seen)) + +(format #t "~%apply: kubeconform-check~%") +(reset-log!) +(expect "exit 0 -> ok" #f + (error-message (lambda () ((kubeconform-check) k8s-state 'plan)))) +(expect " pipes to kubeconform -strict -summary" #t (logged? "kubeconform -strict -summary")) +(setenv "FAKE_KUBECONFORM_EXIT" "1") +(expect "exit 1 -> error" #t + (string? (error-message (lambda () ((kubeconform-check) k8s-state 'diff))))) +(expect "exit 1, #:fatal? #f -> warns only" #f + (error-message (lambda () ((kubeconform-check #:fatal? #f) k8s-state 'apply)))) +(unsetenv "FAKE_KUBECONFORM_EXIT") + +(format #t "~%diff: structural-diff~%") +(expect "equal -> no hunks" '() (structural-diff '((a . 1)) '((a . 1) (b . 2)))) +(expect "changed leaf" '(((a b) 1 2)) (structural-diff '((a (b . 2))) '((a (b . 1))))) +(expect "absent live -> #f live value" '(((a) #f 2)) (structural-diff '((a . 2)) '((z . 1)))) +(expect "scalars compare by print form" '() (structural-diff '((port . 80)) '((port . "80")))) +(expect "equal-length lists compare element-wise" + '(((xs 1 n) 2 3)) (structural-diff '((xs ((n . 1)) ((n . 3)))) '((xs ((n . 1)) ((n . 2)))))) +(expect "different-length lists are one leaf" + '(((xs) (1) (1 2))) (structural-diff '((xs 1 2)) '((xs 1)))) +(expect "json->state: symbol keys, lists, null kept" + '((a 1 ((b . null)))) + (json->state "{\"a\":[1,{\"b\":null}]}")) + +(reset-log!) +(format #t "~%~a~%" + (if (zero? failures) + "all checks passed" + (format #f "~a failure(s)" failures))) +(exit (if (zero? failures) 0 1)) diff --git a/test/diff-cli.sh b/test/diff-cli.sh new file mode 100755 index 0000000..ed0aaf3 --- /dev/null +++ b/test/diff-cli.sh @@ -0,0 +1,45 @@ +#!/usr/bin/env bash +# test/diff-cli.sh — `hexol diff` exit codes end to end, against the PATH shims +# in test/fixtures/bin (a fake kubectl whose `diff` exit is $FAKE_DIFF_EXIT). +# 0 clean, 1 drift, 2 error; `--explain` goes through `kubectl get` instead. +# +# Run: test/diff-cli.sh (or `make test`) + +set -u +cd "$(dirname "$0")/.." || exit 2 + +GUILE="${GUILE:-guile}" +export PATH="$PWD/test/fixtures/bin:$PATH" +export FAKE_LOG=/dev/null +hexol() { "$GUILE" -L . -e main -s bin/hexol "$@"; } +inv=examples/kubernetes.scm +failures=0 + +expect_exit() { # DESC EXPECTED CMD… + local desc=$1 want=$2; shift 2 + "$@" >/dev/null 2>&1; local got=$? + if [ "$got" -eq "$want" ]; then printf ' ok %s\n' "$desc" + else failures=$((failures + 1)); printf ' FAIL %s (exit %d, want %d)\n' "$desc" "$got" "$want"; fi +} + +echo +echo "diff: CLI exit codes" +FAKE_DIFF_EXIT=0 expect_exit "clean -> 0" 0 hexol diff -i "$inv" +FAKE_DIFF_EXIT=1 expect_exit "drift -> 1" 1 hexol diff -i "$inv" +FAKE_DIFF_EXIT=3 expect_exit "kubectl error -> 2" 2 hexol diff -i "$inv" +FAKE_DIFF_EXIT=1 expect_exit "--only kubernetes" 1 hexol diff --only kubernetes -i "$inv" +expect_exit "unknown flag -> 2" 2 hexol diff --bogus -i "$inv" +# --explain: no live objects (fake `get` prints nothing) → every resource drifts +expect_exit "--explain, nothing live -> 1" 1 hexol diff --explain -i "$inv" +out=$(hexol diff --explain -i "$inv" 2>/dev/null) +if printf '%s' "$out" | grep -q '^+ Deployment/tintin (ns tintin) (not in cluster)' \ + && printf '%s' "$out" | grep -q 'set by: .*examples/kubernetes.scm:'; then + echo " ok --explain names the resource and the op that set it" +else + failures=$((failures + 1)); echo " FAIL --explain output"; printf '%s\n' "$out" | head -5 +fi +FAKE_DIFF_EXIT=1 expect_exit "apply --dry-run stays plan (exit 0)" 0 hexol apply --dry-run -i "$inv" + +echo +if [ "$failures" -eq 0 ]; then echo "all diff CLI checks passed"; exit 0 +else echo "$failures diff CLI check(s) failed"; exit 1; fi diff --git a/test/fixtures/bin/kubeconform b/test/fixtures/bin/kubeconform new file mode 100755 index 0000000..e0405ef --- /dev/null +++ b/test/fixtures/bin/kubeconform @@ -0,0 +1,6 @@ +#!/usr/bin/env bash +# test/fixtures/bin/kubeconform — PATH shim; logs argv to $FAKE_LOG, drains +# stdin, exits $FAKE_KUBECONFORM_EXIT (default 0). +echo "kubeconform $*" >> "${FAKE_LOG:-/dev/null}" +[ -t 0 ] || cat >/dev/null +exit "${FAKE_KUBECONFORM_EXIT:-0}" diff --git a/test/fixtures/bin/kubectl b/test/fixtures/bin/kubectl new file mode 100755 index 0000000..a549a4b --- /dev/null +++ b/test/fixtures/bin/kubectl @@ -0,0 +1,16 @@ +#!/usr/bin/env bash +# test/fixtures/bin/kubectl — PATH shim standing in for kubectl in tests. +# Appends its argv to $FAKE_LOG, drains stdin, and exits per verb: +# apply $FAKE_APPLY_EXIT (default 0) +# diff $FAKE_DIFF_EXIT (default 0; 1 = drift, as kubectl's) +# get prints $FAKE_GET_JSON's contents (nothing when unset: not found) +echo "kubectl $*" >> "${FAKE_LOG:-/dev/null}" +verb= +for a in "$@"; do case "$a" in -*) ;; *) verb=$a; break;; esac; done +[ -t 0 ] || cat >/dev/null +case "$verb" in + apply) exit "${FAKE_APPLY_EXIT:-0}" ;; + diff) exit "${FAKE_DIFF_EXIT:-0}" ;; + get) [ -n "${FAKE_GET_JSON:-}" ] && cat "$FAKE_GET_JSON"; exit 0 ;; + *) exit 0 ;; +esac diff --git a/test/fixtures/bin/tofu b/test/fixtures/bin/tofu new file mode 100755 index 0000000..4de7bfd --- /dev/null +++ b/test/fixtures/bin/tofu @@ -0,0 +1,12 @@ +#!/usr/bin/env bash +# test/fixtures/bin/tofu — PATH shim standing in for tofu in tests. +# Appends its argv to $FAKE_LOG; `plan` exits $FAKE_PLAN_EXIT (default 0; +# 2 = changes pending under -detailed-exitcode), `output` prints "out". +echo "tofu $*" >> "${FAKE_LOG:-/dev/null}" +verb= +for a in "$@"; do case "$a" in -*) ;; *) verb=$a; break;; esac; done +case "$verb" in + plan) exit "${FAKE_PLAN_EXIT:-0}" ;; + output) echo out ;; +esac +exit 0 From 4e64b5daad6c7bcfb87aeb75f9f16420ea9b4bcc Mon Sep 17 00:00:00 2001 From: Polyedre Date: Thu, 3 Sep 2026 14:34:32 +0200 Subject: [PATCH 08/12] hexol: version, changelog, and install paths (container, nix, guix) - (hexol version) exports %hexol-version = 0.1.0; `hexol --version` and `hexol version` print it. guix.scm carries a commented copy. - CHANGELOG.md (Keep a Changelog): 0.1.0 summarises today, Unreleased lists the verbs in flight. - Containerfile: Alpine + guile/guile-json/jq, guile-libyaml built from source with nyacc in a first stage (neither Alpine nor Debian packages it). ~80 MB. `make image` builds it; `make image-guix` is the guix pack alternative. - flake.nix: package + devShell; nixpkgs lacks nyacc and guile-libyaml too, so both are built in the flake. flake.lock committed. - README Install: source/Guix, container, Nix; Status line -> CHANGELOG. - CI: new image job builds the Containerfile and smoke-tests it (no push). --- .containerignore | 4 ++ .github/workflows/ci.yml | 14 ++++++ CHANGELOG.md | 54 ++++++++++++++++++++ Containerfile | 50 +++++++++++++++++++ Makefile | 18 ++++++- README.md | 28 ++++++++--- bin/hexol | 6 +++ flake.lock | 27 ++++++++++ flake.nix | 103 +++++++++++++++++++++++++++++++++++++++ guix.scm | 4 +- hexol/version.scm | 10 ++++ 11 files changed, 308 insertions(+), 10 deletions(-) create mode 100644 .containerignore create mode 100644 CHANGELOG.md create mode 100644 Containerfile create mode 100644 flake.lock create mode 100644 flake.nix create mode 100644 hexol/version.scm diff --git a/.containerignore b/.containerignore new file mode 100644 index 0000000..0b031c5 --- /dev/null +++ b/.containerignore @@ -0,0 +1,4 @@ +.git +.direnv +deploy +*.go diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 25f46e8..71ca6dc 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -61,3 +61,17 @@ jobs: # 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 + + # Build the OCI image (no push) so the Containerfile can't rot. Runs on the + # runner's docker; the same file builds under podman via `make image`. + image: + runs-on: ubuntu-latest + timeout-minutes: 30 + steps: + - uses: actions/checkout@v4 + - name: Build the image + run: docker build -t hexol:ci . + - name: Smoke-test it + run: | + docker run --rm hexol:ci --version + docker run --rm hexol:ci render -o yaml -i examples/kubernetes.scm | head -5 diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..497c2fe --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,54 @@ +# Changelog + +All notable changes to hexol are documented here. The format follows +[Keep a Changelog](https://keepachangelog.com/en/1.1.0/); the version is the one +`hexol --version` prints (`%hexol-version` in `hexol/version.scm`). + +## [Unreleased] + +### Added +- `diff` verb: compare two renders (or a render against live state). +- `doc` verb: documentation for the constructs an inventory uses. +- `import` verb: turn existing manifests/config into an inventory. +- `lint` verb: static checks over an inventory. +- `--validate` flag: schema-check the resolved state before rendering. +- `explain` reports the fix location for ops generated under `hx-each`. + +## [0.1.0] - 2026-09-03 + +First tagged release: the engine, the author surface, the target libraries, +and the CLI as they exist today. + +### Added +- Kernel: inventories resolve as a fold of labeled ops (`merge`, `set`, + `append`, `when`, `case`) over one state; every value keeps the op that set + it, so `tree`, `show`, and `explain` can answer "what set this?". +- Author surface: `hx-ops`, `hx-each`, `hx-merge`, `hx-when`, `hx-case`, + `hx-append`; `define-construct` for record-body constructs. +- CLI verbs: `render` (`-o sexp|json|yaml|terraform|ansible`, `--path`), + `apply` (`--only`, `--dry-run`, `--list`), `tree` (`-v` with per-op fold + time), `explain PATH|HASH`, `show HASH`, `secret`, and `--version`. + Inventories add verbs with `defines-action`; global `--color`. +- Inventory is `-i/--inventory` or `$HEXOL_INVENTORY`, never a positional. +- Kubernetes library: standard resources (Deployment, Service, ConfigMap, + Secret, ...), Helm chart expansion, `checksum-config` rollout pass, a + `kubectl` applier. +- Terraform library: providers/resources/data sources rendered to Terraform + JSON; `tofu` applier with output reporting and a `validate` action. +- Ansible library: plays and tasks accumulated into a playbook. +- Inline SOPS/age secrets, path-keyed, with `(secret-ref 'k)` markers; + managed with `hexol secret ls|get|set|edit|rm|rekey|init`. +- Inventory-registered renderers (`renders-with`) and appliers + (`applies-with`); SQL and Ledger renderers as example extensions. +- Render cache for `helm template` / remote-manifest shell-outs. +- Examples: kubernetes, terraform, ansible, secrets, helm + kube-prometheus-stack, database-schema, ledger, and the homelab (3-node + Talos on OVH, deployed end to end). +- Docs: `docs/model.md`, `docs/authoring.md`, `docs/extending.md`. +- Packaging: `manifest.scm` (Guix dev shell, CI), `guix.scm` (Guix package), + `Containerfile` (OCI image), `flake.nix` (Nix package + devShell). +- CI: GitHub Actions runs build, tests, and example renders under Guix, and + builds the container image. + +[Unreleased]: https://github.com/Polyedre/hexol/compare/v0.1.0...HEAD +[0.1.0]: https://github.com/Polyedre/hexol/releases/tag/v0.1.0 diff --git a/Containerfile b/Containerfile new file mode 100644 index 0000000..ae129dd --- /dev/null +++ b/Containerfile @@ -0,0 +1,50 @@ +# Containerfile — hexol as a small OCI image. +# +# Trade-off: Alpine ships guile 3 + guile-json + jq, but not guile-libyaml +# (nor does Debian), so the first stage builds it from source with nyacc's +# ffi-helper — the same recipe Guix's guile-libyaml package uses. The +# alternative, `guix pack -f docker -m manifest.scm` (see `make image-guix`), +# is a one-liner but needs a Guix install and yields a ~300 MB image; this +# stays plain OCI, builds anywhere podman/docker runs, and lands ~60 MB. +# +# podman build -t hexol . +# podman run --rm -v "$PWD:/w" -w /w hexol render -i examples/kubernetes.scm + +ARG ALPINE=3.21 +ARG NYACC=3.02.0 +ARG LIBYAML=3.0.2 + +FROM alpine:${ALPINE} AS libyaml +ARG NYACC +ARG LIBYAML +RUN apk add --no-cache guile guile-dev gcc musl-dev make pkgconf yaml yaml-dev curl +WORKDIR /src +# nyacc: pure Guile; provides `guild compile-ffi`. +RUN curl -fsSL "https://download.savannah.gnu.org/releases/nyacc/nyacc-${NYACC}.tar.gz" | tar xz \ + && cd "nyacc-${NYACC}" && ./configure --prefix=/usr && make && make install +# guile-libyaml: generate the FFI bindings, compile, install into guile's site dirs. +RUN curl -fsSL "https://github.com/mwette/guile-libyaml/archive/refs/tags/V${LIBYAML}.tar.gz" | tar xz \ + && cd "guile-libyaml-${LIBYAML}" \ + && GUILE_AUTO_COMPILE=0 guild compile-ffi --no-exec yaml/libyaml.ffi \ + && sed -i 's| "libyaml"| "/usr/lib/libyaml"|' yaml/libyaml.scm \ + && site=/usr/share/guile/site/3.0 ccache=/usr/lib/guile/3.0/site-ccache \ + && for f in yaml.scm yaml/*.scm; do \ + mkdir -p "$site/$(dirname $f)" "$ccache/$(dirname $f)"; \ + cp "$f" "$site/$f"; \ + guild compile -L . -o "$ccache/${f%.scm}.go" "$f"; \ + done + +FROM alpine:${ALPINE} +RUN apk add --no-cache guile guile-json jq yaml make +COPY --from=libyaml /usr/share/guile/site/3.0/ /usr/share/guile/site/3.0/ +COPY --from=libyaml /usr/lib/guile/3.0/site-ccache/ /usr/lib/guile/3.0/site-ccache/ +COPY . /opt/hexol +WORKDIR /opt/hexol +# Precompile into the image so first run isn't a compile; XDG cache is where +# guile's auto-compiler looks, so point it at a fixed, world-readable dir. +ENV XDG_CACHE_HOME=/opt/hexol/.cache +RUN make build && guile -L . -e main -s bin/hexol --version && chmod -R a+rX /opt/hexol/.cache +# busybox `env` has no -S, so bin/hexol's shebang can't run as-is: invoke guile +# the way the shebang would (same shape as guix.scm's wrapper). +ENTRYPOINT ["guile", "-L", "/opt/hexol", "-e", "main", "-s", "/opt/hexol/bin/hexol"] +CMD ["--help"] diff --git a/Makefile b/Makefile index 32fa682..66719fc 100644 --- a/Makefile +++ b/Makefile @@ -1,4 +1,4 @@ -.PHONY: help test test-examples build clean +.PHONY: help test test-examples build image image-guix clean GUILE ?= guile @@ -7,7 +7,9 @@ help: @echo " make test run the smoke tests (kernel, surface, res, k8s, import)" @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" + @echo " make image build the OCI image from Containerfile (podman or docker)" + @echo " make image-guix same via guix pack (no container build needed)" + @echo " make clean remove this project's Guile compile cache" @echo @echo "everything else is the CLI — ./bin/hexol --help:" @echo " ./bin/hexol render [-o sexp|json|yaml|terraform|ansible] [--query K=V,…] [--path P] [-i INVENTORY]" @@ -19,6 +21,7 @@ help: @echo " ./bin/hexol lint [-i INVENTORY]" @echo " ./bin/hexol doc [CONSTRUCT] [-i INVENTORY]" @echo " ./bin/hexol import -f FILE|- [--from yaml|terraform] [--sugar] [--no-clean]" + @echo " ./bin/hexol --version" test: $(GUILE) -L . test.scm @@ -34,5 +37,16 @@ test-examples: build: @$(GUILE) -L . -c '(begin (use-modules (hexol) (hexol k8s) (hexol terraform) (hexol apply) (hexol ansible) (hexol ledger) (hexol sql) (hexol json) (hexol lint) (hexol import)) (display "build ok\n"))' +# Prefer podman, fall back to docker. IMAGE is the tag. +IMAGE ?= hexol +OCI ?= $(shell command -v podman || command -v docker) +image: + $(OCI) build -t $(IMAGE) . + +# Alternative: let Guix assemble the image from guix.scm (bigger image, but no +# source build of guile-libyaml). Loads the tarball into $(OCI). +image-guix: + $(OCI) load < "$$(guix pack -f docker -S /bin=bin --entry-point=bin/hexol -e '(load "guix.scm")')" + clean: rm -rf ~/.cache/guile/ccache/*$(CURDIR)* diff --git a/README.md b/README.md index 875437f..4efa284 100644 --- a/README.md +++ b/README.md @@ -56,26 +56,40 @@ A few things this buys you over plain manifests: ## Install +**Status:** 0.1.0 (`hexol --version`); see [CHANGELOG.md](CHANGELOG.md) for +what's in it and what's coming. + 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. +Three ways to get them: -The easy path is [Guix](https://guix.gnu.org/), which reads that manifest -directly — no manual install: +**From source** — install Guile 3.x, guile-json, guile-libyaml, and jq however +your distro provides them (or let [Guix](https://guix.gnu.org/) read the +manifest), then run from the checkout: ```sh git clone https://github.com/Polyedre/hexol && cd hexol -guix shell -m manifest.scm -- ./bin/hexol render -i examples/kubernetes.scm +./bin/hexol render -i examples/kubernetes.scm # auto-compiles on first use +guix shell -m manifest.scm -- ./bin/hexol render -i examples/kubernetes.scm # with Guix ``` -(The repo's `.envrc` does this automatically under [direnv](https://direnv.net/).) +(The repo's `.envrc` runs the `guix shell` for you under +[direnv](https://direnv.net/).) + +**Container** — an OCI image built from [`Containerfile`](Containerfile) +(`make image` builds it locally); mount your inventories in: + +```sh +podman run --rm -v "$PWD:/w" -w /w ghcr.io/polyedre/hexol render -i examples/kubernetes.scm +``` -Without Guix, install Guile 3.x plus guile-json, guile-libyaml, and jq however -your distro provides them, then: +**Nix** — [`flake.nix`](flake.nix) packages the CLI and provides a dev shell: ```sh -./bin/hexol render -i examples/kubernetes.scm # auto-compiles on first use +nix run github:Polyedre/hexol -- render -i examples/kubernetes.scm +nix develop github:Polyedre/hexol # guile + deps in a shell ``` The CLI itself shells out to nothing. Individual features do, and only when you diff --git a/bin/hexol b/bin/hexol index c6836f8..6f9fbd4 100755 --- a/bin/hexol +++ b/bin/hexol @@ -24,6 +24,7 @@ ;;; JSON -> an inventory (stdout) ;;; ;;; Inventory is -i/--inventory (or $HEXOL_INVENTORY), never a positional. +;;; `hexol --version` / `hexol version` prints the release ((hexol version)). ;;; ;;; render formats (-o / --output): sexp (default), json, yaml, terraform, ansible, ;;; plus any name an inventory registers with `renders-with`. @@ -66,6 +67,7 @@ ((hexol apply) #:select (current-diff-explainer)) ((hexol sh) #:select (which-cmd)) (ice-9 popen) + (hexol version) (srfi srfi-1) (srfi srfi-9) (ice-9 match) @@ -1269,6 +1271,10 @@ Global: --color[=always|never|auto] forces the human views' coloring.") (call-with-values (lambda () (extract-color (cdr args))) (lambda (mode rest) (when mode (set-color-mode! mode)) + ;; Version is frame-level like help: no inventory, no verb lookup. + (when (or (member "--version" rest) (equal? rest '("version"))) + (format #t "hexol ~a~%" %hexol-version) + (exit 0)) ;; One render cache per invocation, scoped to this inventory's content, so ;; helm-template / remote-manifest shell-outs are reused across runs. #f (no ;; inventory, or an unusable cache dir) disables it — results are identical. diff --git a/flake.lock b/flake.lock new file mode 100644 index 0000000..4e641bd --- /dev/null +++ b/flake.lock @@ -0,0 +1,27 @@ +{ + "nodes": { + "nixpkgs": { + "locked": { + "lastModified": 1788316716, + "narHash": "sha256-bc7rSpXIdn9QWGNqfWcPZWOhEVF8NoeAZkWq0XWnf/k=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "3ed67ec0a4d3c7ab4ae1f04f8ee8df07bfa506a2", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixos-unstable", + "repo": "nixpkgs", + "type": "github" + } + }, + "root": { + "inputs": { + "nixpkgs": "nixpkgs" + } + } + }, + "root": "root", + "version": 7 +} diff --git a/flake.nix b/flake.nix new file mode 100644 index 0000000..e239d5f --- /dev/null +++ b/flake.nix @@ -0,0 +1,103 @@ +{ + description = "hexol — extensible inventory engine (Guile)"; + + inputs.nixpkgs.url = "github:NixOS/nixpkgs/nixos-unstable"; + + outputs = { self, nixpkgs }: + let + systems = [ "x86_64-linux" "aarch64-linux" "x86_64-darwin" "aarch64-darwin" ]; + forAll = f: nixpkgs.lib.genAttrs systems (system: f nixpkgs.legacyPackages.${system}); + site = "share/guile/site/3.0"; + ccache = "lib/guile/3.0/site-ccache"; + + # nixpkgs has neither nyacc nor guile-libyaml, so build both here — the + # same recipe as the Containerfile and Guix's guile-libyaml package. + nyacc = pkgs: pkgs.stdenv.mkDerivation rec { + pname = "nyacc"; + version = "3.02.0"; + src = pkgs.fetchurl { + url = "https://download.savannah.gnu.org/releases/nyacc/nyacc-${version}.tar.gz"; + hash = "sha256-b6TOVTxg+bV7e0+0WHv5z8XkcW3Z5y/RR4bOWL+kEJE="; + }; + nativeBuildInputs = [ pkgs.guile_3_0 ]; + configureFlags = [ "--prefix=${placeholder "out"}" ]; + }; + guile-libyaml = pkgs: pkgs.stdenv.mkDerivation rec { + pname = "guile-libyaml"; + version = "3.0.2"; + src = pkgs.fetchurl { + url = "https://github.com/mwette/guile-libyaml/archive/refs/tags/V${version}.tar.gz"; + hash = "sha256-RQhh72Ic9xT8JEyvKzIlmvPprk03bh3kBCwsv22aWp0="; + }; + nativeBuildInputs = [ pkgs.guile_3_0 (nyacc pkgs) pkgs.libyaml.dev ]; + buildInputs = [ pkgs.libyaml ]; + GUILE_AUTO_COMPILE = "0"; + buildPhase = '' + export GUILE_LOAD_PATH=${nyacc pkgs}/${site} + export GUILE_LOAD_COMPILED_PATH=${nyacc pkgs}/${ccache} + guild compile-ffi --no-exec yaml/libyaml.ffi + sed -i 's| "libyaml"| "${pkgs.libyaml}/lib/libyaml"|' yaml/libyaml.scm + for f in yaml.scm yaml/*.scm; do + mkdir -p "$out/${ccache}/$(dirname $f)" "$out/${site}/$(dirname $f)" + guild compile -L . -o "$out/${ccache}/''${f%.scm}.go" "$f" + cp "$f" "$out/${site}/$f" + done + ''; + dontInstall = true; + }; + + # Runtime deps; mirrors manifest.scm (the source of truth). + deps = pkgs: [ pkgs.guile_3_0 pkgs.guile-json (guile-libyaml pkgs) (nyacc pkgs) pkgs.jq ]; + guileSite = pkgs: pkgs.lib.makeSearchPath site (deps pkgs); + guileCcache = pkgs: pkgs.lib.makeSearchPath ccache (deps pkgs); + in { + packages = forAll (pkgs: rec { + hexol = pkgs.stdenv.mkDerivation { + pname = "hexol"; + # Keep in sync with %hexol-version in hexol/version.scm. + version = "0.1.0"; + src = self; + nativeBuildInputs = [ pkgs.makeWrapper ] ++ deps pkgs; + dontConfigure = true; + dontPatchShebangs = true; # bin/hexol is run via the wrapper, not its shebang + GUILE_AUTO_COMPILE = "0"; + # Precompile the modules into a site-ccache so runs don't hit guile's + # auto-compiler (whose cache dir would be the read-only store). + buildPhase = '' + export GUILE_LOAD_PATH=.:${guileSite pkgs} + export GUILE_LOAD_COMPILED_PATH=${guileCcache pkgs} + for f in hexol.scm hexol/*.scm; do + mkdir -p "ccache/$(dirname $f)" + guild compile -L . -o "ccache/''${f%.scm}.go" "$f" + done + ''; + installPhase = '' + mkdir -p $out/share/hexol $out/${site} $out/lib/guile/3.0 $out/bin + cp -r bin $out/share/hexol/ + cp -r hexol hexol.scm $out/${site}/ + cp -r ccache $out/${ccache} + # bin/hexol's shebang uses `-L .`; run it explicitly instead, with + # the module paths in the environment. GUILE_AUTO_COMPILE=0 keeps + # guile from trying to cache the script itself under $HOME. + makeWrapper ${pkgs.guile_3_0}/bin/guile $out/bin/hexol \ + --add-flags "-e main -s $out/share/hexol/bin/hexol" \ + --set GUILE_AUTO_COMPILE 0 \ + --prefix GUILE_LOAD_PATH : "$out/${site}:${guileSite pkgs}" \ + --prefix GUILE_LOAD_COMPILED_PATH : "$out/${ccache}:${guileCcache pkgs}" \ + --prefix PATH : ${pkgs.lib.makeBinPath [ pkgs.jq ]} + ''; + meta = with pkgs.lib; { + description = "Extensible inventory engine"; + homepage = "https://github.com/Polyedre/hexol"; + license = licenses.gpl3Plus; + mainProgram = "hexol"; + }; + }; + default = hexol; + }); + + devShells = forAll (pkgs: { + default = pkgs.mkShell { packages = deps pkgs ++ [ pkgs.gnumake ]; }; + }); + }; +} diff --git a/guix.scm b/guix.scm index aefe4c6..0ce771e 100644 --- a/guix.scm +++ b/guix.scm @@ -7,7 +7,9 @@ (package (name "hexol") - (version "0.1") + ;; Keep in sync with %hexol-version in hexol/version.scm (a package definition + ;; can't load the module it packages, so this copy is unavoidable). + (version "0.1.0") (source (local-file "." "hexol-source" #:recursive? #t #:select? (lambda (f s) diff --git a/hexol/version.scm b/hexol/version.scm new file mode 100644 index 0000000..38a50cf --- /dev/null +++ b/hexol/version.scm @@ -0,0 +1,10 @@ +;;; hexol/version.scm — the one place the release version lives. +;;; +;;; `hexol --version` prints it; CHANGELOG.md's top entry and guix.scm's +;;; `version` field must agree with it (guix.scm can't import this module at +;;; package-definition time, so it carries a copy — see the comment there). + +(define-module (hexol version) + #:export (%hexol-version)) + +(define %hexol-version "0.1.0") From 94c8ec882bc7f067532dcb4e212ed433dc128b63 Mon Sep 17 00:00:00 2001 From: Polyedre Date: Sat, 5 Sep 2026 15:19:09 +0200 Subject: [PATCH 09/12] ci: build image with -f Containerfile (docker looks for Dockerfile) --- .github/workflows/ci.yml | 2 +- Makefile | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 71ca6dc..62b06ed 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -70,7 +70,7 @@ jobs: steps: - uses: actions/checkout@v4 - name: Build the image - run: docker build -t hexol:ci . + run: docker build -f Containerfile -t hexol:ci . - name: Smoke-test it run: | docker run --rm hexol:ci --version diff --git a/Makefile b/Makefile index 66719fc..9904bc5 100644 --- a/Makefile +++ b/Makefile @@ -41,7 +41,7 @@ build: IMAGE ?= hexol OCI ?= $(shell command -v podman || command -v docker) image: - $(OCI) build -t $(IMAGE) . + $(OCI) build -f Containerfile -t $(IMAGE) . # Alternative: let Guix assemble the image from guix.scm (bigger image, but no # source build of guile-libyaml). Loads the tarball into $(OCI). From 35e68422c18f4ba21d094c29d83cf4059a4d22ca Mon Sep 17 00:00:00 2001 From: Polyedre Date: Sat, 5 Sep 2026 15:22:17 +0200 Subject: [PATCH 10/12] Containerfile: fetch nyacc from Savannah mirror, retry downloads --- Containerfile | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Containerfile b/Containerfile index ae129dd..5617656 100644 --- a/Containerfile +++ b/Containerfile @@ -20,10 +20,10 @@ ARG LIBYAML RUN apk add --no-cache guile guile-dev gcc musl-dev make pkgconf yaml yaml-dev curl WORKDIR /src # nyacc: pure Guile; provides `guild compile-ffi`. -RUN curl -fsSL "https://download.savannah.gnu.org/releases/nyacc/nyacc-${NYACC}.tar.gz" | tar xz \ +RUN curl -fsSL --retry 5 --retry-all-errors "https://download-mirror.savannah.gnu.org/releases/nyacc/nyacc-${NYACC}.tar.gz" | tar xz \ && cd "nyacc-${NYACC}" && ./configure --prefix=/usr && make && make install # guile-libyaml: generate the FFI bindings, compile, install into guile's site dirs. -RUN curl -fsSL "https://github.com/mwette/guile-libyaml/archive/refs/tags/V${LIBYAML}.tar.gz" | tar xz \ +RUN curl -fsSL --retry 5 --retry-all-errors "https://github.com/mwette/guile-libyaml/archive/refs/tags/V${LIBYAML}.tar.gz" | tar xz \ && cd "guile-libyaml-${LIBYAML}" \ && GUILE_AUTO_COMPILE=0 guild compile-ffi --no-exec yaml/libyaml.ffi \ && sed -i 's| "libyaml"| "/usr/lib/libyaml"|' yaml/libyaml.scm \ From 2bd866a0c2333fd223857f724dfb8b3b453c0ed5 Mon Sep 17 00:00:00 2001 From: Polyedre Date: Sat, 5 Sep 2026 15:35:08 +0200 Subject: [PATCH 11/12] import: port libyaml FFI to nyacc cdata; CI pulls current Guix guile-libyaml 3.0.2 (what manifest.scm resolves to today, and what the Containerfile builds) generates its bindings with nyacc's cdata backend; (system ffi-help-rt) / (bytestructures guile) only existed in a stale personal profile. Rewrite read-yaml-documents / convert-tree on cdata. Containerfile: point the binding at libyaml-0.so.2 (Alpine's runtime package has no unversioned .so). CI: guix pull before guix shell, since the 1.4.0 binary ships the pre-cdata guile-libyaml. --- .github/workflows/ci.yml | 7 ++++- Containerfile | 2 +- hexol/import.scm | 65 +++++++++++++++++++++------------------- 3 files changed, 41 insertions(+), 33 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 62b06ed..7b4fbd2 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -50,7 +50,12 @@ jobs: sudo "$GUIX_BIN/guix" archive --authorize \ < "$GUIX_PROFILE/share/guix/ci.guix.gnu.org.pub" - "$GUIX_BIN/guix" --version + # The 1.4.0 tarball is from 2022 and ships the old guile-libyaml + # (ffi-help-rt API); (hexol import) targets the current one (nyacc + # cdata), so bring Guix up to date before resolving manifest.scm. + sudo "$GUIX_BIN/guix" pull + GUIX_BIN=/root/.config/guix/current/bin + sudo "$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 — diff --git a/Containerfile b/Containerfile index 5617656..2128ee3 100644 --- a/Containerfile +++ b/Containerfile @@ -26,7 +26,7 @@ RUN curl -fsSL --retry 5 --retry-all-errors "https://download-mirror.savannah.gn RUN curl -fsSL --retry 5 --retry-all-errors "https://github.com/mwette/guile-libyaml/archive/refs/tags/V${LIBYAML}.tar.gz" | tar xz \ && cd "guile-libyaml-${LIBYAML}" \ && GUILE_AUTO_COMPILE=0 guild compile-ffi --no-exec yaml/libyaml.ffi \ - && sed -i 's| "libyaml"| "/usr/lib/libyaml"|' yaml/libyaml.scm \ + && sed -i 's| "libyaml"| "/usr/lib/libyaml-0.so.2"|' yaml/libyaml.scm \ && site=/usr/share/guile/site/3.0 ccache=/usr/lib/guile/3.0/site-ccache \ && for f in yaml.scm yaml/*.scm; do \ mkdir -p "$site/$(dirname $f)" "$ccache/$(dirname $f)"; \ diff --git a/hexol/import.scm b/hexol/import.scm index c66b54b..ddda885 100644 --- a/hexol/import.scm +++ b/hexol/import.scm @@ -37,8 +37,7 @@ #:use-module ((hexol yaml) #:select (object-shape?)) #:autoload (hexol k8s) (res) #:use-module (yaml libyaml) - #:use-module (system ffi-help-rt) - #:use-module (bytestructures guile) + #:use-module (nyacc foreign cdata) #:use-module ((system foreign) #:prefix ffi:) #:use-module (rnrs bytevectors) #:use-module (json) @@ -73,42 +72,47 @@ ;; in source order; a `null` value drops its key (there is no null in the ;; state model — an absent key renders the same as YAML's absence). Sequences ;; become lists; a null item becomes '() (renders `{}`). +;; libyaml's node stack is a yaml_node_t* (1-based indices); compute the +;; element address by hand and wrap it as a node pointer. +(define (node-at stack index) + (make-cdata yaml_node_t* + (+ (ffi:pointer-address (cdata-ref stack)) + (* (1- index) (ctype-size yaml_node_t))))) + (define (convert-tree root stack) (define (scalar node) - (let ((style (wrap-yaml_scalar_style_t (bytestructure-ref node 'data 'scalar 'style))) - (text (ffi:pointer->string - (ffi:make-pointer (bytestructure-ref node 'data 'scalar 'value))))) + (let ((style (cdata*-ref node 'data 'scalar 'style)) + (text (ffi:pointer->string (cdata*-ref node 'data 'scalar 'value)))) (if (eq? style 'YAML_PLAIN_SCALAR_STYLE) (plain-scalar->scm text) text))) ;; Walk a libyaml stack (items or pairs) from TOP back to START, SIZE bytes ;; per slot, collecting (f slot-address) in order. (define (slots start top size f) - (let loop ((acc '()) (addr (- top size))) - (if (>= addr start) + (let loop ((acc '()) (addr (- (ffi:pointer-address top) size))) + (if (>= addr (ffi:pointer-address start)) (loop (cons (f addr) acc) (- addr size)) acc))) - (define (node-at index) (bytestructure-ref stack (1- index))) (define (convert node) - (case (wrap-yaml_node_type_t (bytestructure-ref node 'type)) + (case (cdata*-ref node 'type) ((YAML_SCALAR_NODE) (scalar node)) ((YAML_SEQUENCE_NODE) (map (lambda (v) (if (eq? v 'null) '() v)) - (slots (bytestructure-ref node 'data 'sequence 'items 'start) - (bytestructure-ref node 'data 'sequence 'items 'top) - (bytestructure-descriptor-size yaml_node_item_t-desc) + (slots (cdata*-ref node 'data 'sequence 'items 'start) + (cdata*-ref node 'data 'sequence 'items 'top) + (ctype-size yaml_node_item_t) (lambda (addr) - (convert (node-at (bytestructure-ref (bytestructure int*-desc addr) '*))))))) + (convert (node-at stack (cdata-ref (make-cdata (cpointer 'int) addr) '*))))))) ((YAML_MAPPING_NODE) (filter-map (lambda (kv) (and (not (eq? (cdr kv) 'null)) kv)) - (slots (bytestructure-ref node 'data 'mapping 'pairs 'start) - (bytestructure-ref node 'data 'mapping 'pairs 'top) - (bytestructure-descriptor-size yaml_node_pair_t-desc) + (slots (cdata*-ref node 'data 'mapping 'pairs 'start) + (cdata*-ref node 'data 'mapping 'pairs 'top) + (ctype-size yaml_node_pair_t) (lambda (addr) - (let ((pair (bytestructure yaml_node_pair_t*-desc addr))) + (let ((pair (make-cdata yaml_node_pair_t* addr))) (cons (string->symbol - (let ((k (convert (node-at (bytestructure-ref pair '* 'key))))) + (let ((k (convert (node-at stack (cdata*-ref pair 'key))))) (if (string? k) k (format #f "~a" k)))) - (convert (node-at (bytestructure-ref pair '* 'value))))))))) + (convert (node-at stack (cdata*-ref pair 'value))))))))) (else (error "yaml: unexpected node type")))) (convert root)) @@ -116,29 +120,28 @@ "Parse TEXT, a YAML stream, into a list of documents in stream order. Maps are symbol-keyed alists, sequences lists; plain scalars are typed (number / boolean), quoted and block scalars stay strings." - (let* ((parser (make-yaml_parser_t)) - (&parser (pointer-to parser)) + (let* ((parser (make-cdata yaml_parser_t)) + (&parser (cdata& parser)) (bv (string->utf8 text))) (yaml_parser_initialize &parser) (yaml_parser_set_input_string &parser (ffi:bytevector->pointer bv) (bytevector-length bv)) (let loop ((docs '())) - (let* ((document (make-yaml_document_t)) - (&document (pointer-to document))) + (let* ((document (make-cdata yaml_document_t)) + (&document (cdata& document))) (when (zero? (yaml_parser_load &parser &document)) - (let ((problem (fh-object-ref parser 'problem)) - (line (fh-object-ref parser 'problem_mark 'line))) + (let ((problem (cdata-ref parser 'problem)) + (line (cdata-ref parser 'problem_mark 'line))) (yaml_parser_delete &parser) (error (format #f "yaml: line ~a: ~a" (1+ line) - (if (zero? problem) "parse error" - (ffi:pointer->string (ffi:make-pointer problem))))))) + (if (NULL? problem) "parse error" + (ffi:pointer->string problem)))))) (let ((root (yaml_document_get_root_node &document))) - (if (zero? (fh-object-ref root)) ; NULL root: end of stream + (if (NULL? root) ; NULL root: end of stream (begin (yaml_document_delete &document) (yaml_parser_delete &parser) (reverse docs)) - (let* ((stack (bytestructure yaml_node_t*-desc - (fh-object-ref document 'nodes 'start))) - (tree (convert-tree (fh-object-val root) stack))) + (let* ((stack (cdata-sel document 'nodes 'start)) + (tree (convert-tree root stack))) (yaml_document_delete &document) (loop (cons tree docs))))))))) From 6d559d2681f69b0e8d30756491e1f84d4f029d1f Mon Sep 17 00:00:00 2001 From: Polyedre Date: Sat, 5 Sep 2026 15:37:00 +0200 Subject: [PATCH 12/12] ci: guix pull from the Codeberg mirror (1.4.0's libgit2 can't follow Savannah's redirect) --- .github/workflows/ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 7b4fbd2..2e37fdb 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -53,7 +53,7 @@ jobs: # The 1.4.0 tarball is from 2022 and ships the old guile-libyaml # (ffi-help-rt API); (hexol import) targets the current one (nyacc # cdata), so bring Guix up to date before resolving manifest.scm. - sudo "$GUIX_BIN/guix" pull + sudo "$GUIX_BIN/guix" pull --url=https://codeberg.org/guix/guix.git GUIX_BIN=/root/.config/guix/current/bin sudo "$GUIX_BIN/guix" --version