jpkg phase 1: local package primitives
ober
ccf91275a40078a152812215a9aa6bfa0d59f1e4
--- a/docs/jpkg-plan.md +++ b/docs/jpkg-plan.md @@ -543,7 +543,17 @@ Tracked per phase as implementation lands. Tests live in `tests/test-jpkg*.ss` "Project Files" above — a non-executable Jerboa-readable data file with strict unknown/duplicate-field rejection and canonical JSON as the signing representation. -- Phase 1 (local package primitives): not started. +- Phase 1 (local package primitives): DONE. `jpkg init`, `jpkg new`, + `jpkg pack`, `jpkg verify`. Strict manifest parser/validator with + normalized sexp + canonical JSON renderings (`lib/std/pkg/manifest.ss`, + `canonical.ss`); full semver versions/ranges (`semver.ss`); deterministic + ustar writer + strict pre-extraction validator with traversal/symlink/ + device/setuid/limit rejection (`tarball.ss`); deterministic gzip framing, + pure Scheme, with a full inflate for reading foreign artifacts + (`gzipio.ss`); .jpkg pipeline with mandatory normalized embedded manifest + (`artifact.ss`); content-addressed store with atomic verified inserts + (`store.ss`). `.jpkg` is deterministic tar.gz (stored-block deflate for + byte-stable output everywhere; reader accepts any conformant gzip). - Phase 2 (lockfile and resolver): not started. - Phase 3 (static registry with TUF): not started. - Phase 4 (signing and provenance): not started. new file mode 100644 --- /dev/null +++ b/lib/std/pkg/artifact.ss @@ -0,0 +1,191 @@ +#!chezscheme +;;; (std pkg artifact) — .jpkg artifact creation and verification. +;;; +;;; A .jpkg is deterministic gzip (std pkg gzipio) around a deterministic +;;; ustar archive (std pkg tarball) that MUST contain a normalized +;;; `jpkg.sexp` manifest at the root. The verification pipeline never +;;; extracts before the digest, gzip framing, archive structure, and +;;; embedded manifest have all been validated. + +(library (std pkg artifact) + (export pack-project + artifact-validate + artifact-info? artifact-info-manifest artifact-info-entries + artifact-info-digest artifact-info-size + artifact-extract + artifact-file-name + jpkg-max-artifact-bytes) + + (import (chezscheme) + (only (jerboa core) def defstruct try catch) + (only (std pkg util) + jpkg-error read-file-bytevector write-file-bytevector + sha256-hex-of-bytevector walk-files path-concat + string-prefix-of? string-suffix-of? string-split-char + mkdir-p) + (only (std pkg gzipio) gzip-deterministic gunzip-checked) + (only (std pkg tarball) + tar-create-deterministic tar-validate tar-extract-validated + tar-entry-name tar-entry-dir? tar-entry-content + jpkg-max-total-size) + (only (std pkg manifest) + parse-manifest-file parse-manifest-string + manifest-name manifest-version manifest-modules + manifest->sexp-text)) + + (def jpkg-max-artifact-bytes (* 64 1024 1024)) ;; compressed size cap + + (defstruct artifact-info (manifest entries digest size)) + + ;; ── file selection for pack ──────────────────────────────────────────── + + (def excluded-dirs + '(".git" ".hg" ".svn" ".jj" "node_modules" "target" "build" "dist" + ".chez" ".cache")) + + (def excluded-suffixes + '(".so" ".wpo" ".o" ".a" ".dylib" ".jpkg" ".lock")) + + (def (excluded-file? rel) + (let ([base (let loop ([i (- (string-length rel) 1)]) + (cond [(< i 0) rel] + [(char=? (string-ref rel i) #\/) + (substring rel (+ i 1) (string-length rel))] + [else (loop (- i 1))]))]) + (or (and (> (string-length base) 0) (char=? (string-ref base 0) #\.)) + (string=? base "jpkg.sexp") ;; re-rendered, never copied raw + (exists (lambda (sfx) (string-suffix-of? sfx base)) excluded-suffixes)))) + + (def (excluded-path? rel) + (let ([segs (string-split-char rel #\/)]) + (or (exists (lambda (seg) + (or (member seg excluded-dirs) + (and (> (string-length seg) 0) + (char=? (string-ref seg 0) #\.)))) + segs) + (excluded-file? rel)))) + + (def (top-level-keeper? rel) + ;; top-level docs always included + (and (not (let loop ([i 0]) + (cond [(= i (string-length rel)) #f] + [(char=? (string-ref rel i) #\/) #t] + [else (loop (+ i 1))]))) + (exists (lambda (p) (string-prefix-of? p rel)) + '("README" "LICENSE" "NOTICE" "CHANGELOG")))) + + (def (collect-project-files project-dir root) + ;; returns sorted relative paths to include (excluding jpkg.sexp) + (let ([acc '()]) + (walk-files project-dir + (lambda (rel) + (let ([in-root? + (or (string=? root ".") + (string-prefix-of? (string-append root "/") rel))]) + (when (or (and in-root? (not (excluded-path? rel))) + (top-level-keeper? rel)) + (set! acc (cons rel acc)))))) + (list-sort string<? acc))) + + ;; ── pack ─────────────────────────────────────────────────────────────── + + (def (executable-file? path) + (let ([mode (get-mode path)]) + (not (= 0 (bitwise-and mode #o100))))) + + (def (parent-dirs-of paths) + ;; every intermediate directory of the relative paths, deduped + (let ([t (make-hashtable string-hash string=?)]) + (for-each + (lambda (p) + (let ([segs (string-split-char p #\/)]) + (let loop ([acc ""] [segs segs]) + (when (pair? (cdr segs)) + (let ([dir (if (string=? acc "") + (car segs) + (string-append acc "/" (car segs)))]) + (hashtable-set! t dir #t) + (loop dir (cdr segs))))))) + paths) + (vector->list (hashtable-keys t)))) + + (def (pack-project project-dir output-path) + ;; Validates ./jpkg.sexp, collects files, writes a deterministic + ;; artifact to output-path. Returns (values path digest size). + (let* ([manifest-path (path-concat project-dir "jpkg.sexp")] + [m (parse-manifest-file manifest-path)] + [root (if (manifest-modules m) + (cdr (assq 'root (manifest-modules m))) + "src")] + [normalized (manifest->sexp-text m)] + ;; round-trip guard: the normalized text must re-parse equal + [_ (parse-manifest-string normalized)] + [files (collect-project-files project-dir root)] + [entries + (cons + (list "jpkg.sexp" #f #f (string->utf8 normalized)) + (append + (map (lambda (d) (list d #t #f #f)) (parent-dirs-of files)) + (map (lambda (rel) + (let ([abs (path-concat project-dir rel)]) + (list rel #f (executable-file? abs) + (read-file-bytevector abs)))) + files)))] + [tar (tar-create-deterministic entries)] + [artifact (gzip-deterministic tar)]) + (when (> (bytevector-length artifact) jpkg-max-artifact-bytes) + (jpkg-error "pack: artifact exceeds size limit")) + (write-file-bytevector output-path artifact) + (values output-path + (sha256-hex-of-bytevector artifact) + (bytevector-length artifact)))) + + (def (artifact-file-name m) + ;; "@scope/name" 1.2.3 -> scope-name-1.2.3.jpkg + (let* ([name (manifest-name m)] + [no-at (substring name 1 (string-length name))] + [flat (list->string (map (lambda (c) (if (char=? c #\/) #\- c)) + (string->list no-at)))]) + (string-append flat "-" (manifest-version m) ".jpkg"))) + + ;; ── verify ───────────────────────────────────────────────────────────── + + (def (artifact-validate-bytes bv) + ;; full pipeline on in-memory artifact; returns artifact-info + (when (> (bytevector-length bv) jpkg-max-artifact-bytes) + (jpkg-error "artifact: compressed size exceeds limit")) + (let* ([tar (gunzip-checked bv jpkg-max-total-size)] + [entries (tar-validate tar)] + [manifest-entry + (or (find (lambda (e) (and (not (tar-entry-dir? e)) + (string=? (tar-entry-name e) "jpkg.sexp"))) + entries) + (jpkg-error "artifact: missing embedded jpkg.sexp manifest"))] + [mtext (let ([c (tar-entry-content tar manifest-entry)]) + (utf8->string c))] + [m (parse-manifest-string mtext)]) + ;; the embedded manifest must be in normalized form + (unless (string=? mtext (manifest->sexp-text m)) + (jpkg-error "artifact: embedded manifest is not in normalized form")) + (make-artifact-info m entries + (sha256-hex-of-bytevector bv) + (bytevector-length bv)))) + + (def (artifact-validate path) + (unless (file-exists? path) + (jpkg-error "artifact: file not found: ~a" path)) + (artifact-validate-bytes (read-file-bytevector path))) + + ;; ── extract ──────────────────────────────────────────────────────────── + + (def (artifact-extract path dest) + ;; validate, then extract into dest (created; must not exist) + (let ([info (artifact-validate path)]) + (when (file-exists? dest) + (jpkg-error "artifact: extraction target already exists: ~a" dest)) + (mkdir-p dest) + (let ([tar (gunzip-checked (read-file-bytevector path) jpkg-max-total-size)]) + (tar-extract-validated tar (artifact-info-entries info) dest)) + info)) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/pkg/canonical.ss @@ -0,0 +1,106 @@ +#!chezscheme +;;; (std pkg canonical) — canonical JSON encoding for signing. +;;; +;;; jpkg signs canonical JSON (RFC 8785 subset): object keys sorted, +;;; no insignificant whitespace, minimal escapes, exact integers only. +;;; The data model is deliberately restricted so every encodable value +;;; has exactly one encoding: +;;; +;;; string -> JSON string +;;; exact integer -> JSON number +;;; #t / #f -> true / false +;;; 'null -> null +;;; vector of values -> JSON array +;;; list of (string . value) pairs -> JSON object (keys sorted, no dups) +;;; +;;; Floats are rejected (no canonical float formatting headaches), and +;;; object keys must be ASCII so bytewise ordering equals the RFC 8785 +;;; UTF-16 code unit ordering. + +(library (std pkg canonical) + (export canonical-json + canonical-json-bytes) + + (import (chezscheme) + (only (jerboa core) def) + (only (std pkg util) jpkg-error)) + + (def (ascii-string? s) + (let loop ([i 0]) + (or (= i (string-length s)) + (and (< (char->integer (string-ref s i)) 128) + (loop (+ i 1)))))) + + (def (json-escape-string s out) + (put-char out #\") + (let ([n (string-length s)]) + (let loop ([i 0]) + (when (< i n) + (let* ([c (string-ref s i)] [code (char->integer c)]) + (cond + [(char=? c #\") (put-string out "\\\"")] + [(char=? c #\\) (put-string out "\\\\")] + [(= code 8) (put-string out "\\b")] + [(= code 9) (put-string out "\\t")] + [(= code 10) (put-string out "\\n")] + [(= code 12) (put-string out "\\f")] + [(= code 13) (put-string out "\\r")] + [(< code 32) + (put-string out "\\u") + (let ([hex (number->string code 16)]) + (do ([k (string-length hex) (+ k 1)]) ((= k 4)) (put-char out #\0)) + (put-string out hex))] + [else (put-char out c)])) + (loop (+ i 1))))) + (put-char out #\")) + + (def (object? v) + ;; () is the empty object; non-empty: every element a (string . value) pair + (and (list? v) + (for-all (lambda (e) (and (pair? e) (string? (car e)))) v))) + + (def (emit v out) + (cond + [(string? v) (json-escape-string v out)] + [(and (integer? v) (exact? v)) (put-string out (number->string v))] + [(eq? v #t) (put-string out "true")] + [(eq? v #f) (put-string out "false")] + [(eq? v 'null) (put-string out "null")] + [(vector? v) + (put-char out #\[) + (let ([n (vector-length v)]) + (do ([i 0 (+ i 1)]) ((= i n)) + (when (> i 0) (put-char out #\,)) + (emit (vector-ref v i) out))) + (put-char out #\])] + [(object? v) + (let ([keys (map car v)]) + (for-each (lambda (k) + (unless (ascii-string? k) + (jpkg-error "canonical-json: non-ASCII object key ~s" k))) + keys) + (let ([sorted (list-sort (lambda (a b) (string<? (car a) (car b))) v)]) + ;; reject duplicates + (let loop ([ps sorted]) + (when (and (pair? ps) (pair? (cdr ps))) + (when (string=? (caar ps) (caadr ps)) + (jpkg-error "canonical-json: duplicate object key ~s" (caar ps))) + (loop (cdr ps)))) + (put-char out #\{) + (let loop ([ps sorted] [first #t]) + (unless (null? ps) + (unless first (put-char out #\,)) + (json-escape-string (caar ps) out) + (put-char out #\:) + (emit (cdar ps) out) + (loop (cdr ps) #f))) + (put-char out #\})))] + [else (jpkg-error "canonical-json: unencodable value ~s" v)])) + + (def (canonical-json v) + (call-with-string-output-port (lambda (out) (emit v out)))) + + (def (canonical-json-bytes v) + (string->utf8 (canonical-json v))) + + ) ;; end library --- a/lib/std/pkg/cli.ss +++ b/lib/std/pkg/cli.ss @@ -22,7 +22,9 @@ jpkg-help-text) (import (chezscheme) - (only (jerboa core) def try catch)) + (only (jerboa core) def try catch) + (only (std pkg util) jpkg-error? jpkg-error-message) + (only (std pkg commands) cmd-init cmd-new cmd-pack cmd-verify)) (def jpkg-version "0.1.0") @@ -41,10 +43,10 @@ (def *commands* (list - (list "init" "jpkg init" - "create jpkg.sexp for the current project" (stub "phase 1")) + (list "init" "jpkg init [NAME]" + "create jpkg.sexp for the current project" cmd-init) (list "new" "jpkg new NAME" - "create a new package template" (stub "phase 1")) + "create a new package template" cmd-new) (list "add" "jpkg add PKG[@VERSION]" "add dependency and update lockfile" (stub "phase 2")) (list "remove" "jpkg remove PKG" @@ -63,10 +65,10 @@ "build under policy-controlled sandbox" (stub "phase 5")) (list "clean" "jpkg clean [PKG ...]" "remove build outputs" (stub "phase 5")) - (list "pack" "jpkg pack" - "create deterministic local .jpkg artifact" (stub "phase 1")) - (list "verify" "jpkg verify" - "verify manifest, lock, artifacts, signatures" (stub "phase 1")) + (list "pack" "jpkg pack [--output FILE]" + "create deterministic local .jpkg artifact" cmd-pack) + (list "verify" "jpkg verify [FILE.jpkg]" + "verify manifest, lock, artifacts, signatures" cmd-verify) (list "audit" "jpkg audit" "check advisories, yanks, policy drift" (stub "phase 6")) (list "publish" "jpkg publish" @@ -171,7 +173,9 @@ (catch (e) (let ([p (current-error-port)]) (put-string p "jpkg: error: ") - (display-condition e p) + (if (jpkg-error? e) + (put-string p (jpkg-error-message e)) + (display-condition e p)) (put-string p "\n") (flush-output-port p)) 1))))] new file mode 100644 --- /dev/null +++ b/lib/std/pkg/commands.ss @@ -0,0 +1,155 @@ +#!chezscheme +;;; (std pkg commands) — implementations behind the jpkg CLI. +;;; +;;; Each cmd-* takes the post-command argument list and returns an exit +;;; code; user-facing failures raise jpkg conditions that the CLI prints. +;;; Phase 1: init, new, pack, verify. + +(library (std pkg commands) + (export cmd-init cmd-new cmd-pack cmd-verify) + + (import (chezscheme) + (only (jerboa core) def try catch) + (only (std pkg util) + jpkg-error mkdir-p path-concat path-basename + write-file-bytevector string-suffix-of?) + (only (std pkg manifest) + manifest-template parse-manifest-file + manifest-name manifest-version valid-package-name?) + (only (std pkg artifact) + pack-project artifact-validate artifact-file-name + artifact-info-manifest artifact-info-entries + artifact-info-digest artifact-info-size) + (only (std pkg tarball) tar-entry-dir?)) + + (def (say fmt . args) + (let ([p (current-output-port)]) + (put-string p (apply format fmt args)) + (put-string p "\n") + (flush-output-port p))) + + ;; ── init ─────────────────────────────────────────────────────────────── + + (def (sanitize-dir-name s) + (let* ([lowered (list->string + (map (lambda (c) + (cond [(char<=? #\A c #\Z) + (integer->char (+ 32 (char->integer c)))] + [(or (char<=? #\a c #\z) + (char<=? #\0 c #\9) + (char=? c #\-)) + c] + [else #\-])) + (string->list s)))] + ;; strip leading/trailing dashes + [n (string-length lowered)] + [start (let loop ([i 0]) (if (and (< i n) (char=? (string-ref lowered i) #\-)) + (loop (+ i 1)) i))] + [end (let loop ([i n]) (if (and (> i start) + (char=? (string-ref lowered (- i 1)) #\-)) + (loop (- i 1)) i))]) + (let ([r (substring lowered start end)]) + (if (string=? r "") "package" r)))) + + (def (cmd-init args) + (let ([name (cond + [(null? args) + (string-append "@local/" + (sanitize-dir-name + (path-basename (current-directory))))] + [(null? (cdr args)) (car args)] + [else (jpkg-error "usage: jpkg init [NAME]")])]) + (unless (valid-package-name? name) + (jpkg-error "invalid package name ~s (want @scope/name, lowercase)" name)) + (when (file-exists? "jpkg.sexp") + (jpkg-error "jpkg.sexp already exists (refusing to overwrite)")) + (write-file-bytevector "jpkg.sexp" (string->utf8 (manifest-template name))) + ;; template must always re-parse + (parse-manifest-file "jpkg.sexp") + (say "created jpkg.sexp for ~a" name) + 0)) + + ;; ── new ──────────────────────────────────────────────────────────────── + + (def main-ss-template + (string-append + ";;; main.ss — package entry point\n" + "(import (jerboa prelude))\n" + "\n" + "(def (main)\n" + " (displayln \"hello from jpkg\"))\n" + "\n" + "(main)\n")) + + (def (cmd-new args) + (unless (and (pair? args) (null? (cdr args))) + (jpkg-error "usage: jpkg new NAME (NAME like @scope/name)")) + (let ([name (car args)]) + (unless (valid-package-name? name) + (jpkg-error "invalid package name ~s (want @scope/name, lowercase)" name)) + (let* ([dir (let loop ([i 0]) ;; directory = part after the slash + (if (char=? (string-ref name i) #\/) + (substring name (+ i 1) (string-length name)) + (loop (+ i 1))))]) + (when (file-exists? dir) + (jpkg-error "directory ~a already exists" dir)) + (mkdir-p (path-concat dir "src")) + (write-file-bytevector (path-concat dir "jpkg.sexp") + (string->utf8 (manifest-template name))) + (write-file-bytevector (path-concat dir "src/main.ss") + (string->utf8 main-ss-template)) + (write-file-bytevector + (path-concat dir "README.md") + (string->utf8 (string-append "# " name "\n"))) + (parse-manifest-file (path-concat dir "jpkg.sexp")) + (say "created package ~a in ~a/" name dir) + (say " ~a/jpkg.sexp" dir) + (say " ~a/src/main.ss" dir) + (say " ~a/README.md" dir) + 0))) + + ;; ── pack ─────────────────────────────────────────────────────────────── + + (def (cmd-pack args) + (let ([output + (cond + [(null? args) #f] + [(and (string=? (car args) "--output") (pair? (cdr args)) + (null? (cddr args))) + (cadr args)] + [else (jpkg-error "usage: jpkg pack [--output FILE]")])]) + (let* ([m (parse-manifest-file "jpkg.sexp")] + [out (or output (artifact-file-name m))]) + (let-values ([(path digest size) (pack-project "." out)]) + ;; the artifact must verify with the same pipeline installs use + (artifact-validate path) + (say "packed ~a ~a" (manifest-name m) (manifest-version m)) + (say " artifact: ~a" path) + (say " sha256: ~a" digest) + (say " size: ~a bytes" size) + 0)))) + + ;; ── verify ───────────────────────────────────────────────────────────── + + (def (cmd-verify args) + (cond + ;; no args: verify the project manifest + [(null? args) + (let ([m (parse-manifest-file "jpkg.sexp")]) + (say "ok: jpkg.sexp valid (~a ~a)" (manifest-name m) (manifest-version m)) + 0)] + ;; verify an artifact file + [(and (null? (cdr args)) (string-suffix-of? ".jpkg" (car args))) + (let* ([info (artifact-validate (car args))] + [m (artifact-info-manifest info)] + [files (filter (lambda (e) (not (tar-entry-dir? e))) + (artifact-info-entries info))]) + (say "ok: ~a" (car args)) + (say " package: ~a ~a" (manifest-name m) (manifest-version m)) + (say " sha256: ~a" (artifact-info-digest info)) + (say " size: ~a bytes" (artifact-info-size info)) + (say " files: ~a" (length files)) + 0)] + [else (jpkg-error "usage: jpkg verify [FILE.jpkg]")])) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/pkg/gzipio.ss @@ -0,0 +1,315 @@ +#!chezscheme +;;; (std pkg gzipio) — deterministic gzip for .jpkg artifacts, pure Scheme. +;;; +;;; Writer: RFC 1952 gzip framing around RFC 1951 *stored* deflate blocks. +;;; Stored blocks compress nothing, but the output is byte-deterministic +;;; (mtime=0, XFL=0, OS=255, fixed block segmentation), valid for any +;;; gunzip, and needs no native library — so `jpkg pack` produces +;;; identical artifacts in dev trees, multicall binaries, and static +;;; builds. Compression can move to zstd later per docs/jpkg-plan.md. +;;; +;;; Reader: full RFC 1951 inflate (stored, fixed, dynamic huffman) with a +;;; hard expansion limit, plus CRC32 and ISIZE verification — so third +;;; party .jpkg artifacts written with real compressors verify too. + +(library (std pkg gzipio) + (export gzip-deterministic + gunzip-checked + crc32-of) + + (import (chezscheme) + (only (jerboa core) def) + (only (std pkg util) jpkg-error)) + + ;; ── crc32 ────────────────────────────────────────────────────────────── + + (def crc-table + (let ([t (make-vector 256 0)]) + (do ([n 0 (+ n 1)]) ((= n 256) t) + (let loop ([c n] [k 0]) + (if (= k 8) + (vector-set! t n c) + (loop (if (odd? c) + (fxxor #xedb88320 (fxsrl c 1)) + (fxsrl c 1)) + (+ k 1))))))) + + (def (crc32-of bv) + (let ([n (bytevector-length bv)]) + (let loop ([i 0] [c #xffffffff]) + (if (= i n) + (fxxor c #xffffffff) + (loop (+ i 1) + (fxxor (vector-ref crc-table + (fxand (fxxor c (bytevector-u8-ref bv i)) #xff)) + (fxsrl c 8))))))) + + ;; ── gzip writer (stored blocks) ──────────────────────────────────────── + + (def (put-u16le out v) + (put-u8 out (fxand v #xff)) + (put-u8 out (fxand (fxsrl v 8) #xff))) + + (def (put-u32le out v) + (put-u8 out (bitwise-and v #xff)) + (put-u8 out (bitwise-and (bitwise-arithmetic-shift-right v 8) #xff)) + (put-u8 out (bitwise-and (bitwise-arithmetic-shift-right v 16) #xff)) + (put-u8 out (bitwise-and (bitwise-arithmetic-shift-right v 24) #xff))) + + (def (gzip-deterministic data) + (let-values ([(out get) (open-bytevector-output-port)]) + ;; header: magic, CM=8 (deflate), FLG=0, MTIME=0, XFL=0, OS=255 + (put-u8 out #x1f) (put-u8 out #x8b) (put-u8 out 8) (put-u8 out 0) + (put-u32le out 0) (put-u8 out 0) (put-u8 out 255) + ;; deflate stored blocks, 65535-byte segments + (let ([n (bytevector-length data)]) + (if (= n 0) + (begin (put-u8 out 1) (put-u16le out 0) (put-u16le out #xffff)) + (let loop ([off 0]) + (let* ([len (min 65535 (- n off))] + [final? (= (+ off len) n)]) + (put-u8 out (if final? 1 0)) + (put-u16le out len) + (put-u16le out (fxand (fxnot len) #xffff)) + (put-bytevector out data off len) + (unless final? (loop (+ off len))))))) + (put-u32le out (crc32-of data)) + (put-u32le out (bitwise-and (bytevector-length data) #xffffffff)) + (get))) + + ;; ── inflate (full RFC 1951) ──────────────────────────────────────────── + ;; Bit reader, LSB first. + + (def (inflate bv start limit) + ;; returns (values output-bytevector bytes-consumed-after-start) + (let ([byte-pos start] [bit-pos 0] + [out (make-bytevector (min limit 65536))] [out-len 0]) + (define (ensure-out! extra) + (let ([need (+ out-len extra)]) + (when (> need limit) + (jpkg-error "gunzip: expanded size exceeds limit (~a bytes)" limit)) + (when (> need (bytevector-length out)) + (let* ([newcap (max need (min limit (* 2 (bytevector-length out))))] + [nv (make-bytevector newcap)]) + (bytevector-copy! out 0 nv 0 out-len) + (set! out nv))))) + (define (emit! b) + (ensure-out! 1) + (bytevector-u8-set! out out-len b) + (set! out-len (+ out-len 1))) + (define (need-byte) + (when (>= byte-pos (bytevector-length bv)) + (jpkg-error "gunzip: truncated deflate stream"))) + (define (read-bit) + (need-byte) + (let ([b (fxand (fxsrl (bytevector-u8-ref bv byte-pos) bit-pos) 1)]) + (if (= bit-pos 7) + (begin (set! bit-pos 0) (set! byte-pos (+ byte-pos 1))) + (set! bit-pos (+ bit-pos 1))) + b)) + (define (read-bits n) + (let loop ([i 0] [v 0]) + (if (= i n) v + (loop (+ i 1) (fxior v (fxsll (read-bit) i)))))) + (define (align-byte!) + (unless (= bit-pos 0) + (set! bit-pos 0) + (set! byte-pos (+ byte-pos 1)))) + ;; canonical huffman decoder from code lengths + (define (build-decoder lengths) + ;; returns proc () -> symbol-index, via simple per-length tables + (let* ([maxlen (fold-left max 0 (vector->list lengths))] + [counts (make-vector (+ maxlen 1) 0)]) + (when (= maxlen 0) + (jpkg-error "gunzip: empty huffman table")) + (vector-for-each + (lambda (l) (when (> l 0) + (vector-set! counts l (+ 1 (vector-ref counts l))))) + lengths) + ;; first code per length + symbol table ordered by (length, symbol) + (let ([first-code (make-vector (+ maxlen 1) 0)] + [first-sym (make-vector (+ maxlen 1) 0)] + [syms (make-vector (vector-length lengths) 0)]) + (let loop ([l 1] [code 0] [sym-base 0]) + (when (<= l maxlen) + (vector-set! first-code l code) + (vector-set! first-sym l sym-base) + (loop (+ l 1) + (fxsll (+ code (vector-ref counts l)) 1) + (+ sym-base (vector-ref counts l))))) + ;; fill syms ordered by length then symbol + (let ([next (make-vector (+ maxlen 1) 0)]) + (do ([l 1 (+ l 1)]) ((> l maxlen)) + (vector-set! next l (vector-ref first-sym l))) + (do ([s 0 (+ s 1)]) ((= s (vector-length lengths))) + (let ([l (vector-ref lengths s)]) + (when (> l 0) + (vector-set! syms (vector-ref next l) s) + (vector-set! next l (+ 1 (vector-ref next l))))))) + (lambda () + (let loop ([l 1] [code (read-bit)]) + (when (> l maxlen) + (jpkg-error "gunzip: invalid huffman code")) + (let ([fc (vector-ref first-code l)] + [cnt (vector-ref counts l)]) + (if (and (> cnt 0) (< (- code fc) cnt) (>= code fc)) + (vector-ref syms (+ (vector-ref first-sym l) (- code fc))) + (loop (+ l 1) (fxior (fxsll code 1) (read-bit)))))))))) + (define len-base + '#(3 4 5 6 7 8 9 10 11 13 15 17 19 23 27 31 35 43 51 59 67 83 99 115 + 131 163 195 227 258)) + (define len-extra + '#(0 0 0 0 0 0 0 0 1 1 1 1 2 2 2 2 3 3 3 3 4 4 4 4 5 5 5 5 0)) + (define dist-base + '#(1 2 3 4 5 7 9 13 17 25 33 49 65 97 129 193 257 385 513 769 1025 + 1537 2049 3073 4097 6145 8193 12289 16385 24577)) + (define dist-extra + '#(0 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 10 10 11 11 12 12 13 13)) + (define (decode-block lit-dec dist-dec) + (let loop () + (let ([sym (lit-dec)]) + (cond + [(< sym 256) (emit! sym) (loop)] + [(= sym 256) (void)] + [(< sym 286) + (let* ([li (- sym 257)] + [len (+ (vector-ref len-base li) + (read-bits (vector-ref len-extra li)))] + [dsym (dist-dec)]) + (when (>= dsym 30) + (jpkg-error "gunzip: invalid distance symbol")) + (let ([dist (+ (vector-ref dist-base dsym) + (read-bits (vector-ref dist-extra dsym)))]) + (when (> dist out-len) + (jpkg-error "gunzip: distance beyond output")) + (ensure-out! len) + (do ([k 0 (+ k 1)]) ((= k len)) + (bytevector-u8-set! out out-len + (bytevector-u8-ref out (- out-len dist))) + (set! out-len (+ out-len 1))) + (loop)))] + [else (jpkg-error "gunzip: invalid literal/length symbol")])))) + (define fixed-lit-lengths + (let ([v (make-vector 288 0)]) + (do ([i 0 (+ i 1)]) ((= i 288) v) + (vector-set! v i (cond [(< i 144) 8] [(< i 256) 9] + [(< i 280) 7] [else 8]))))) + (define fixed-dist-lengths (make-vector 30 5)) + (let block-loop () + (let* ([final (read-bit)] + [btype (read-bits 2)]) + (case btype + [(0) ;; stored + (align-byte!) + (when (> (+ byte-pos 4) (bytevector-length bv)) + (jpkg-error "gunzip: truncated stored block")) + (let ([len (fxior (bytevector-u8-ref bv byte-pos) + (fxsll (bytevector-u8-ref bv (+ byte-pos 1)) 8))] + [nlen (fxior (bytevector-u8-ref bv (+ byte-pos 2)) + (fxsll (bytevector-u8-ref bv (+ byte-pos 3)) 8))]) + (unless (= (fxand (fxnot len) #xffff) nlen) + (jpkg-error "gunzip: stored block LEN/NLEN mismatch")) + (set! byte-pos (+ byte-pos 4)) + (when (> (+ byte-pos len) (bytevector-length bv)) + (jpkg-error "gunzip: truncated stored block data")) + (ensure-out! len) + (bytevector-copy! bv byte-pos out out-len len) + (set! out-len (+ out-len len)) + (set! byte-pos (+ byte-pos len)))] + [(1) ;; fixed huffman + (decode-block (build-decoder fixed-lit-lengths) + (build-decoder fixed-dist-lengths))] + [(2) ;; dynamic huffman + (let* ([hlit (+ 257 (read-bits 5))] + [hdist (+ 1 (read-bits 5))] + [hclen (+ 4 (read-bits 4))] + [clc-order '#(16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15)] + [clc-lengths (make-vector 19 0)]) + (do ([i 0 (+ i 1)]) ((= i hclen)) + (vector-set! clc-lengths (vector-ref clc-order i) (read-bits 3))) + (let* ([clc-dec (build-decoder clc-lengths)] + [all (make-vector (+ hlit hdist) 0)]) + (let fill ([i 0]) + (when (< i (+ hlit hdist)) + (let ([s (clc-dec)]) + (cond + [(< s 16) (vector-set! all i s) (fill (+ i 1))] + [(= s 16) + (when (= i 0) (jpkg-error "gunzip: repeat with no prior length")) + (let ([r (+ 3 (read-bits 2))] [prev (vector-ref all (- i 1))]) + (do ([k 0 (+ k 1)]) ((= k r)) (vector-set! all (+ i k) prev)) + (fill (+ i r)))] + [(= s 17) + (let ([r (+ 3 (read-bits 3))]) (fill (+ i r)))] + [(= s 18) + (let ([r (+ 11 (read-bits 7))]) (fill (+ i r)))] + [else (jpkg-error "gunzip: invalid code-length symbol")])))) + (let ([lit-lengths (make-vector hlit 0)] + [dist-lengths (make-vector hdist 0)]) + (do ([i 0 (+ i 1)]) ((= i hlit)) + (vector-set! lit-lengths i (vector-ref all i))) + (do ([i 0 (+ i 1)]) ((= i hdist)) + (vector-set! dist-lengths i (vector-ref all (+ hlit i)))) + (decode-block (build-decoder lit-lengths) + (build-decoder dist-lengths)))))] + [else (jpkg-error "gunzip: invalid block type 3")]) + (if (= final 1) + (begin + (align-byte!) + (let ([result (make-bytevector out-len)]) + (bytevector-copy! out 0 result 0 out-len) + (values result (- byte-pos start)))) + (block-loop)))))) + + ;; ── gzip reader ──────────────────────────────────────────────────────── + + (def (u32le bv i) + (bitwise-ior (bytevector-u8-ref bv i) + (bitwise-arithmetic-shift-left (bytevector-u8-ref bv (+ i 1)) 8) + (bitwise-arithmetic-shift-left (bytevector-u8-ref bv (+ i 2)) 16) + (bitwise-arithmetic-shift-left (bytevector-u8-ref bv (+ i 3)) 24))) + + ;; gunzip with hard expansion limit + CRC32 + ISIZE verification. + (def (gunzip-checked bv limit) + (let ([n (bytevector-length bv)]) + (when (< n 18) + (jpkg-error "gunzip: input too short to be gzip")) + (unless (and (= (bytevector-u8-ref bv 0) #x1f) + (= (bytevector-u8-ref bv 1) #x8b)) + (jpkg-error "gunzip: bad gzip magic")) + (unless (= (bytevector-u8-ref bv 2) 8) + (jpkg-error "gunzip: unsupported compression method")) + (let ([flg (bytevector-u8-ref bv 3)]) + (when (> (fxand flg #xe0) 0) + (jpkg-error "gunzip: reserved FLG bits set")) + (let* ([pos 10] + ;; FEXTRA + [pos (if (fxbit-set? flg 2) + (let ([xlen (fxior (bytevector-u8-ref bv pos) + (fxsll (bytevector-u8-ref bv (+ pos 1)) 8))]) + (+ pos 2 xlen)) + pos)] + ;; FNAME, FCOMMENT: NUL-terminated + [skip-z (lambda (p) + (let loop ([p p]) + (when (>= p n) (jpkg-error "gunzip: truncated header")) + (if (= (bytevector-u8-ref bv p) 0) (+ p 1) (loop (+ p 1)))))] + [pos (if (fxbit-set? flg 3) (skip-z pos) pos)] + [pos (if (fxbit-set? flg 4) (skip-z pos) pos)] + ;; FHCRC + [pos (if (fxbit-set? flg 1) (+ pos 2) pos)]) + (when (>= pos n) (jpkg-error "gunzip: truncated header")) + (let-values ([(data consumed) (inflate bv pos limit)]) + (let ([tpos (+ pos consumed)]) + (when (> (+ tpos 8) n) + (jpkg-error "gunzip: truncated trailer")) + (unless (= (u32le bv tpos) (crc32-of data)) + (jpkg-error "gunzip: CRC32 mismatch")) + (unless (= (u32le bv (+ tpos 4)) + (bitwise-and (bytevector-length data) #xffffffff)) + (jpkg-error "gunzip: ISIZE mismatch")) + (unless (= (+ tpos 8) n) + (jpkg-error "gunzip: trailing garbage after gzip stream")) + data)))))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/pkg/manifest.ss @@ -0,0 +1,475 @@ +#!chezscheme +;;; (std pkg manifest) — strict jpkg.sexp parser, validator, and canonical +;;; renderings (sexp text + canonical JSON for signing). +;;; +;;; The manifest is DATA, never code: it is read with a guarded reader +;;; that rejects anything but pairs, strings, symbols, exact integers, +;;; and booleans, with hard depth/node budgets (so datum labels, cycles, +;;; and reader bombs cannot reach validation). Unknown fields, duplicate +;;; fields, and malformed field shapes are errors, per docs/jpkg-plan.md. +;;; +;;; Manifest shape (all validated): +;;; (package +;;; (name "@scope/name") +;;; (version "0.1.0") +;;; (description "short text") +;;; (license "Apache-2.0") +;;; (source "https://host/path") +;;; (jerboa ">=0.1.0") +;;; (modules ((root "src") (exports ((name main))))) +;;; (dependencies (("@scope/dep" "^1.2.0"))) +;;; (dev-dependencies ()) +;;; (capabilities ((native-code reason: "why") ...))) + +(library (std pkg manifest) + (export manifest? make-manifest + manifest-name manifest-version manifest-description + manifest-license manifest-source manifest-jerboa-req + manifest-modules manifest-dependencies manifest-dev-dependencies + manifest-capabilities + parse-manifest-datum parse-manifest-string parse-manifest-file + valid-package-name? valid-relative-path? + manifest->sexp-text manifest->canonical-json + manifest-template) + + (import (chezscheme) + (only (jerboa core) def defstruct try catch) + (only (std pkg util) + jpkg-error string-split-char string-join-list + read-file-bytevector bytes->utf8-or-false) + (only (std pkg semver) semver-parse range-parse) + (only (std pkg canonical) canonical-json)) + + (defstruct manifest + (name version description license source jerboa-req + modules dependencies dev-dependencies capabilities)) + ;; modules: ((root . STRING) (exports . ((sym ...) ...))) or #f + ;; dependencies: ((name . range-string) ...) + ;; dev-dependencies: ((name . range-string) ...) + ;; capabilities: alist: (native-code . ((reason . STR))) + ;; (network . ((build . BOOL) (test . BOOL))) + ;; (ffi . ((libraries . (STR ...)))) + ;; (executables . (STR ...)) + + ;; ── guarded reading ──────────────────────────────────────────────────── + + (def max-manifest-bytes 65536) + (def max-depth 32) + (def max-nodes 10000) + + (def (check-data! x) + ;; verify x is plain acyclic data within budget; returns node count + (let ([nodes 0]) + (let walk ([x x] [depth 0]) + (set! nodes (+ nodes 1)) + (when (> nodes max-nodes) + (jpkg-error "manifest: too many nodes")) + (when (> depth max-depth) + (jpkg-error "manifest: nesting too deep")) + (cond + [(pair? x) (walk (car x) (+ depth 1)) (walk (cdr x) (+ depth 1))] + [(null? x) (void)] + [(string? x) + (when (> (string-length x) 4096) + (jpkg-error "manifest: string too long"))] + [(symbol? x) (void)] + [(and (integer? x) (exact? x)) (void)] + [(boolean? x) (void)] + [else (jpkg-error "manifest: disallowed datum ~s" x)])) + nodes)) + + (def (read-manifest-text text) + (when (> (string-length text) max-manifest-bytes) + (jpkg-error "manifest: file too large (max ~a bytes)" max-manifest-bytes)) + ;; Datum labels (#0=) can build cyclic or exponentially-shared data; + ;; check-data!'s node budget below converts both into hard errors, so + ;; no textual pre-scan is needed. + (let* ([port (open-string-input-port text)] + [datum (try (read port) + (catch (e) (jpkg-error "manifest: unreadable: ~a" + (if (message-condition? e) + (condition-message e) ""))))]) + (when (eof-object? datum) + (jpkg-error "manifest: empty file")) + (let ([extra (try (read port) (catch (e) (jpkg-error "manifest: trailing junk")))]) + (unless (eof-object? extra) + (jpkg-error "manifest: more than one top-level form"))) + (check-data! datum) + datum)) + + ;; ── name / path validation ───────────────────────────────────────────── + + (def (lower-alnum? c) (or (char<=? #\a c #\z) (char<=? #\0 c #\9))) + + (def (valid-segment? s allow-dot?) + ;; [a-z0-9][a-z0-9-]* with optional single dots between runs + (and (> (string-length s) 0) + (<= (string-length s) 64) + (lower-alnum? (string-ref s 0)) + (lower-alnum? (string-ref s (- (string-length s) 1))) + (let loop ([i 0] [prev-sep #f]) + (or (= i (string-length s)) + (let ([c (string-ref s i)]) + (cond + [(lower-alnum? c) (loop (+ i 1) #f)] + [(char=? c #\-) (and (not prev-sep) (loop (+ i 1) #t))] + [(and allow-dot? (char=? c #\.)) (and (not prev-sep) (loop (+ i 1) #t))] + [else #f])))))) + + (def (valid-package-name? s) + ;; @scope/name or @scope/collection.subpackage + (and (string? s) + (<= (string-length s) 128) + (> (string-length s) 3) + (char=? (string-ref s 0) #\@) + (let ([parts (string-split-char (substring s 1 (string-length s)) #\/)]) + (and (= (length parts) 2) + (valid-segment? (car parts) #f) + (valid-segment? (cadr parts) #t))))) + + (def (valid-relative-path? s) + ;; relative, normalized, no traversal, no weird characters + (and (string? s) + (> (string-length s) 0) + (<= (string-length s) 256) + (not (char=? (string-ref s 0) #\/)) + (let ([segs (string-split-char s #\/)]) + (for-all (lambda (seg) + (and (> (string-length seg) 0) + (not (string=? seg ".")) + (not (string=? seg "..")) + (let loop ([i 0]) + (or (= i (string-length seg)) + (let ([c (string-ref seg i)]) + (and (or (lower-alnum? c) + (char<=? #\A c #\Z) + (memv c '(#\- #\_ #\.))) + (loop (+ i 1)))))))) + segs)))) + + ;; ── field validators ───────────────────────────────────────────────────