jpkg phase 3: static registry with TUF verification
ober
9bff19ece09fbedd54e64291e8cb967d358ee938
--- a/docs/jpkg-plan.md +++ b/docs/jpkg-plan.md @@ -566,7 +566,19 @@ Tracked per phase as implementation lands. Tests live in `tests/test-jpkg*.ss` pinning per name (dependency-confusion guard) (`project.ss`). Commands: add, remove, install, update, uninstall, link, unlink, list, env; verify now also checks the lock + store. -- Phase 3 (static registry with TUF): not started. +- Phase 3 (static registry with TUF): DONE. Pure-Scheme SHA-512 + + Ed25519 verified against FIPS/RFC 8032 vectors (`sha512.ss`, + `ed25519.ss`) so verification works identically in static builds; TUF + client with root pinning (TOFU on first use), chained root rotation + (old threshold + new threshold), timestamp/snapshot/targets + verification, expiry (freeze) and monotonic-version (rollback) + protection, signed-targets-only version listings (`tuf.ss`); registry + generator for tests/staging (`tuf-registry-init!/-sign!/-rotate-root!`); + resolver provider routes through TUF-verified release.json bytes when + `metadata/root.json` is present — mirrors stay untrusted. Signature + payloads are canonical JSON; keyids are sha256 of canonical key + objects. 35 new tests incl. tamper, threshold, unauthorized-key, + rollback, freeze, and hostile root-rotation cases. - Phase 4 (signing and provenance): not started. - Phase 5 (sandbox builds): not started. - Phase 6 (audit, advisories, search): not started. new file mode 100644 --- /dev/null +++ b/lib/std/pkg/ed25519.ss @@ -0,0 +1,218 @@ +#!chezscheme +;;; (std pkg ed25519) — pure-Scheme Ed25519 (RFC 8032) for TUF metadata +;;; and offline package signatures. +;;; +;;; Exact-integer field arithmetic mod 2^255-19, extended-coordinate +;;; point ops. Not constant-time — fine for VERIFICATION (public data). +;;; Signing here is for registry generators, tests, and self-hosted +;;; keys; keep long-lived private keys in proper tooling. + +(library (std pkg ed25519) + (export ed25519-public-key ;; 32-byte seed -> 32-byte public key + ed25519-sign* ;; seed pubkey msg -> 64-byte signature + ed25519-verify* ;; pubkey msg sig -> boolean + bytes->hex hex->bytes) + + (import (chezscheme) + (only (jerboa core) def) + (only (std pkg util) jpkg-error) + (only (std pkg sha512) sha512-bytevector)) + + ;; ── field: GF(2^255 - 19) ────────────────────────────────────────────── + + (def P (- (expt 2 255) 19)) + (def L (+ (expt 2 252) 27742317777372353535851937790883648493)) + + (def (pow-mod b e m) + (let loop ([b (mod b m)] [e e] [acc 1]) + (if (= e 0) acc + (loop (mod (* b b) m) + (bitwise-arithmetic-shift-right e 1) + (if (odd? e) (mod (* acc b) m) acc))))) + + (def D (mod (* -121665 (pow-mod 121666 (- P 2) P)) P)) ;; -121665/121666 + + (def (fmod x) (mod x P)) + (def (finv x) (pow-mod x (- P 2) P)) + + ;; sqrt(-1) per RFC 8032 §5.1.3 (decoding) + (def sqrt-m1 (pow-mod 2 (div (- P 1) 4) P)) + + ;; ── points: extended homogeneous (X:Y:Z:T), x=X/Z y=Y/Z xy=T/Z ──────── + + (def zero-point (vector 0 1 1 0)) ;; neutral + + (def (point-add p q) + (let ([x1 (vector-ref p 0)] [y1 (vector-ref p 1)] + [z1 (vector-ref p 2)] [t1 (vector-ref p 3)] + [x2 (vector-ref q 0)] [y2 (vector-ref q 1)] + [z2 (vector-ref q 2)] [t2 (vector-ref q 3)]) + (let* ([a (fmod (* (- y1 x1) (- y2 x2)))] + [b (fmod (* (+ y1 x1) (+ y2 x2)))] + [c (fmod (* 2 t1 t2 D))] + [dd (fmod (* 2 z1 z2))] + [e (- b a)] [f (- dd c)] [g (+ dd c)] [h (+ b a)]) + (vector (fmod (* e f)) (fmod (* g h)) (fmod (* f g)) (fmod (* e h)))))) + + (def (point-double p) (point-add p p)) + + (def (scalar-mult k p) + (let loop ([k k] [p p] [acc zero-point]) + (if (= k 0) acc + (loop (bitwise-arithmetic-shift-right k 1) + (point-double p) + (if (odd? k) (point-add acc p) acc))))) + + (def (point-equal? p q) + ;; x1/z1 == x2/z2 and y1/z1 == y2/z2 + (and (= 0 (fmod (- (* (vector-ref p 0) (vector-ref q 2)) + (* (vector-ref q 0) (vector-ref p 2))))) + (= 0 (fmod (- (* (vector-ref p 1) (vector-ref q 2)) + (* (vector-ref q 1) (vector-ref p 2))))))) + + ;; x from y and sign bit (RFC 8032 §5.1.3); raises if not on curve + (def (recover-x y sign) + (when (>= y P) (jpkg-error "ed25519: y out of range")) + (let* ([y2 (fmod (* y y))] + [u (fmod (- y2 1))] + [v (fmod (+ (* D y2) 1))] + ;; candidate: (u/v)^((p+3)/8) = u v^3 (u v^7)^((p-5)/8) + [x (fmod (* u v v v + (pow-mod (fmod (* u (pow-mod v 7 P))) (div (- P 5) 8) P)))] + [vx2 (fmod (* v x x))] + [x (cond [(= vx2 (fmod u)) x] + [(= vx2 (fmod (- u))) (fmod (* x sqrt-m1))] + [else (jpkg-error "ed25519: point not on curve")])]) + (cond + [(and (= x 0) (= sign 1)) (jpkg-error "ed25519: invalid sign for x=0")] + [(= (bitwise-and x 1) sign) x] + [else (- P x)]))) + + ;; base point B: y = 4/5, x recovered, even sign + (def B + (let* ([y (fmod (* 4 (finv 5)))] + [x (recover-x y 0)]) + (vector x y 1 (fmod (* x y))))) + + ;; ── encoding ─────────────────────────────────────────────────────────── + + (def (le-bytes->int bv) + (let loop ([i (- (bytevector-length bv) 1)] [v 0]) + (if (< i 0) v + (loop (- i 1) + (bitwise-ior (bitwise-arithmetic-shift-left v 8) + (bytevector-u8-ref bv i)))))) + + (def (int->le-bytes v n) + (let ([bv (make-bytevector n 0)]) + (let loop ([i 0] [v v]) + (if (= i n) bv + (begin (bytevector-u8-set! bv i (bitwise-and v #xff)) + (loop (+ i 1) (bitwise-arithmetic-shift-right v 8))))))) + + (def (point-encode p) + (let* ([zi (finv (vector-ref p 2))] + [x (fmod (* (vector-ref p 0) zi))] + [y (fmod (* (vector-ref p 1) zi))] + [enc (int->le-bytes y 32)]) + (bytevector-u8-set! enc 31 + (bitwise-ior (bytevector-u8-ref enc 31) + (bitwise-arithmetic-shift-left + (bitwise-and x 1) 7))) + enc)) + + (def (point-decode bv) + (unless (= (bytevector-length bv) 32) + (jpkg-error "ed25519: bad point encoding length")) + (let* ([y-bytes (bytevector-copy bv)] + [sign (bitwise-arithmetic-shift-right (bytevector-u8-ref bv 31) 7)]) + (bytevector-u8-set! y-bytes 31 (bitwise-and (bytevector-u8-ref bv 31) #x7f)) + (let* ([y (le-bytes->int y-bytes)] + [x (recover-x y sign)]) + (vector x y 1 (fmod (* x y)))))) + + ;; ── key derivation, sign, verify (RFC 8032 §5.1.5/.6/.7) ─────────────── + + (def (clamp h32) + (let ([a (le-bytes->int h32)]) + (bitwise-ior + (bitwise-and a (- (expt 2 254) 8)) + (expt 2 254)))) + + (def (sub-bv bv start end) + (let ([out (make-bytevector (- end start))]) + (bytevector-copy! bv start out 0 (- end start)) + out)) + + (def (cat-bv . bvs) + (let* ([total (fold-left + 0 (map bytevector-length bvs))] + [out (make-bytevector total)]) + (let loop ([off 0] [bvs bvs]) + (if (null? bvs) out + (begin + (bytevector-copy! (car bvs) 0 out off (bytevector-length (car bvs))) + (loop (+ off (bytevector-length (car bvs))) (cdr bvs))))))) + + (def (ed25519-public-key seed) + (unless (and (bytevector? seed) (= (bytevector-length seed) 32)) + (jpkg-error "ed25519: seed must be 32 bytes")) + (let* ([h (sha512-bytevector seed)] + [a (clamp (sub-bv h 0 32))]) + (point-encode (scalar-mult a B)))) + + (def (ed25519-sign* seed pubkey msg) + (unless (and (bytevector? seed) (= (bytevector-length seed) 32)) + (jpkg-error "ed25519: seed must be 32 bytes")) + (let* ([h (sha512-bytevector seed)] + [a (clamp (sub-bv h 0 32))] + [prefix (sub-bv h 32 64)] + [r (mod (le-bytes->int (sha512-bytevector (cat-bv prefix msg))) L)] + [R (point-encode (scalar-mult r B))] + [k (mod (le-bytes->int (sha512-bytevector (cat-bv R pubkey msg))) L)] + [s (mod (+ r (* k (mod a L))) L)]) + (cat-bv R (int->le-bytes s 32)))) + + (def (ed25519-verify* pubkey msg sig) + (and (bytevector? pubkey) (= (bytevector-length pubkey) 32) + (bytevector? sig) (= (bytevector-length sig) 64) + (guard (e [#t #f]) + (let* ([A (point-decode pubkey)] + [R-bytes (sub-bv sig 0 32)] + [R (point-decode R-bytes)] + [s (le-bytes->int (sub-bv sig 32 64))]) + (and (< s L) ;; reject malleable signatures + (let ([k (mod (le-bytes->int + (sha512-bytevector (cat-bv R-bytes pubkey msg))) + L)]) + ;; S*B == R + k*A + (point-equal? (scalar-mult s B) + (point-add R (scalar-mult k A))))))))) + + ;; ── hex helpers (key files, signatures in JSON) ──────────────────────── + + (def hex-chars "0123456789abcdef") + + (def (bytes->hex bv) + (let* ([n (bytevector-length bv)] [out (make-string (* 2 n))]) + (do ([i 0 (+ i 1)]) ((= i n) out) + (let ([b (bytevector-u8-ref bv i)]) + (string-set! out (* 2 i) + (string-ref hex-chars (bitwise-arithmetic-shift-right b 4))) + (string-set! out (+ (* 2 i) 1) + (string-ref hex-chars (bitwise-and b #xf))))))) + + (def (hex-digit c) + (cond [(char<=? #\0 c #\9) (- (char->integer c) 48)] + [(char<=? #\a c #\f) (+ 10 (- (char->integer c) 97))] + [(char<=? #\A c #\F) (+ 10 (- (char->integer c) 65))] + [else (jpkg-error "bad hex digit ~c" c)])) + + (def (hex->bytes s) + (unless (even? (string-length s)) (jpkg-error "odd hex length")) + (let* ([n (div (string-length s) 2)] [out (make-bytevector n)]) + (do ([i 0 (+ i 1)]) ((= i n) out) + (bytevector-u8-set! out i + (+ (* 16 (hex-digit (string-ref s (* 2 i)))) + (hex-digit (string-ref s (+ (* 2 i) 1)))))))) + + ) ;; end library --- a/lib/std/pkg/project.ss +++ b/lib/std/pkg/project.ss @@ -47,8 +47,9 @@ lock-parse-file lock-write-file lock-file-name) (only (std pkg resolve) resolve-dependencies) (only (std pkg registry) - registry-config registry-lookup registry-package-versions - registry-release registry-fetch-blob + registry-config registry-lookup + registry-versions-for registry-release-for + registry-fetch-blob release-info-artifact-sha256 release-info-artifact-size release-info-manifest-sha256 release-info-dependencies release-info-yanked?) @@ -72,7 +73,7 @@ [(null? cs) (set! owner-cache (cons (cons name #f) owner-cache)) #f] - [(pair? (registry-package-versions (cdr (car cs)) name)) + [(pair? (registry-versions-for (car (car cs)) (cdr (car cs)) name)) (set! owner-cache (cons (cons name (car cs)) owner-cache)) (car cs)] [else (loop (cdr cs))]))])) @@ -83,11 +84,11 @@ (case op [(versions) (let ([o (owner-of (car args))]) - (if o (registry-package-versions (cdr o) (car args)) '()))] + (if o (registry-versions-for (car o) (cdr o) (car args)) '()))] [(release) (let ([o (owner-of (car args))]) (unless o (jpkg-error "package ~a not found in any registry" (car args))) - (let ([rel (registry-release (cdr o) (car args) (cadr args))]) + (let ([rel (registry-release-for (car o) (cdr o) (car args) (cadr args))]) (list (cons 'dependencies (release-info-dependencies rel)) (cons 'yanked (release-info-yanked? rel)) (cons 'registry (car o)) --- a/lib/std/pkg/registry.ss +++ b/lib/std/pkg/registry.ss @@ -20,6 +20,9 @@ registry-lookup registry-package-versions registry-release + registry-versions-for + registry-release-for + tuf-cache-reset! registry-blob-path registry-fetch-blob release-info? release-info-name release-info-version @@ -48,6 +51,8 @@ artifact-validate artifact-info-manifest artifact-info-digest 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) (only (std text json) string->json-object)) ;; ── configuration ────────────────────────────────────────────────────── @@ -123,46 +128,122 @@ (unless v (jpkg-error "registry: release.json missing ~a" what)) v)) + (def (parse-release-text text name version) + ;; parse + structurally validate release.json content + (let* ([h (try (string->json-object text) + (catch (e) (jpkg-error "registry: release.json unparseable")))] + [rname (json-ref h "name" "name")] + [rver (json-ref h "version" "version")] + [asha (json-ref h "artifact-sha256" "artifact-sha256")] + [asize (json-ref h "artifact-size" "artifact-size")] + [msha (json-ref h "manifest-sha256" "manifest-sha256")] + [deps (hashtable-ref h "dependencies" '())] + [caps (hashtable-ref h "capabilities" '())] + [yanked (hashtable-ref h "yanked" #f)]) + (unless (and (string? rname) (string=? rname name)) + (jpkg-error "registry: release.json name mismatch (~s vs ~s)" rname name)) + (unless (and (string? rver) (string=? rver version)) + (jpkg-error "registry: release.json version mismatch")) + (unless (valid-digest? asha) + (jpkg-error "registry: bad artifact-sha256")) + (unless (valid-digest? msha) + (jpkg-error "registry: bad manifest-sha256")) + (unless (and (integer? asize) (exact? asize) (>= asize 0)) + (jpkg-error "registry: bad artifact-size")) + (unless (list? deps) + (jpkg-error "registry: bad dependencies")) + (make-release-info + name version asha asize msha + (map (lambda (d) + (unless (and (list? d) (= (length d) 2) + (valid-package-name? (car d)) (string? (cadr d))) + (jpkg-error "registry: bad dependency entry ~s" d)) + (cons (car d) (cadr d))) + deps) + caps + (eq? yanked #t)))) + (def (registry-release reg-path name version) - ;; parse + structurally validate release.json + ;; UNVERIFIED file read — only correct for plain local registries; + ;; TUF registries must go through registry-release-for. (let ([path (path-concat (path-concat (package-dir reg-path name) version) "release.json")]) (unless (file-exists? path) (jpkg-error "registry: no release ~a@~a" name version)) - (let* ([text (or (bytes->utf8-or-false (read-file-bytevector path)) - (jpkg-error "registry: release.json not UTF-8"))] - [h (try (string->json-object text) - (catch (e) (jpkg-error "registry: release.json unparseable")))]) - (let ([rname (json-ref h "name" "name")] - [rver (json-ref h "version" "version")] - [asha (json-ref h "artifact-sha256" "artifact-sha256")] - [asize (json-ref h "artifact-size" "artifact-size")] - [msha (json-ref h "manifest-sha256" "manifest-sha256")] - [deps (hashtable-ref h "dependencies" '())] - [caps (hashtable-ref h "capabilities" '())] - [yanked (hashtable-ref h "yanked" #f)]) - (unless (and (string? rname) (string=? rname name)) - (jpkg-error "registry: release.json name mismatch (~s vs ~s)" rname name)) - (unless (and (string? rver) (string=? rver version)) - (jpkg-error "registry: release.json version mismatch")) - (unless (valid-digest? asha) - (jpkg-error "registry: bad artifact-sha256")) - (unless (valid-digest? msha) - (jpkg-error "registry: bad manifest-sha256")) - (unless (and (integer? asize) (exact? asize) (>= asize 0)) - (jpkg-error "registry: bad artifact-size")) - (unless (list? deps) - (jpkg-error "registry: bad dependencies")) - (make-release-info - name version asha asize msha - (map (lambda (d) - (unless (and (list? d) (= (length d) 2) - (valid-package-name? (car d)) (string? (cadr d))) - (jpkg-error "registry: bad dependency entry ~s" d)) - (cons (car d) (cadr d))) - deps) - caps - (eq? yanked #t)))))) + (parse-release-text + (or (bytes->utf8-or-false (read-file-bytevector path)) + (jpkg-error "registry: release.json not UTF-8")) + name version))) + + ;; ── TUF-aware access (used by the resolver provider) ─────────────────── + ;; Per-process cache of verified targets metadata, keyed by registry + ;; name. Reset in tests after re-signing a registry. + + (def *tuf-cache* '()) + + (def (tuf-cache-reset!) (set! *tuf-cache* '())) + + (def (tuf-targets-for name reg-path) + (cond + [(assoc name *tuf-cache*) => cdr] + [else + (let ([targets (tuf-context name reg-path)]) + (set! *tuf-cache* (cons (cons name targets) *tuf-cache*)) + targets)])) + + (def (canon-ref obj key) + (let ([p (and (list? obj) (assoc key obj))]) + (and p (cdr p)))) + + (def (registry-release-for name reg-path pkg version) + ;; release.json via TUF-verified bytes when the registry has TUF + ;; metadata; plain read otherwise. + (if (tuf-registry? reg-path) + (let* ([targets (tuf-targets-for name reg-path)] + [tpath (string-append "packages/" pkg "/" version "/release.json")] + [bytes (tuf-verified-target-bytes targets reg-path tpath)]) + (parse-release-text + (or (bytes->utf8-or-false bytes) + (jpkg-error "registry: release.json not UTF-8")) + pkg version)) + (registry-release reg-path pkg version))) + + (def (registry-versions-for name reg-path pkg) + ;; For TUF registries the version list comes from SIGNED targets + ;; metadata — directory listings are untrusted mirror content and + ;; 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") '())] + [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)]) + (and (string? path) + (>= (string-length path) + (+ (string-length prefix) (string-length suffix))) + (string=? prefix + (substring path 0 (string-length prefix))) + (string=? suffix + (substring path + (- (string-length path) + (string-length suffix)) + (string-length path))) + (let ([v (substring path (string-length prefix) + (- (string-length path) + (string-length suffix)))]) + ;; exactly one segment (no nested slashes) + (and (not (let loop ([i 0]) + (cond [(= i (string-length v)) #f] + [(char=? (string-ref v i) #\/) #t] + [else (loop (+ i 1))]))) + v))))) + targets)))) + (registry-package-versions reg-path pkg))) (def (registry-blob-path reg-path digest) (unless (valid-digest? digest) new file mode 100644 --- /dev/null +++ b/lib/std/pkg/sha512.ss @@ -0,0 +1,142 @@ +#!chezscheme +;;; (std pkg sha512) — pure-Scheme SHA-512 (FIPS 180-4). +;;; +;;; Needed by the pure Ed25519 used for TUF metadata signatures, so jpkg +;;; verifies registries identically in dev trees, multicall binaries, +;;; and static builds with no native crypto present. Exact-integer +;;; arithmetic masked to 64 bits; fine for the small payloads TUF signs. + +(library (std pkg sha512) + (export sha512-bytevector sha512-hex) + + (import (chezscheme) + (only (jerboa core) def)) + + (def U64 #xffffffffffffffff) + + (def (u64+ . xs) (bitwise-and U64 (apply + xs))) + + (def (rotr64 x n) + (bitwise-and U64 + (bitwise-ior (bitwise-arithmetic-shift-right x n) + (bitwise-arithmetic-shift-left x (- 64 n))))) + + (def (shr64 x n) (bitwise-arithmetic-shift-right x n)) + + ;; FIPS 180-4 §4.2.3: first 64 bits of fractional parts of cube roots + ;; of the first 80 primes. + (def K + (vector + #x428a2f98d728ae22 #x7137449123ef65cd #xb5c0fbcfec4d3b2f #xe9b5dba58189dbbc + #x3956c25bf348b538 #x59f111f1b605d019 #x923f82a4af194f9b #xab1c5ed5da6d8118 + #xd807aa98a3030242 #x12835b0145706fbe #x243185be4ee4b28c #x550c7dc3d5ffb4e2 + #x72be5d74f27b896f #x80deb1fe3b1696b1 #x9bdc06a725c71235 #xc19bf174cf692694 + #xe49b69c19ef14ad2 #xefbe4786384f25e3 #x0fc19dc68b8cd5b5 #x240ca1cc77ac9c65 + #x2de92c6f592b0275 #x4a7484aa6ea6e483 #x5cb0a9dcbd41fbd4 #x76f988da831153b5 + #x983e5152ee66dfab #xa831c66d2db43210 #xb00327c898fb213f #xbf597fc7beef0ee4 + #xc6e00bf33da88fc2 #xd5a79147930aa725 #x06ca6351e003826f #x142929670a0e6e70 + #x27b70a8546d22ffc #x2e1b21385c26c926 #x4d2c6dfc5ac42aed #x53380d139d95b3df + #x650a73548baf63de #x766a0abb3c77b2a8 #x81c2c92e47edaee6 #x92722c851482353b + #xa2bfe8a14cf10364 #xa81a664bbc423001 #xc24b8b70d0f89791 #xc76c51a30654be30 + #xd192e819d6ef5218 #xd69906245565a910 #xf40e35855771202a #x106aa07032bbd1b8 + #x19a4c116b8d2d0c8 #x1e376c085141ab53 #x2748774cdf8eeb99 #x34b0bcb5e19b48a8 + #x391c0cb3c5c95a63 #x4ed8aa4ae3418acb #x5b9cca4f7763e373 #x682e6ff3d6b2b8a3 + #x748f82ee5defb2fc #x78a5636f43172f60 #x84c87814a1f0ab72 #x8cc702081a6439ec + #x90befffa23631e28 #xa4506cebde82bde9 #xbef9a3f7b2c67915 #xc67178f2e372532b + #xca273eceea26619c #xd186b8c721c0c207 #xeada7dd6cde0eb1e #xf57d4f7fee6ed178 + #x06f067aa72176fba #x0a637dc5a2c898a6 #x113f9804bef90dae #x1b710b35131c471b + #x28db77f523047d84 #x32caab7b40c72493 #x3c9ebe0a15c9bebc #x431d67c49c100d4c + #x4cc5d4becb3e42b6 #x597f299cfc657e2a #x5fcb6fab3ad6faec #x6c44198c4a475817)) + + (def H0 + (vector + #x6a09e667f3bcc908 #xbb67ae8584caa73b #x3c6ef372fe94f82b #xa54ff53a5f1d36f1 + #x510e527fade682d1 #x9b05688c2b3e6c1f #x1f83d9abfb41bd6b #x5be0cd19137e2179)) + + (def (pad-message bv) + (let* ([len (bytevector-length bv)] + [bitlen (* len 8)] + ;; message + 0x80 + zeros + 16-byte length, multiple of 128 + [total (let ([t (+ len 1 16)]) + (* 128 (div (+ t 127) 128)))] + [out (make-bytevector total 0)]) + (bytevector-copy! bv 0 out 0 len) + (bytevector-u8-set! out len #x80) + ;; 128-bit big-endian length (low 64 bits enough for our sizes) + (let loop ([i 0] [v bitlen]) + (when (< i 16) + (bytevector-u8-set! out (- total 1 i) (bitwise-and v #xff)) + (loop (+ i 1) (bitwise-arithmetic-shift-right v 8)))) + out)) + + (def (u64-ref bv i) + ;; big-endian 64-bit word at byte offset i + (let loop ([k 0] [v 0]) + (if (= k 8) v + (loop (+ k 1) + (bitwise-ior (bitwise-arithmetic-shift-left v 8) + (bytevector-u8-ref bv (+ i k))))))) + + (def (sha512-bytevector bv) + (let* ([msg (pad-message bv)] + [nblocks (div (bytevector-length msg) 128)] + [h (vector-map (lambda (x) x) H0)] + [w (make-vector 80 0)]) + (do ([blk 0 (+ blk 1)]) ((= blk nblocks)) + (let ([base (* blk 128)]) + (do ([t 0 (+ t 1)]) ((= t 16)) + (vector-set! w t (u64-ref msg (+ base (* t 8))))) + (do ([t 16 (+ t 1)]) ((= t 80)) + (let ([w2 (vector-ref w (- t 2))] + [w7 (vector-ref w (- t 7))] + [w15 (vector-ref w (- t 15))] + [w16 (vector-ref w (- t 16))]) + (let ([s1 (bitwise-xor (rotr64 w2 19) (rotr64 w2 61) (shr64 w2 6))] + [s0 (bitwise-xor (rotr64 w15 1) (rotr64 w15 8) (shr64 w15 7))]) + (vector-set! w t (u64+ s1 w7 s0 w16))))) + (let loop ([t 0] + [a (vector-ref h 0)] [b (vector-ref h 1)] + [c (vector-ref h 2)] [d (vector-ref h 3)] + [e (vector-ref h 4)] [f (vector-ref h 5)] + [g (vector-ref h 6)] [hh (vector-ref h 7)]) + (if (= t 80) + (begin + (vector-set! h 0 (u64+ (vector-ref h 0) a)) + (vector-set! h 1 (u64+ (vector-ref h 1) b)) + (vector-set! h 2 (u64+ (vector-ref h 2) c)) + (vector-set! h 3 (u64+ (vector-ref h 3) d)) + (vector-set! h 4 (u64+ (vector-ref h 4) e)) + (vector-set! h 5 (u64+ (vector-ref h 5) f)) + (vector-set! h 6 (u64+ (vector-ref h 6) g)) + (vector-set! h 7 (u64+ (vector-ref h 7) hh))) + (let* ([S1 (bitwise-xor (rotr64 e 14) (rotr64 e 18) (rotr64 e 41))] + [ch (bitwise-xor (bitwise-and e f) + (bitwise-and (bitwise-xor e U64) g))] + [t1 (u64+ hh S1 ch (vector-ref K t) (vector-ref w t))] + [S0 (bitwise-xor (rotr64 a 28) (rotr64 a 34) (rotr64 a 39))] + [maj (bitwise-xor (bitwise-and a b) (bitwise-and a c) + (bitwise-and b c))] + [t2 (u64+ S0 maj)]) + (loop (+ t 1) + (u64+ t1 t2) a b c + (u64+ d t1) e f g)))))) + (let ([out (make-bytevector 64)]) + (do ([i 0 (+ i 1)]) ((= i 8) out) + (let loop ([k 0] [v (vector-ref h i)]) + (when (< k 8) + (bytevector-u8-set! out (+ (* i 8) (- 7 k)) (bitwise-and v #xff)) + (loop (+ k 1) (bitwise-arithmetic-shift-right v 8)))))))) + + (def hex-chars "0123456789abcdef") + + (def (sha512-hex bv) + (let* ([d (sha512-bytevector bv)] + [out (make-string 128)]) + (do ([i 0 (+ i 1)]) ((= i 64) out) + (let ([b (bytevector-u8-ref d i)]) + (string-set! out (* 2 i) + (string-ref hex-chars (bitwise-arithmetic-shift-right b 4))) + (string-set! out (+ (* 2 i) 1) + (string-ref hex-chars (bitwise-and b #xf))))))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/pkg/tuf.ss @@ -0,0 +1,589 @@ +#!chezscheme +;;; (std pkg tuf) — The Update Framework for jpkg registries. +;;; +;;; Implements the TUF client workflow (root trust pinning, root +;;; rotation, timestamp/snapshot/targets verification with threshold +;;; Ed25519 signatures, rollback and freeze protection) plus the +;;; registry-side metadata generator used by tests, staging registries, +;;; and `jpkg publish`. +;;; +;;; Metadata layout (docs/jpkg-plan.md "Registry Model"): +;;; metadata/root.json root role: keys + role thresholds +;;; metadata/timestamp.json freshness marker -> snapshot meta +;;; metadata/snapshot.json consistent view -> targets meta +;;; metadata/targets.json target file digests (release.json files) +;;; +;;; Envelope: {"signed": {...}, "signatures": [{"keyid","sig"}]} +;;; The signature payload is the canonical JSON of "signed". keyid is +;;; the sha256 of the canonical JSON of the public key object. Mirrors +;;; are untrusted: every byte consumed is checked against a signature +;;; or a digest recorded in signed metadata. +;;; +;;; Client state (per registry NAME, under $JERBOA_PKG_HOME): +;;; roots/NAME.root.json pinned trusted root (TOFU on first use) +;;; registries/NAME.state monotonic version state (rollback guard) + +(library (std pkg tuf) + (export + ;; client + tuf-context tuf-verified-target-bytes tuf-registry? + ;; generator + tuf-keygen tuf-registry-init! tuf-registry-sign! tuf-rotate-root! + ;; shared (used by phase-4 publish + tests) + json-file->canonical canonical-of-json-text signed-payload-bytes + key->keyid iso8601-of-epoch tuf-now) + + (import (chezscheme) + (only (jerboa core) def try catch) + (only (std pkg util) + jpkg-error mkdir-p path-concat + read-file-bytevector write-file-bytevector + bytes->utf8-or-false sha256-hex-of-bytevector + string-join-list) + (only (std pkg canonical) canonical-json) + (only (std pkg store) valid-digest?) + (only (std pkg ed25519) + ed25519-public-key ed25519-sign* ed25519-verify* + bytes->hex hex->bytes) + (only (std text json) string->json-object)) + + ;; ── json -> canonical data ───────────────────────────────────────────── + ;; (std text json): objects are hashtables, arrays are lists, null is + ;; (void). Canonical data: objects are alists, arrays are vectors. + + (def (json->canonical x) + (cond + [(hashtable? x) + (let-values ([(keys vals) (hashtable-entries x)]) + (let ([pairs (map (lambda (k v) + (unless (string? k) + (jpkg-error "tuf: non-string JSON key")) + (cons k (json->canonical v))) + (vector->list keys) (vector->list vals))]) + (list-sort (lambda (a b) (string<? (car a) (car b))) pairs)))] + [(list? x) (list->vector (map json->canonical x))] + [(string? x) x] + [(and (integer? x) (exact? x)) x] + [(boolean? x) x] + [(eq? x (void)) 'null] + [else (jpkg-error "tuf: unsupported JSON value ~s" x)])) + + (def (canonical-of-json-text text) + (json->canonical + (try (string->json-object text) + (catch (e) (jpkg-error "tuf: unparseable JSON"))))) + + (def (json-file->canonical path) + (unless (file-exists? path) + (jpkg-error "tuf: missing metadata file ~a" path)) + (let ([text (or (bytes->utf8-or-false (read-file-bytevector path)) + (jpkg-error "tuf: metadata not UTF-8: ~a" path))]) + (canonical-of-json-text text))) + + ;; canonical-data accessors (objects are sorted alists) + (def (oref obj key) + (let ([p (and (list? obj) (assoc key obj))]) + (and p (cdr p)))) + + (def (oref! obj key what) + (or (oref obj key) (jpkg-error "tuf: ~a missing ~a" what key))) + + (def (signed-payload-bytes envelope) + (string->utf8 (canonical-json (oref! envelope "signed" "envelope")))) + + ;; ── time ─────────────────────────────────────────────────────────────── + + (def (iso8601-of-epoch secs) + ;; civil-from-days (Howard Hinnant's algorithm), UTC + (let* ([z (+ (div secs 86400) 719468)] + [era (div (if (>= z 0) z (- z 146096)) 146097)] + [doe (- z (* era 146097))] + [yoe (div (- doe (+ (div doe 1460) (- (div doe 36524)) (div doe 146096))) + 365)] + [y (+ yoe (* era 400))] + [doy (- doe (- (+ (* 365 yoe) (div yoe 4)) (div yoe 100)))] + [mp (div (+ (* 5 doy) 2) 153)] + [d (+ (- doy (div (+ (* 153 mp) 2) 5)) 1)] + [m (+ mp (if (< mp 10) 3 -9))] + [y (if (<= m 2) (+ y 1) y)] + [tod (mod secs 86400)] + [tod (if (< tod 0) (+ tod 86400) tod)] + [hh (div tod 3600)] [mm (div (mod tod 3600) 60)] [ss (mod tod 60)] + [p2 (lambda (n) (if (< n 10) (format "0~a" n) (number->string n)))]) + (format "~a-~a-~aT~a:~a:~aZ" y (p2 m) (p2 d) (p2 hh) (p2 mm) (p2 ss)))) + + (def (tuf-now) + ;; override for tests: JPKG_TUF_NOW="2030-01-01T00:00:00Z" + (or (getenv "JPKG_TUF_NOW") + (iso8601-of-epoch (time-second (current-time))))) + + (def (expired? expires) + (unless (and (string? expires) (= (string-length expires) 20)) + (jpkg-error "tuf: bad expires timestamp ~s" expires)) + ;; zulu ISO-8601 compares lexicographically + (string<=? expires (tuf-now))) + + ;; ── keys ─────────────────────────────────────────────────────────────── + + (def (key-object pub-hex) + (list (cons "keytype" "ed25519") + (cons "keyval" (list (cons "public" pub-hex))) + (cons "scheme" "ed25519"))) + + (def (key->keyid key-obj) + (sha256-hex-of-bytevector (string->utf8 (canonical-json key-obj)))) + + ;; generator-side key record: (keyid pub-hex seed key-obj) + (def (tuf-keygen seed) + (unless (and (bytevector? seed) (= (bytevector-length seed) 32)) + (jpkg-error "tuf: key seed must be 32 bytes")) + (let* ([pub (ed25519-public-key seed)] + [pub-hex (bytes->hex pub)] + [obj (key-object pub-hex)]) + (list (key->keyid obj) pub-hex seed obj))) + + (def (kr-keyid k) (car k)) + (def (kr-pubhex k) (cadr k)) + (def (kr-seed k) (caddr k)) + (def (kr-obj k) (cadddr k)) + + ;; ── signature verification ───────────────────────────────────────────── + + (def (verify-envelope envelope role-keyids threshold keydb what) + ;; role-keyids: list of authorized keyids; keydb: alist keyid -> pub-hex + (let* ([payload (signed-payload-bytes envelope)] + [sigs (oref! envelope "signatures" what)] + [sigs (vector->list sigs)] + [good + (let loop ([sigs sigs] [seen '()] [count 0]) + (cond + [(null? sigs) count] + [else + (let* ([s (car sigs)] + [keyid (oref! s "keyid" "signature")] + [sighex (oref! s "sig" "signature")]) + (if (and (member keyid role-keyids) + (not (member keyid seen)) ;; one vote per key + (let ([pub (oref keydb keyid)]) + (and pub + (ed25519-verify* (hex->bytes pub) + payload + (hex->bytes sighex))))) + (loop (cdr sigs) (cons keyid seen) (+ count 1)) + (loop (cdr sigs) seen count)))]))]) + (when (< good threshold) + (jpkg-error "tuf: ~a: ~a valid signature~a, threshold ~a" + what good (if (= good 1) "" "s") threshold)) + #t)) + + (def (root-keydb root-signed) + ;; keyid -> pub-hex from root's key table; keyid self-check enforced + (map (lambda (entry) + (let* ([keyid (car entry)] + [obj (cdr entry)] + [keytype (oref! obj "keytype" "key")] + [pub (oref! (oref! obj "keyval" "key") "public" "keyval")]) + (unless (string=? keytype "ed25519") + (jpkg-error "tuf: unsupported keytype ~a" keytype)) + (unless (string=? (key->keyid obj) keyid) + (jpkg-error "tuf: keyid does not match key content")) + (cons keyid pub))) + (oref! root-signed "keys" "root"))) + + (def (role-of root-signed name) + (let ([r (oref! (oref! root-signed "roles" "root") name "roles")]) + (cons (vector->list (oref! r "keyids" name)) + (oref! r "threshold" name)))) + + (def (check-type! signed expected) + (unless (equal? (oref! signed "_type" "metadata") expected) + (jpkg-error "tuf: expected _type ~a" expected))) + + (def (check-version! signed what) + (let ([v (oref! signed "version" what)]) + (unless (and (integer? v) (exact? v) (> v 0)) + (jpkg-error "tuf: bad version in ~a" what)) + v)) + + ;; ── client state ─────────────────────────────────────────────────────── + + (def (jpkg-home*) + (or (getenv "JERBOA_PKG_HOME") + (let ([home (or (getenv "HOME") (jpkg-error "tuf: HOME not set"))]) + (path-concat home ".jerboa/pkg")))) + + (def (pinned-root-path name) + (path-concat (jpkg-home*) (string-append "roots/" name ".root.json"))) + + (def (state-path name) + (path-concat (jpkg-home*) (string-append "registries/" name ".state"))) + + (def (load-state name) + ;; ((timestamp . v) (snapshot . v) (targets . v) (root . v)) or '() + (let ([p (state-path name)]) + (if (file-exists? p) + (let ([text (or (bytes->utf8-or-false (read-file-bytevector p)) "()")]) + (let ([d (with-input-from-string text read)]) + (if (list? d) d '()))) + '()))) + + (def (save-state! name st) + (mkdir-p (path-concat (jpkg-home*) "registries")) + (write-file-bytevector + (state-path name) + (string->utf8 (call-with-string-output-port + (lambda (p) (write st p) (newline p)))))) + + (def (state-ref st key) (let ([p (assq key st)]) (and p (cdr p)))) + (def (state-set st key v) + (cons (cons key v) (filter (lambda (p) (not (eq? (car p) key))) st))) + + ;; ── client: trust establishment + update ─────────────────────────────── + + (def (tuf-registry? reg-path) + (file-exists? (path-concat reg-path "metadata/root.json"))) + + (def (verify-root-self envelope) + ;; a root envelope must satisfy ITS OWN root role + (let* ([signed (oref! envelope "signed" "root")] + [keydb (root-keydb signed)] + [role (role-of signed "root")]) + (check-type! signed "root") + (verify-envelope envelope (car role) (cdr role) keydb "root.json") + signed)) + + (def (load-pinned-root name reg-path) + ;; returns (envelope . signed); pins on first use (TOFU) + (let ([pp (pinned-root-path name)]) + (if (file-exists? pp) + (let* ([env (json-file->canonical pp)] + [signed (verify-root-self env)]) + (cons env signed)) + (let* ([rp (path-concat reg-path "metadata/root.json")] + [env (json-file->canonical rp)] + [signed (verify-root-self env)]) + (mkdir-p (path-concat (jpkg-home*) "roots")) + (write-file-bytevector pp (read-file-bytevector rp)) + (cons env signed))))) + + (def (maybe-rotate-root! name reg-path pinned) + ;; if the registry serves a newer root, verify the chain: + ;; new root must satisfy the OLD root role AND its own role. + (let* ([penv (car pinned)] [psigned (cdr pinned)] + [pversion (check-version! psigned "root.json")] + [rp (path-concat reg-path "metadata/root.json")] + [renv (json-file->canonical rp)] + [rsigned (oref! renv "signed" "root")] + [rversion (check-version! rsigned "root.json")]) + (cond + [(= rversion pversion) pinned] + [(< rversion pversion) + (jpkg-error "tuf: registry serves older root (v~a < pinned v~a) — rollback attack?" + rversion pversion)] + [else + (check-type! rsigned "root") + (unless (= rversion (+ pversion 1)) + (jpkg-error "tuf: root version skipped (v~a -> v~a)" pversion rversion)) + ;; old role must approve the new root + (let ([old-keydb (root-keydb psigned)] + [old-role (role-of psigned "root")]) + (verify-envelope renv (car old-role) (cdr old-role) + old-keydb "root.json (chain)")) + ;; and the new root must satisfy itself + (verify-root-self renv) + (write-file-bytevector (pinned-root-path name) + (read-file-bytevector rp)) + (cons renv rsigned)]))) + + (def (check-meta-entry! meta-obj fname bytes what) + ;; verify bytes against {"version","length","hashes":{"sha256"}} entry + (let ([entry (oref! meta-obj fname what)]) + (let ([len (oref! entry "length" fname)] + [hashes (oref! entry "hashes" fname)]) + (unless (= len (bytevector-length bytes)) + (jpkg-error "tuf: ~a length mismatch" fname)) + (let ([want (oref! hashes "sha256" fname)]) + (unless (string=? want (sha256-hex-of-bytevector bytes)) + (jpkg-error "tuf: ~a hash mismatch (tampered mirror?)" fname)))) + (oref! entry "version" fname))) + + ;; Full verification; returns the verified targets "signed" object. + (def (tuf-context name reg-path) + (let* ([pinned (load-pinned-root name reg-path)] + [pinned (maybe-rotate-root! name reg-path pinned)] + [root-signed (cdr pinned)] + [keydb (root-keydb root-signed)] + [st (load-state name)]) + (when (expired? (oref! root-signed "expires" "root.json")) + (jpkg-error "tuf: root metadata expired (freeze attack or stale registry)")) + ;; timestamp + (let* ([ts-bytes (read-file-bytevector + (path-concat reg-path "metadata/timestamp.json"))] + [ts-env (canonical-of-json-text + (or (bytes->utf8-or-false ts-bytes) + (jpkg-error "tuf: timestamp not UTF-8")))] + [ts-signed (oref! ts-env "signed" "timestamp")] + [ts-role (role-of root-signed "timestamp")]) + (check-type! ts-signed "timestamp") + (verify-envelope ts-env (car ts-role) (cdr ts-role) keydb "timestamp.json") + (when (expired? (oref! ts-signed "expires" "timestamp")) + (jpkg-error "tuf: timestamp expired (freeze attack or stale registry)")) + (let ([ts-version (check-version! ts-signed "timestamp.json")] + [cached (state-ref st 'timestamp)]) + (when (and cached (< ts-version cached)) + (jpkg-error "tuf: timestamp version went backwards (v~a < v~a) — rollback attack?" + ts-version cached)) + ;; snapshot + (let* ([sn-bytes (read-file-bytevector + (path-concat reg-path "metadata/snapshot.json"))] + [sn-version-expected + (check-meta-entry! (oref! ts-signed "meta" "timestamp") + "snapshot.json" sn-bytes "timestamp")] + [sn-env (canonical-of-json-text (utf8->string sn-bytes))] + [sn-signed (oref! sn-env "signed" "snapshot")] + [sn-role (role-of root-signed "snapshot")]) + (check-type! sn-signed "snapshot") + (verify-envelope sn-env (car sn-role) (cdr sn-role) keydb "snapshot.json") + (when (expired? (oref! sn-signed "expires" "snapshot")) + (jpkg-error "tuf: snapshot expired")) + (let ([sn-version (check-version! sn-signed "snapshot.json")] + [sn-cached (state-ref st 'snapshot)]) + (unless (= sn-version sn-version-expected) + (jpkg-error "tuf: snapshot version does not match timestamp meta")) + (when (and sn-cached (< sn-version sn-cached)) + (jpkg-error "tuf: snapshot version went backwards — rollback attack?")) + ;; targets + (let* ([tg-bytes (read-file-bytevector + (path-concat reg-path "metadata/targets.json"))] + [tg-version-expected + (check-meta-entry! (oref! sn-signed "meta" "snapshot") + "targets.json" tg-bytes "snapshot")] + [tg-env (canonical-of-json-text (utf8->string tg-bytes))] + [tg-signed (oref! tg-env "signed" "targets")] + [tg-role (role-of root-signed "targets")]) + (check-type! tg-signed "targets") + (verify-envelope tg-env (car tg-role) (cdr tg-role) keydb "targets.json") + (when (expired? (oref! tg-signed "expires" "targets")) + (jpkg-error "tuf: targets expired")) + (let ([tg-version (check-version! tg-signed "targets.json")] + [tg-cached (state-ref st 'targets)]) + (unless (= tg-version tg-version-expected) + (jpkg-error "tuf: targets version does not match snapshot meta")) + (when (and tg-cached (< tg-version tg-cached)) + (jpkg-error "tuf: targets version went backwards — rollback attack?")) + ;; persist monotonic state + (save-state! name + (state-set + (state-set + (state-set st 'timestamp ts-version) + 'snapshot sn-version) + 'targets tg-version)) + 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))]) + (let ([len (oref! entry "length" target-path)] + [hashes (oref! entry "hashes" target-path)]) + (unless (= len (bytevector-length bytes)) + (jpkg-error "tuf: ~a length mismatch" target-path)) + (unless (string=? (oref! hashes "sha256" target-path) + (sha256-hex-of-bytevector bytes)) + (jpkg-error "tuf: ~a digest mismatch (tampered mirror?)" target-path))) + bytes))