jpkg phase 7: federation and hardening
ober
1d2fe9b46848a91934c7285f8f5cc0a46d2c74fd
--- a/docs/jpkg-plan.md +++ b/docs/jpkg-plan.md @@ -619,7 +619,26 @@ Tracked per phase as implementation lands. Tests live in `tests/test-jpkg*.ss` 26 new tests: OSV matching edges, audit blocking/yank reporting, search ranking, dir management. Every command surface entry is now implemented (no stubs remain). -- Phase 7 (federation and hardening): not started. +- Phase 7 (federation and hardening): DONE. TUF targets delegation — + the top targets role delegates `packages/@scope/*` to per-scope + maintainer keys with their own threshold; the client follows the + delegation, verifies the delegated role's metadata against the + delegation authority + snapshot, and only then accepts targets under + that scope; version listings come from top + delegated signed targets + (`tuf.ss`: delegate/sign-delegated/transfer + delegation-aware + resolver). Namespace transfer re-delegates a scope to new keys under + the top role's authority (threshold-maintainer). Append-only, + hash-chained transparency log with inclusion + consistency + (anti-equivocation) checks, carried as a TUF target; `jpkg publish` + appends to it and `jpkg audit` monitors inclusion/consistency against + a client-cached head (`transparency.json`, `transparency.ss`, + `audit.ss`). Reproducible-rebuild verification leverages deterministic + pack: `jpkg verify --reproduce` / `--rebuild DIGEST` (`rebuild.ss`), + plus a security-review summary aggregating capability/signature/ + provenance/advisory/yank/reproducibility signals. 52 new tests. + +All seven implementation phases are complete; every command in the +command surface is implemented and the full design document is realized. ## References --- a/lib/std/pkg/audit.ss +++ b/lib/std/pkg/audit.ss @@ -15,7 +15,8 @@ (export audit-project audit-report-findings audit-report-blocking? finding-name finding-version finding-kind finding-detail finding-action finding-fixed - load-registry-advisories) + load-registry-advisories + check-transparency) (import (chezscheme) (only (jerboa core) def defstruct try catch) @@ -24,7 +25,8 @@ (only (std pkg lock) lock-parse-file lock-file-name locked-package-name locked-package-version - locked-package-registry locked-package-link) + locked-package-registry locked-package-link + locked-package-artifact-sha256) (only (std pkg registry) registry-config registry-lookup registry-release-for release-info-yanked?) @@ -33,7 +35,11 @@ advisory-summary advisory-severity advisory-fixed-versions action-blocks-new? action-blocks-all?) (only (std pkg tuf) - tuf-registry? tuf-context tuf-verified-target-bytes)) + tuf-registry? tuf-context tuf-verified-target-bytes) + (only (std pkg transparency) + transparency-parse transparency-includes? transparency-consistent? + transparency-length) + (only (std pkg util) mkdir-p write-file-bytevector random-suffix)) (defstruct finding (name version kind detail action fixed)) ;; kind: 'advisory | 'yanked ; action: advisory action or #f @@ -74,6 +80,80 @@ (directory-list adv-dir))))] [else '()]))) + ;; ── transparency monitoring ──────────────────────────────────────────── + + (def (jpkg-home*) + (or (getenv "JERBOA_PKG_HOME") + (let ([home (or (getenv "HOME") (jpkg-error "audit: HOME not set"))]) + (path-concat home ".jerboa/pkg")))) + + (def (load-registry-transparency reg-name reg-path) + ;; TUF-verified transparency.json (or plain), parsed + chain-checked. + (let ([bytes + (cond + [(tuf-registry? reg-path) + (guard (e [#t #f]) + (let ([targets (tuf-context reg-name reg-path)]) + (tuf-verified-target-bytes targets reg-path "transparency.json")))] + [(file-exists? (path-concat reg-path "transparency.json")) + (read-file-bytevector (path-concat reg-path "transparency.json"))] + [else #f])]) + (and bytes + (transparency-parse + (or (bytes->utf8-or-false bytes) + (jpkg-error "audit: transparency.json not UTF-8")))))) + + ;; Returns a list of transparency findings (inclusion gaps, equivocation) + ;; and updates the client-side consistency cache. + (def (check-transparency reg-name reg-path pkgs) + (let ([t (guard (e [#t #f]) (load-registry-transparency reg-name reg-path))]) + (if (not t) + '() + (let ([findings '()] + [cache-path (path-concat (jpkg-home*) + (string-append "transparency/" + reg-name ".json"))]) + ;; consistency vs the last-seen log (equivocation / history rewrite) + (when (file-exists? cache-path) + (let ([prev (guard (e [#t #f]) + (transparency-parse + (or (bytes->utf8-or-false (read-file-bytevector cache-path)) + "")))]) + (when (and prev (not (transparency-consistent? prev t))) + (set! findings + (cons (make-finding reg-name "" 'transparency + "transparency log is NOT consistent with the previously seen log — possible equivocation / history rewrite" + 'block-all '()) + findings))))) + ;; inclusion: every locked package must appear in the log + (for-each + (lambda (p) + (let ([name (locked-package-name p)] + [version (locked-package-version p)] + [digest (locked-package-artifact-sha256 p)]) + (when (and digest + (not (transparency-includes? t name version digest))) + (set! findings + (cons (make-finding name version 'transparency + "release is NOT recorded in the transparency log" + 'warn '()) + findings))))) + pkgs) + ;; refresh the cache (the verified bytes) for next-time consistency + (let ([bytes (guard (e [#t #f]) + (read-reg-transparency-bytes reg-name reg-path))]) + (when bytes + (mkdir-p (path-concat (jpkg-home*) "transparency")) + (write-file-bytevector cache-path bytes))) + (reverse findings))))) + + (def (read-reg-transparency-bytes reg-name reg-path) + (cond + [(tuf-registry? reg-path) + (let ([targets (tuf-context reg-name reg-path)]) + (tuf-verified-target-bytes targets reg-path "transparency.json"))] + [else (read-file-bytevector (path-concat reg-path "transparency.json"))])) + ;; ── audit ────────────────────────────────────────────────────────────── (def (audit-project) @@ -125,14 +205,35 @@ #f '()) findings))))))) pkgs) + ;; transparency-log monitoring per registry (inclusion + consistency) + (let ([by-reg '()]) + (for-each + (lambda (p) + (unless (locked-package-link p) + (let ([reg (locked-package-registry p)]) + (let ([cell (assoc reg by-reg)]) + (if cell + (set-cdr! cell (cons p (cdr cell))) + (set! by-reg (cons (list reg p) by-reg))))))) + pkgs) + (for-each + (lambda (cell) + (let ([reg (car cell)]) + (for-each (lambda (f) (set! findings (cons f findings))) + (guard (e [#t '()]) + (check-transparency reg (registry-lookup reg) (cdr cell)))))) + by-reg)) (let ([fs (reverse findings)]) (make-audit-report fs - ;; blocking when any advisory action blocks installs + ;; blocking when an advisory action blocks installs, or the + ;; transparency log is inconsistent (block-all) (and (exists (lambda (f) - (and (eq? (finding-kind f) 'advisory) - (or (action-blocks-new? (finding-action f)) - (action-blocks-all? (finding-action f))))) + (or (and (eq? (finding-kind f) 'advisory) + (or (action-blocks-new? (finding-action f)) + (action-blocks-all? (finding-action f)))) + (and (eq? (finding-kind f) 'transparency) + (eq? (finding-action f) 'block-all)))) fs) #t))))) --- a/lib/std/pkg/commands.ss +++ b/lib/std/pkg/commands.ss @@ -54,6 +54,7 @@ search-row-name search-row-version search-row-registry search-row-yanked? search-row-provenance? search-row-tuf? dir-list dir-add! dir-remove!) + (only (std pkg rebuild) rebuild-verify rebuild-digest) (only (std crypto random) random-bytes)) (def (say fmt . args) @@ -189,6 +190,15 @@ (say "ok: jpkg.sexp valid (~a ~a)" (manifest-name m) (manifest-version m)) (verify-lock-report #t) 0)] + ;; --rebuild DIGEST: prove the current source reproduces an artifact + [(and (= (length args) 2) (string=? (car args) "--rebuild")) + (rebuild-verify "." (cadr args)) + (say "ok: source reproduces artifact ~a" (cadr args)) + 0] + ;; --reproduce: print this project's deterministic artifact digest + [(and (null? (cdr args)) (string=? (car args) "--reproduce")) + (say "~a" (rebuild-digest ".")) + 0] ;; verify an artifact file [(and (null? (cdr args)) (string-suffix-of? ".jpkg" (car args))) (let* ([info (artifact-validate (car args))] @@ -201,7 +211,7 @@ (say " size: ~a bytes" (artifact-info-size info)) (say " files: ~a" (length files)) 0)] - [else (jpkg-error "usage: jpkg verify [--strict | FILE.jpkg]")])) + [else (jpkg-error "usage: jpkg verify [--strict | --rebuild DIGEST | --reproduce | FILE.jpkg]")])) ;; ── phase 2: dependency + environment commands ───────────────────────── @@ -399,6 +409,9 @@ (string-join-list (finding-fixed f) ", ")))] [(yanked) (say "~a ~a YANKED" (finding-name f) (finding-version f)) + (say " ~a" (finding-detail f))] + [(transparency) + (say "~a ~a TRANSPARENCY" (finding-name f) (finding-version f)) (say " ~a" (finding-detail f))])) findings) (say "") --- a/lib/std/pkg/publish.ss +++ b/lib/std/pkg/publish.ss @@ -44,6 +44,9 @@ pubhex->keyid) (only (std pkg registry) registry-generate-skeleton registry-add-signed-package!) + (only (std pkg transparency) + transparency-empty transparency-parse transparency-append + transparency->json) (only (std pkg tuf) tuf-keygen tuf-registry? tuf-registry-init! tuf-registry-sign! tuf-now)) @@ -178,9 +181,21 @@ keyid seed))]) (registry-add-signed-package! reg-path apath sig-json prov-json) (delete-file apath) + ;; append to the append-only transparency log + (append-transparency! reg-path name version digest keyid) ;; re-sign TUF so the new files become covered targets (when roles (tuf-registry-sign! reg-path roles expires)) (values name version digest))))) + (def (append-transparency! reg-path name version digest keyid) + (let* ([path (path-concat reg-path "transparency.json")] + [t (if (file-exists? path) + (transparency-parse + (or (bytes->utf8-or-false (read-file-bytevector path)) + (jpkg-error "publish: transparency.json not UTF-8"))) + (transparency-empty))] + [t2 (transparency-append t name version digest keyid)]) + (write-file-bytevector path (string->utf8 (transparency->json t2))))) + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/pkg/rebuild.ss @@ -0,0 +1,88 @@ +#!chezscheme +;;; (std pkg rebuild) — reproducible-rebuild verification. +;;; +;;; Because `jpkg pack` is byte-deterministic, a package's artifact digest +;;; is reproducible from its source. `rebuild-verify` re-packs a source +;;; checkout and checks the resulting digest against an expected one +;;; (from the lockfile / registry / published attestation), proving the +;;; published artifact corresponds to the given source (docs/jpkg-plan.md +;;; "reproducible rebuild verification for selected packages"). +;;; +;;; A security-review summary (`review-package`) aggregates the signals +;;; the earlier phases produce — declared capabilities, signature and +;;; provenance presence, advisories, yank status, reproducibility — into +;;; one report, without claiming any of it proves safety. + +(library (std pkg rebuild) + (export rebuild-digest rebuild-verify + review-package review->lines) + + (import (chezscheme) + (only (jerboa core) def try catch) + (only (std pkg util) + jpkg-error path-concat random-suffix remove-tree + string-join-list) + (only (std pkg artifact) + pack-project artifact-validate artifact-info-manifest + artifact-info-digest) + (only (std pkg manifest) + parse-manifest-file manifest-name manifest-version + manifest-capabilities)) + + ;; ── reproducible rebuild ─────────────────────────────────────────────── + + (def (rebuild-digest project-dir) + ;; deterministically pack project-dir to a temp artifact; return digest + (let ([tmp (format "/tmp/jpkg-rebuild-~a.jpkg" (random-suffix))]) + (let-values ([(path digest size) (pack-project project-dir tmp)]) + (delete-file tmp) + digest))) + + (def (rebuild-verify project-dir expected-digest) + ;; -> #t if the rebuilt artifact's digest matches; raises otherwise + (let ([got (rebuild-digest project-dir)]) + (unless (string=? got expected-digest) + (jpkg-error "rebuild: digest mismatch — source does not reproduce the artifact\n expected ~a\n rebuilt ~a" + expected-digest got)) + #t)) + + ;; ── security review summary ──────────────────────────────────────────── + ;; signals: alist with keys provided by the caller (it has registry + + ;; advisory context); this assembles them into an ordered report. + ;; (capabilities . (sym ...)) declared capability kinds + ;; (signed . bool) package signature present + verified + ;; (provenance . #f | builder) provenance builder id or #f + ;; (advisories . N) count of active advisories + ;; (yanked . bool) + ;; (reproducible . #f | bool | 'unchecked) + + (def (review-package name version signals) + (let ([g (lambda (k d) (let ([p (assq k signals)]) (if p (cdr p) d)))]) + (list (cons "name" name) + (cons "version" version) + (cons "capabilities" (g 'capabilities '())) + (cons "signed" (g 'signed #f)) + (cons "provenance" (g 'provenance #f)) + (cons "advisories" (g 'advisories 0)) + (cons "yanked" (g 'yanked #f)) + (cons "reproducible" (g 'reproducible 'unchecked))))) + + (def (review->lines review) + (let ([g (lambda (k) (cdr (assoc k review)))]) + (list + (format "~a ~a" (g "name") (g "version")) + (format " capabilities: ~a" + (if (null? (g "capabilities")) "none declared" + (string-join-list (map symbol->string (g "capabilities")) ", "))) + (format " signature: ~a" (if (g "signed") "present + verified" "ABSENT")) + (format " provenance: ~a" (or (g "provenance") "ABSENT")) + (format " advisories: ~a" (g "advisories")) + (format " yanked: ~a" (if (g "yanked") "YES" "no")) + (format " reproducible: ~a" + (case (g "reproducible") + [(unchecked) "not checked"] + [(#t) "yes — source reproduces the artifact"] + [(#f) "NO — source does not reproduce the artifact"] + [else (g "reproducible")]))))) + + ) ;; end library --- a/lib/std/pkg/registry.ss +++ b/lib/std/pkg/registry.ss @@ -55,7 +55,8 @@ artifact-info-size artifact-info-entries) (only (std pkg tarball) tar-entry-name tar-entry-dir? tar-entry-content) (only (std pkg tuf) - tuf-registry? tuf-context tuf-verified-target-bytes) + tuf-registry? tuf-context tuf-verified-target-bytes + tuf-all-target-paths) (only (std pkg provenance) signed-subject verify-package-signature publishers-parse publishers-keys-for publishers-builders-for @@ -222,15 +223,15 @@ ;; could hide versions (downgrade-by-omission). (if (tuf-registry? reg-path) (let* ([targets-signed (tuf-targets-for name reg-path)] - [targets (or (canon-ref targets-signed "targets") '())] + [target-paths (tuf-all-target-paths targets-signed reg-path)] [prefix (string-append "packages/" pkg "/")] [suffix "/release.json"]) (list-sort string<? (filter (lambda (v) (and v (semver-try-parse v))) - (map (lambda (entry) - (let ([path (car entry)]) + (map (lambda (path) + (begin (and (string? path) (>= (string-length path) (+ (string-length prefix) (string-length suffix))) @@ -250,7 +251,7 @@ [(char=? (string-ref v i) #\/) #t] [else (loop (+ i 1))]))) v))))) - targets)))) + target-paths)))) (registry-package-versions reg-path pkg))) ;; ── publisher trust + authorship verification (phase 4) ──────────────── new file mode 100644 --- /dev/null +++ b/lib/std/pkg/transparency.ss @@ -0,0 +1,137 @@ +#!chezscheme +;;; (std pkg transparency) — append-only, hash-chained publish log. +;;; +;;; Each published release appends an entry to a transparency log so that +;;; independent monitors can detect equivocation or surreptitious +;;; publishes (docs/jpkg-plan.md "Publishing": "publishes enough data for +;;; independent monitoring"). +;;; +;;; Log shape (canonical JSON), stored as transparency.json (a TUF target +;;; so a mirror cannot rewrite it): +;;; {"entries": [ {"index": N, +;;; "name","version","artifact-sha256","keyid", +;;; "prev": <sha256 of prior entry's canonical JSON, or +;;; 64 zeros for index 0>} ... ], +;;; "head": <sha256 of the last entry's canonical JSON>} +;;; +;;; The chain is verifiable two ways: +;;; - inclusion: a release (name,version,digest) appears in the log +;;; - consistency: a newer log EXTENDS an older one — the first K +;;; entries are byte-identical (no history rewrite) + +(library (std pkg transparency) + (export transparency-empty + transparency-append + transparency-verify-chain + transparency-includes? + transparency-consistent? + transparency->json transparency-parse + transparency-head transparency-length + entry-name entry-version entry-digest entry-keyid entry-index) + + (import (chezscheme) + (only (jerboa core) def defstruct try catch) + (only (std pkg util) jpkg-error sha256-hex-of-bytevector) + (only (std pkg canonical) canonical-json) + (only (std pkg store) valid-digest?) + (only (std text json) string->json-object)) + + (def zero-hash (make-string 64 #\0)) + + (defstruct tlog (entries head)) + (defstruct entry (index name version digest keyid prev)) + + (def (transparency-empty) (make-tlog '() zero-hash)) + + (def (transparency-head t) (tlog-head t)) + (def (transparency-length t) (length (tlog-entries t))) + + ;; canonical JSON of one entry (the hashed unit) + (def (entry->canonical e) + (list (cons "artifact-sha256" (entry-digest e)) + (cons "index" (entry-index e)) + (cons "keyid" (entry-keyid e)) + (cons "name" (entry-name e)) + (cons "prev" (entry-prev e)) + (cons "version" (entry-version e)))) + + (def (entry-hash e) + (sha256-hex-of-bytevector (string->utf8 (canonical-json (entry->canonical e))))) + + (def (transparency-append t name version digest keyid) + (unless (valid-digest? digest) + (jpkg-error "transparency: bad artifact-sha256")) + (let* ([entries (tlog-entries t)] + [index (length entries)] + [prev (tlog-head t)] + [e (make-entry index name version digest keyid prev)]) + (make-tlog (append entries (list e)) (entry-hash e)))) + + ;; ── verification ─────────────────────────────────────────────────────── + + (def (transparency-verify-chain t) + ;; recompute the chain; head must match and prev links must be intact + (let loop ([entries (tlog-entries t)] [expected-prev zero-hash] [index 0]) + (cond + [(null? entries) + (let ([computed (if (= index 0) zero-hash expected-prev)]) + (unless (string=? computed (tlog-head t)) + (jpkg-error "transparency: head does not match chain (tampered log?)")) + #t)] + [else + (let ([e (car entries)]) + (unless (= (entry-index e) index) + (jpkg-error "transparency: entry index out of order at ~a" index)) + (unless (string=? (entry-prev e) expected-prev) + (jpkg-error "transparency: broken hash chain at index ~a" index)) + (loop (cdr entries) (entry-hash e) (+ index 1)))]))) + + (def (transparency-includes? t name version digest) + (and (exists (lambda (e) + (and (string=? (entry-name e) name) + (string=? (entry-version e) version) + (string=? (entry-digest e) digest))) + (tlog-entries t)) + #t)) + + ;; newer extends older: older's entries are a byte-identical prefix. + (def (transparency-consistent? older newer) + (let ([oe (tlog-entries older)] [ne (tlog-entries newer)]) + (and (<= (length oe) (length ne)) + (let loop ([oe oe] [ne ne]) + (cond + [(null? oe) #t] + [(string=? (canonical-json (entry->canonical (car oe))) + (canonical-json (entry->canonical (car ne)))) + (loop (cdr oe) (cdr ne))] + [else #f]))))) + + ;; ── serialization ────────────────────────────────────────────────────── + + (def (transparency->json t) + (canonical-json + (list (cons "entries" + (list->vector (map entry->canonical (tlog-entries t)))) + (cons "head" (tlog-head t))))) + + (def (oref h k) (hashtable-ref h k #f)) + + (def (transparency-parse text) + (let* ([root (try (string->json-object text) + (catch (e) (jpkg-error "transparency: unparseable")))] + [entries-json (oref root "entries")] + [head (oref root "head")]) + (unless (and (list? entries-json) (string? head)) + (jpkg-error "transparency: malformed log")) + (let ([entries + (map (lambda (ej) + (unless (hashtable? ej) (jpkg-error "transparency: bad entry")) + (make-entry (oref ej "index") (oref ej "name") + (oref ej "version") (oref ej "artifact-sha256") + (oref ej "keyid") (oref ej "prev"))) + entries-json)]) + (let ([t (make-tlog entries head)]) + (transparency-verify-chain t) ;; parse-time integrity + t)))) + + ) ;; end library --- a/lib/std/pkg/tuf.ss +++ b/lib/std/pkg/tuf.ss @@ -27,8 +27,10 @@ (export ;; client tuf-context tuf-verified-target-bytes tuf-registry? + tuf-all-target-paths ;; generator tuf-keygen tuf-registry-init! tuf-registry-sign! tuf-rotate-root! + tuf-registry-delegate! tuf-registry-sign-delegated! tuf-transfer-scope! ;; shared (used by phase-4 publish + tests) json-file->canonical canonical-of-json-text signed-payload-bytes key->keyid iso8601-of-epoch tuf-now) @@ -243,6 +245,17 @@ (def (tuf-registry? reg-path) (file-exists? (path-concat reg-path "metadata/root.json"))) + ;; Per-registry verification context, populated by tuf-context and read + ;; by the delegation-aware target resolver. Keyed by reg-path string. + ;; ctx = (snapshot-signed root-keydb) + (def *ctx-table* '()) + (def (ctx-set! reg-path ctx) + (set! *ctx-table* (cons (cons reg-path ctx) + (filter (lambda (p) (not (string=? (car p) reg-path))) + *ctx-table*)))) + (def (ctx-get reg-path) + (let ([p (assoc reg-path *ctx-table*)]) (and p (cdr p)))) + (def (verify-root-self envelope) ;; a root envelope must satisfy ITS OWN root role (let* ([signed (oref! envelope "signed" "root")] @@ -378,15 +391,82 @@ (state-set st 'timestamp ts-version) 'snapshot sn-version) 'targets tg-version)) + ;; record context for delegation-aware target resolution + (ctx-set! reg-path (list sn-signed keydb)) tg-signed)))))))) - ;; Verified read of a target file (e.g. a release.json): bytes are - ;; returned ONLY if length+sha256 match the signed targets metadata. - (def (tuf-verified-target-bytes targets-signed reg-path target-path) - (let* ([targets (oref! targets-signed "targets" "targets")] - [entry (or (oref targets target-path) - (jpkg-error "tuf: ~a not in signed targets" target-path))] - [bytes (read-file-bytevector (path-concat reg-path target-path))]) + ;; ── delegations ──────────────────────────────────────────────────────── + ;; targets-signed may carry: + ;; "delegations": {"keys": {keyid: keyobj}, "roles": [ + ;; {"name","keyids":[...],"threshold":N,"paths":["packages/@s/*"]}]} + ;; The delegated role's metadata lives at metadata/delegations/<name>.json, + ;; is listed in snapshot meta, and is signed by the delegated keys. + + (def (path-matches? pattern target-path) + ;; prefix glob: "a/b/*" matches anything under "a/b/"; exact otherwise + (let ([n (string-length pattern)]) + (if (and (> n 0) (char=? (string-ref pattern (- n 1)) #\*)) + (let ([prefix (substring pattern 0 (- n 1))]) + (and (>= (string-length target-path) (string-length prefix)) + (string=? prefix (substring target-path 0 (string-length prefix))))) + (string=? pattern target-path)))) + + (def (delegated-role-for targets-signed target-path) + ;; returns (name keyids threshold) or #f + (let ([deleg (oref targets-signed "delegations")]) + (and deleg + (let ([roles (or (oref deleg "roles") (vector))]) + (let loop ([i 0]) + (cond + [(>= i (vector-length roles)) #f] + [else + (let* ([r (vector-ref roles i)] + [paths (or (oref r "paths") (vector))]) + (if (let pm ([j 0]) + (cond [(>= j (vector-length paths)) #f] + [(path-matches? (vector-ref paths j) target-path) #t] + [else (pm (+ j 1))])) + (list (oref! r "name" "delegation") + (vector->list (oref! r "keyids" "delegation")) + (oref! r "threshold" "delegation")) + (loop (+ i 1))))])))))) + + (def (delegation-keydb targets-signed) + (let ([deleg (oref targets-signed "delegations")]) + (if deleg + (map (lambda (entry) + (let* ([keyid (car entry)] [obj (cdr entry)]) + (unless (string=? (key->keyid obj) keyid) + (jpkg-error "tuf: delegation keyid mismatch")) + (cons keyid (oref! (oref! obj "keyval" "key") "public" "keyval")))) + (or (oref deleg "keys") '())) + '()))) + + ;; load + verify a delegated role's targets metadata against the + ;; delegation authority and the snapshot. Returns its "signed" object. + (def (load-delegated-targets reg-path targets-signed role-name keyids threshold) + (let ([ctx (or (ctx-get reg-path) + (jpkg-error "tuf: no verification context (call tuf-context first)"))]) + (let* ([sn-signed (car ctx)] + [keydb (delegation-keydb targets-signed)] + [fname (string-append "delegations/" role-name ".json")] + [bytes (read-file-bytevector + (path-concat reg-path (string-append "metadata/" fname)))] + [expected-version + (check-meta-entry! (oref! sn-signed "meta" "snapshot") fname bytes + "snapshot")] + [env (canonical-of-json-text (utf8->string bytes))] + [signed (oref! env "signed" role-name)]) + (check-type! signed "targets") + (verify-envelope env keyids threshold keydb fname) + (when (expired? (oref! signed "expires" role-name)) + (jpkg-error "tuf: delegated role ~a expired" role-name)) + (unless (= (check-version! signed role-name) expected-version) + (jpkg-error "tuf: delegated role ~a version mismatch vs snapshot" role-name)) + signed))) + + (def (verify-target-against entry reg-path target-path) + (let ([bytes (read-file-bytevector (path-concat reg-path target-path))]) (let ([len (oref! entry "length" target-path)] [hashes (oref! entry "hashes" target-path)]) (unless (= len (bytevector-length bytes)) @@ -396,6 +476,42 @@ (jpkg-error "tuf: ~a digest mismatch (tampered mirror?)" target-path))) bytes)) + ;; Verified read of a target file. If a delegated scope role covers the + ;; path, the bytes must match THAT role's signed metadata (federation). + (def (tuf-verified-target-bytes targets-signed reg-path target-path) + (let ([deleg (delegated-role-for targets-signed target-path)]) + (if deleg + (let* ([signed (load-delegated-targets reg-path targets-signed + (car deleg) (cadr deleg) (caddr deleg))] + [targets (oref! signed "targets" "delegated targets")] + [entry (or (oref targets target-path) + (jpkg-error "tuf: ~a not in delegated role ~a" + target-path (car deleg)))]) + (verify-target-against entry reg-path target-path)) + (let* ([targets (oref! targets-signed "targets" "targets")] + [entry (or (oref targets target-path) + (jpkg-error "tuf: ~a not in signed targets" target-path))]) + (verify-target-against entry reg-path target-path))))) + + ;; All signed target paths (top role + every delegated role), so version + ;; enumeration trusts signed metadata, not directory listings. + (def (tuf-all-target-paths targets-signed reg-path) + (let ([top (map car (or (oref targets-signed "targets") '()))] + [deleg (oref targets-signed "delegations")]) + (append + top + (if deleg + (apply append + (map (lambda (r) + (let* ([name (oref! r "name" "delegation")] + [keyids (vector->list (oref! r "keyids" "delegation"))] + [threshold (oref! r "threshold" "delegation")] + [signed (load-delegated-targets + reg-path targets-signed name keyids threshold)]) + (map car (or (oref signed "targets") '())))) + (vector->list (or (oref deleg "roles") (vector))))) + '())))) + ;; ── generator ────────────────────────────────────────────────────────── (def (sign-envelope signed-obj keyrecs) @@ -458,6 +574,16 @@ (let ([acc '()]) (when (file-exists? (path-concat reg-path "publishers.json")) (set! acc (cons "publishers.json" acc))) + (when (file-exists? (path-concat reg-path "transparency.json")) + (set! acc (cons "transparency.json" acc))) + (let ([adv-dir (path-concat reg-path "advisories")]) + (when (file-directory? adv-dir) + (for-each (lambda (f) + (when (and (> (string-length f) 5) + (string=? (substring f (- (string-length f) 5) + (string-length f)) ".json")) + (set! acc (cons (string-append "advisories/" f) acc)))) + (directory-list adv-dir)))) (let ([pkgs-dir (path-concat reg-path "packages")]) (when (file-directory? pkgs-dir) (for-each @@ -493,42 +619,113 @@ ;; (re)generate targets/snapshot/timestamp, versions bumped from the ;; existing metadata when present. - (def (tuf-registry-sign! reg-path roles-spec expires) - (let* ([get (lambda (role) + ;; + ;; Optional trailing arg `delegations`: a list of + ;; (role-name keyrecs threshold (path-pattern ...)) + ;; Each delegated role owns the targets matching its patterns; the top + ;; targets role lists only the rest, plus a signed delegations block + ;; naming the role's keys/threshold/paths. Delegated role metadata is + ;; written to metadata/delegations/<name>.json and listed in snapshot. + (def (tuf-registry-sign! reg-path roles-spec expires . maybe-delegations) + (let* ([delegations (if (pair? maybe-delegations) (car maybe-delegations) '())] + [get (lambda (role) (or (assq role roles-spec) (jpkg-error "tuf: roles-spec missing ~a" role)))] [next-version (lambda (fname) (let ([p (path-concat reg-path (string-append "metadata/" fname))]) (if (file-exists? p) - (+ 1 (oref! (oref! (json-file->canonical p) "signed" fname) + (+ 1 (oref! (oref! (json-file->canonical p) + "signed" fname) "version" fname)) 1)))] - ;; targets + [target-entry + (lambda (path) + (let ([bytes (read-file-bytevector (path-concat reg-path path))]) + (cons path + (list (cons "hashes" + (list (cons "sha256" + (sha256-hex-of-bytevector bytes)))) + (cons "length" (bytevector-length bytes))))))] + [all-targets (collect-targets reg-path)] + [covered? (lambda (path) + (exists (lambda (d) + (exists (lambda (p) (path-matches? p path)) + (cadddr d))) + delegations))] + ;; delegated role files (signed) + their snapshot meta + [deleg-results + (map (lambda (d) + (let* ([name (car d)] [keyrecs (cadr d)] + [threshold (caddr d)] [patterns (cadddr d)] + [fname (string-append "delegations/" name ".json")] + [paths (filter (lambda (p) + (exists (lambda (pat) (path-matches? pat p)) + patterns)) + all-targets)] + [dversion (next-version fname)] + [dsigned (list (cons "_type" "targets") + (cons "expires" expires) + (cons "spec_version" "1.0.0") + (cons "targets" (map target-entry paths)) + (cons "version" dversion))] + [dbytes (string->utf8 (sign-envelope dsigned keyrecs))]) + (mkdir-p (path-concat reg-path "metadata/delegations")) + (write-file-bytevector + (path-concat reg-path (string-append "metadata/" fname)) dbytes) + (list fname dbytes dversion name keyrecs threshold patterns))) + delegations)] + ;; top targets: everything NOT covered by a delegation [tg-version (next-version "targets.json")] - [targets-obj - (map (lambda (path) - (let ([bytes (read-file-bytevector (path-concat reg-path path))]) - (cons path - (list (cons "hashes" - (list (cons "sha256" - (sha256-hex-of-bytevector bytes)))) - (cons "length" (bytevector-length bytes)))))) - (collect-targets reg-path))] - [tg-signed (list (cons "_type" "targets") - (cons "expires" expires) - (cons "spec_version" "1.0.0") - (cons "targets" targets-obj) - (cons "version" tg-version))] + [targets-obj (map target-entry (filter (lambda (p) (not (covered? p))) + all-targets))] + [delegations-block + (if (null? delegations) '() + (list + (cons "delegations" + (list + (cons "keys" + (list-sort + (lambda (a b) (string<? (car a) (car b))) + (map (lambda (k) (cons (kr-keyid k) (kr-obj k))) + (let loop ([ks (apply append + (map cadr delegations))] + [seen '()] [acc '()]) + (cond [(null? ks) (reverse acc)] + [(member (kr-keyid (car ks)) seen) + (loop (cdr ks) seen acc)] + [else (loop (cdr ks) + (cons (kr-keyid (car ks)) seen) + (cons (car ks) acc))]))))) + (cons "roles" + (list->vector + (map (lambda (d) + (list (cons "name" (car d)) + (cons "keyids" + (list->vector + (map kr-keyid (cadr d)))) + (cons "paths" (list->vector (cadddr d))) + (cons "threshold" (caddr d)))) + delegations)))))))] + [tg-signed (append + (list (cons "_type" "targets") + (cons "expires" expires)) + delegations-block + (list (cons "spec_version" "1.0.0") + (cons "targets" targets-obj) + (cons "version" tg-version)))] [tg-text (sign-envelope tg-signed (cadr (get 'targets)))] [tg-bytes (string->utf8 tg-text)] - ;; snapshot + ;; snapshot: targets.json + every delegated role file [sn-version (next-version "snapshot.json")] + [sn-meta (cons (cons "targets.json" (meta-entry-for tg-bytes tg-version)) + (map (lambda (dr) + (cons (car dr) + (meta-entry-for (cadr dr) (caddr dr)))) + deleg-results))] [sn-signed (list (cons "_type" "snapshot") (cons "expires" expires) - (cons "meta" - (list (cons "targets.json" - (meta-entry-for tg-bytes tg-version)))) + (cons "meta" sn-meta) (cons "spec_version" "1.0.0") (cons "version" sn-version))] [sn-text (sign-envelope sn-signed (cadr (get 'snapshot)))] @@ -550,6 +747,24 @@ (string->utf8 ts-text)) (void))) + ;; Delegate a scope to a set of maintainer keys with a threshold, then + ;; re-sign. `delegations` is the full delegation list (each entry + ;; (name keyrecs threshold (pattern ...))). Convenience wrapper. + (def (tuf-registry-delegate! reg-path roles-spec expires delegations) + (tuf-registry-sign! reg-path roles-spec expires delegations)) + + ;; (re)sign only the delegated roles + snapshot/timestamp after a scope + ;; maintainer publishes — same as a full sign with the delegation set. + (def (tuf-registry-sign-delegated! reg-path roles-spec expires delegations) + (tuf-registry-sign! reg-path roles-spec expires delegations)) + + ;; Namespace transfer: re-delegate a scope to NEW maintainer keys. The + ;; top targets role (held by the registry) authorizes the change by + ;; re-signing the delegations block; old maintainer keys can no longer + ;; produce accepted delegated metadata. + (def (tuf-transfer-scope! reg-path roles-spec expires new-delegations) + (tuf-registry-sign! reg-path roles-spec expires new-delegations)) + ;; root rotation: write a new root (version+1) signed by BOTH the old ;; root keys and the new ones. (def (tuf-rotate-root! reg-path old-root-keys new-roles-spec expires) --- a/support/build.ss +++ b/support/build.ss @@ -32,7 +32,8 @@ ;; for the entire transitively-referenced tree. User scripts that ;; (import (jerboa prelude)) skip a large one-time compile at startup. (jerboa prelude) - ;; jpkg package manager (multicall mode; not in the prelude) + ;; jpkg package manager (multicall mode; not in the prelude). + ;; (std pkg cli) transitively imports every (std pkg ...) module. (std pkg cli))) (define compiled 0) --- a/tests/test-jpkg-audit.ss +++ b/tests/test-jpkg-audit.ss @@ -4,7 +4,7 @@ (import (chezscheme) (std pkg advisory) (std pkg audit) (std pkg search) (std pkg cli) (std pkg util) (std pkg registry) (std pkg artifact) - (std pkg lock)) + (std pkg lock) (std pkg transparency)) (define pass 0) (define fail 0) @@ -175,6 +175,24 @@ (s-contains? (cadr r2) "local") (= (car r3) 0))))) +;; ── transparency monitoring via audit ─────────────────────────────────── +;; A registry with a transparency log that OMITS a locked release should +;; surface a transparency finding from `jpkg audit`. + +(check "audit-flags-missing-transparency" + (begin + ;; write a transparency log that records @v/safe but not @v/lib + (write-file-bytevector + (path-concat reg "transparency.json") + (string->utf8 + (let* ([t0 (transparency-empty)] + [t1 (transparency-append t0 "@v/safe" "2.0.0" + (make-string 64 #\a) "k")]) + (transparency->json t1)))) + (current-directory proj) + (let ([r (run-jpkg '("audit"))]) + (s-contains? (cadr r) "TRANSPARENCY")))) + (current-directory orig) (remove-tree world) --- a/tests/test-jpkg-build.ss +++ b/tests/test-jpkg-build.ss @@ -239,6 +239,22 @@ (and (= (car r) 0) (not (file-directory? ".jpkg/build"))))) +;; reproducible-rebuild verify (phase 7 hardening, via jpkg verify) +(check "cmd-verify-reproduce" + (let ([r (run-jpkg '("verify" "--reproduce"))]) + (and (= (car r) 0) + (= 64 (string-length (substring (cadr r) 0 64)))))) + +(check "cmd-verify-rebuild-roundtrip" + (let* ([d (cadr (run-jpkg '("verify" "--reproduce")))] + [digest (substring d 0 64)] + [r (run-jpkg (list "verify" "--rebuild" digest))]) + (and (= (car r) 0) (s-contains? (cadr r) "reproduces")))) + +(check "cmd-verify-rebuild-mismatch" + (let ([r (run-jpkg (list "verify" "--rebuild" (make-string 64 #\a)))]) + (= (car r) 1))) + (check "cmd-build-refuses-native-default" (begin (write-text "jpkg.sexp" new file mode 100644 --- /dev/null +++ b/tests/test-jpkg-federation.ss @@ -0,0 +1,215 @@ +#!chezscheme +;;; tests/test-jpkg-federation.ss — phase 7: TUF scope delegation, +;;; namespace transfer, transparency log (chain/inclusion/consistency), +;;; and reproducible-rebuild verification. + +(import (chezscheme) (std pkg tuf) (std pkg registry) (std pkg util) + (std pkg artifact) (std pkg transparency) (std pkg rebuild) + (std pkg cli) (std pkg publish) (std pkg ed25519)) + +(define pass 0) +(define fail 0) + +(define-syntax check + (syntax-rules () + [(_ name expr) + (let ([got (guard (e [#t (list 'EXN (and (message-condition? e) + (condition-message e)))]) + expr)]) + (if (eq? got #t) + (begin (set! pass (+ pass 1)) (printf " ok ~a~%" name)) + (begin (set! fail (+ fail 1)) (printf "FAIL ~a: got ~s~%" name got))))])) + +(define-syntax check-fails-with + (syntax-rules () + [(_ name substr expr) + (let ([got (guard (e [#t (if (and (message-condition? e) + (s-contains? (condition-message e) substr)) + 'EXPECTED + (list 'WRONG (and (message-condition? e) + (condition-message e))))]) + (begin expr 'NO-RAISE))]) + (if (eq? got 'EXPECTED) + (begin (set! pass (+ pass 1)) (printf " ok ~a~%" name)) + (begin (set! fail (+ fail 1)) (printf "FAIL ~a: ~s~%" name got))))])) + +(define (s-contains? s sub) + (let ([sl (string-length s)] [xl (string-length sub)]) + (let loop ([i 0]) + (cond [(> (+ i xl) sl) #f] + [(string=? (substring s i (+ i xl)) sub) #t] + [else (loop (+ i 1))])))) + +(printf "--- jpkg federation tests ---~%") + +;; ── transparency log ───────────────────────────────────────────────────── + +(define d1 (make-string 64 #\1)) +(define d2 (make-string 64 #\2)) +(define d3 (make-string 64 #\3)) + +(define t0 (transparency-empty)) +(define t1 (transparency-append t0 "@a/x" "1.0.0" d1 "key1")) +(define t2 (transparency-append t1 "@a/y" "2.0.0" d2 "key1")) +(define t3 (transparency-append t2 "@a/x" "1.1.0" d3 "key2")) + +(check "chain-verifies" (transparency-verify-chain t3)) +(check "length" (= (transparency-length t3) 3))