jpkg phase 6: audit, advisories, search, package directories
ober
b2a23ac4e8564cbae1cf73da26eec9090be8303a
--- a/docs/jpkg-plan.md +++ b/docs/jpkg-plan.md @@ -608,7 +608,17 @@ Tracked per phase as implementation lands. Tests live in `tests/test-jpkg*.ss` never runs package code — building is the separate explicit step. 28 new tests: mode semantics, override loosen/tighten limits, capability-gating refusals, deterministic attestation. -- Phase 6 (audit, advisories, search): not started. +- Phase 6 (audit, advisories, search): DONE. OSV-shaped advisory parser + with SEMVER range + explicit-version + open-ended matching and a + warn/block-new/block-all policy action (`advisory.ss`); `jpkg audit` + checks the locked graph against registry advisories (TUF-verified when + present) and current yank status, exit 2 when a finding blocks installs + (`audit.ss`); `jpkg search` over a cross-registry index ranked by exact + name, TUF/provenance signals, and non-yanked recency, plus `jpkg dir + list|add|remove` managing the registry config file (`search.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. ## References new file mode 100644 --- /dev/null +++ b/lib/std/pkg/advisory.ss @@ -0,0 +1,200 @@ +#!chezscheme +;;; (std pkg advisory) — OSV-shaped vulnerability advisories. +;;; +;;; Advisories use the OSV schema subset jpkg needs (docs/jpkg-plan.md +;;; "Advisories And Yanking"): id, aliases, affected package + SEMVER +;;; ranges / explicit versions, severity, and a policy action +;;; warn | block-new | block-all +;;; carried in database_specific.jpkg_action. +;;; +;;; A version is AFFECTED by an `affected` entry when its package name +;;; matches and either it is listed in `versions`, or it falls in a +;;; SEMVER range: affected iff there is an `introduced` event with +;;; version >= introduced and no later `fixed`/`last_affected` excludes +;;; it (standard OSV range evaluation). + +(library (std pkg advisory) + (export advisory? parse-advisory parse-advisory-file + advisory-id advisory-aliases advisory-summary + advisory-action advisory-severity advisory-affected + advisory-affects? + advisory-fixed-versions + load-advisories-from-dir + advisories-for + advisory-action-rank action-blocks-new? action-blocks-all?) + + (import (chezscheme) + (only (jerboa core) def defstruct try catch) + (only (std pkg util) + jpkg-error read-file-bytevector bytes->utf8-or-false + string-suffix-of?) + (only (std pkg semver) semver-parse semver-try-parse semver-compare) + (only (std text json) string->json-object)) + + (defstruct advisory + (id aliases summary action severity affected)) + ;; affected: list of (("name" . STR) ("versions" . (STR...)) + ;; ("ranges" . (((introduced . V) (fixed . V|#f) + ;; (last . V|#f)) ...))) + + (def (oref h k d) (let ([v (hashtable-ref h k d)]) v)) + + (def (as-list x) (if (list? x) x '())) + + (def (parse-affected aff) + ;; aff: json hashtable for one affected entry + (let* ([pkg (oref aff "package" #f)] + [name (and (hashtable? pkg) (oref pkg "name" #f))] + [versions (filter string? (as-list (oref aff "versions" '())))] + [ranges + (apply append + (map + (lambda (r) + (unless (hashtable? r) (jpkg-error "advisory: bad range")) + (let ([type (oref r "type" "SEMVER")] + [events (as-list (oref r "events" '()))]) + (unless (string=? type "SEMVER") + (jpkg-error "advisory: only SEMVER ranges supported (got ~a)" type)) + ;; collect ordered (introduced/fixed/last_affected) events + (let loop ([events events] [introduced #f] [out '()]) + (cond + [(null? events) (reverse out)] + [else + (let ([e (car events)]) + (unless (hashtable? e) (jpkg-error "advisory: bad event")) + (cond + [(hashtable-ref e "introduced" #f) + => (lambda (v) + (loop (cdr events) v out))] + [(hashtable-ref e "fixed" #f) + => (lambda (v) + (loop (cdr events) #f + (cons (list (cons 'introduced (or introduced "0")) + (cons 'fixed v) + (cons 'last #f)) + out)))] + [(hashtable-ref e "last_affected" #f) + => (lambda (v) + (loop (cdr events) #f + (cons (list (cons 'introduced (or introduced "0")) + (cons 'fixed #f) + (cons 'last v)) + out)))] + [else (jpkg-error "advisory: unknown event")]))])))) + (as-list (oref aff "ranges" '()))))] + ;; an introduced with no terminating fixed/last is open-ended + [open-ranges + (let ([events (and (pair? (as-list (oref aff "ranges" '()))) + (let ([r (car (as-list (oref aff "ranges" '())))]) + (and (hashtable? r) (as-list (oref r "events" '())))))]) + (if (and events + (exists (lambda (e) (and (hashtable? e) + (hashtable-ref e "introduced" #f))) + events) + (not (exists (lambda (e) (and (hashtable? e) + (or (hashtable-ref e "fixed" #f) + (hashtable-ref e "last_affected" #f)))) + events))) + (let ([intro (let find ([es events]) + (cond [(null? es) "0"] + [(hashtable-ref (car es) "introduced" #f)] + [else (find (cdr es))]))]) + (list (list (cons 'introduced intro) (cons 'fixed #f) + (cons 'last #f)))) + '()))]) + (unless (string? name) (jpkg-error "advisory: affected entry missing package name")) + (list (cons "name" name) + (cons "versions" versions) + (cons "ranges" (append ranges open-ranges))))) + + (def (parse-advisory text) + (let* ([h (try (string->json-object text) + (catch (e) (jpkg-error "advisory: unparseable JSON")))] + [id (oref h "id" #f)]) + (unless (string? id) (jpkg-error "advisory: missing id")) + (let* ([aliases (filter string? (as-list (oref h "aliases" '())))] + [summary (let ([s (oref h "summary" "")]) (if (string? s) s ""))] + [affected (map parse-affected (as-list (oref h "affected" '())))] + [dbs (oref h "database_specific" #f)] + [action (let ([a (and (hashtable? dbs) + (oref dbs "jpkg_action" #f))]) + (cond [(not a) 'warn] + [(string=? a "warn") 'warn] + [(string=? a "block-new") 'block-new] + [(string=? a "block-all") 'block-all] + [else (jpkg-error "advisory: bad jpkg_action ~s" a)]))] + [severity (let ([sev (oref h "severity" #f)]) + (if (and (list? sev) (pair? sev) + (hashtable? (car sev))) + (let ([s (oref (car sev) "score" #f)]) + (if (string? s) s "unspecified")) + "unspecified"))]) + (make-advisory id aliases summary action severity affected)))) + + (def (parse-advisory-file path) + (parse-advisory + (or (bytes->utf8-or-false (read-file-bytevector path)) + (jpkg-error "advisory: file not UTF-8")))) + + ;; ── matching ─────────────────────────────────────────────────────────── + + (def (version-in-range? v range) + ;; v: parsed semver; range: ((introduced . S) (fixed . S|#f) (last . S|#f)) + (let* ([intro (semver-parse (cdr (assq 'introduced range)))] + [fixed (let ([f (cdr (assq 'fixed range))]) (and f (semver-parse f)))] + [last* (let ([l (cdr (assq 'last range))]) (and l (semver-parse l)))]) + (and (>= (semver-compare v intro) 0) + (or (not fixed) (< (semver-compare v fixed) 0)) + (or (not last*) (<= (semver-compare v last*) 0))))) + + (def (affected-matches? aff name version) + (and (string=? (cdr (assoc "name" aff)) name) + (let ([v (semver-try-parse version)]) + (and v + (or (member version (cdr (assoc "versions" aff))) + (exists (lambda (r) (version-in-range? v r)) + (cdr (assoc "ranges" aff)))))))) + + (def (advisory-affects? adv name version) + (and (exists (lambda (aff) (affected-matches? aff name version)) + (advisory-affected adv)) + #t)) + + (def (advisory-fixed-versions adv name) + ;; collect declared `fixed` versions for name (patched targets) + (let ([acc '()]) + (for-each + (lambda (aff) + (when (string=? (cdr (assoc "name" aff)) name) + (for-each (lambda (r) + (let ([f (cdr (assq 'fixed r))]) + (when (and f (not (member f acc))) + (set! acc (cons f acc))))) + (cdr (assoc "ranges" aff))))) + (advisory-affected adv)) + (list-sort (lambda (a b) (< (semver-compare (semver-parse a) + (semver-parse b)) 0)) + acc))) + + ;; ── loading + querying ───────────────────────────────────────────────── + + (def (load-advisories-from-dir dir) + (if (file-directory? dir) + (let ([files (list-sort string<? + (filter (lambda (f) (string-suffix-of? ".json" f)) + (directory-list dir)))]) + (map (lambda (f) (parse-advisory-file + (string-append dir "/" f))) + files)) + '())) + + (def (advisories-for advisories name version) + (filter (lambda (a) (advisory-affects? a name version)) advisories)) + + (def (advisory-action-rank action) + (case action [(warn) 0] [(block-new) 1] [(block-all) 2] [else 0])) + + (def (action-blocks-new? action) (>= (advisory-action-rank action) 1)) + (def (action-blocks-all? action) (>= (advisory-action-rank action) 2)) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/pkg/audit.ss @@ -0,0 +1,139 @@ +#!chezscheme +;;; (std pkg audit) — check the locked graph against advisories + yanks. +;;; +;;; `jpkg audit` reads jpkg.lock and, for every locked package, checks: +;;; - advisories: any OSV record affecting name@version, with its +;;; policy action (warn / block-new / block-all) +;;; - yank status: whether the registry now marks the version yanked +;;; (does NOT break reproducibility — only flags for new resolutions) +;;; +;;; Advisories come from the registry's TUF-verified advisories/ targets +;;; when available, else a client cache under $JERBOA_PKG_HOME/advisories. +;;; Returns a structured report; the command decides the exit code. + +(library (std pkg audit) + (export audit-project audit-report-findings audit-report-blocking? + finding-name finding-version finding-kind finding-detail + finding-action finding-fixed + load-registry-advisories) + + (import (chezscheme) + (only (jerboa core) def defstruct try catch) + (only (std pkg util) jpkg-error path-concat bytes->utf8-or-false + read-file-bytevector string-suffix-of?) + (only (std pkg lock) + lock-parse-file lock-file-name + locked-package-name locked-package-version + locked-package-registry locked-package-link) + (only (std pkg registry) + registry-config registry-lookup registry-release-for + release-info-yanked?) + (only (std pkg advisory) + parse-advisory advisories-for advisory-id advisory-action + 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)) + + (defstruct finding (name version kind detail action fixed)) + ;; kind: 'advisory | 'yanked ; action: advisory action or #f + + (defstruct audit-report (findings blocking?)) + + ;; ── advisory loading (TUF-verified when present) ─────────────────────── + + (def (load-registry-advisories reg-name reg-path) + ;; read advisories/*.json; TUF-verify each when the registry is TUF. + (let ([adv-dir (path-concat reg-path "advisories")]) + (cond + [(tuf-registry? reg-path) + ;; enumerate advisories/ from the filesystem but require each file + ;; to verify against signed targets (mirror can't inject records). + (if (file-directory? adv-dir) + (let ([targets (tuf-context reg-name reg-path)]) + (filter values + (map (lambda (f) + (let ([rel (string-append "advisories/" f)]) + (try + (parse-advisory + (or (bytes->utf8-or-false + (tuf-verified-target-bytes targets reg-path rel)) + (jpkg-error "audit: advisory not UTF-8"))) + (catch (e) #f)))) ;; unsigned/foreign file ignored + (filter (lambda (f) (string-suffix-of? ".json" f)) + (directory-list adv-dir))))) + '())] + [(file-directory? adv-dir) + (map (lambda (f) + (parse-advisory + (or (bytes->utf8-or-false + (read-file-bytevector (path-concat adv-dir f))) + (jpkg-error "audit: advisory not UTF-8")))) + (list-sort string<? + (filter (lambda (f) (string-suffix-of? ".json" f)) + (directory-list adv-dir))))] + [else '()]))) + + ;; ── audit ────────────────────────────────────────────────────────────── + + (def (audit-project) + (unless (file-exists? lock-file-name) + (jpkg-error "audit: no jpkg.lock (run jpkg install first)")) + (let* ([pkgs (lock-parse-file lock-file-name)] + [adv-cache '()] ;; reg-name -> advisory list + [advisories-of + (lambda (reg-name) + (cond + [(assoc reg-name adv-cache) => cdr] + [else + (let ([advs (guard (e [#t '()]) + (load-registry-advisories + reg-name (registry-lookup reg-name)))]) + (set! adv-cache (cons (cons reg-name advs) adv-cache)) + advs)]))] + [findings '()]) + (for-each + (lambda (p) + (unless (locked-package-link p) ;; local links are not audited + (let ([name (locked-package-name p)] + [version (locked-package-version p)] + [reg (locked-package-registry p)]) + ;; advisories + (let ([hits (advisories-for (advisories-of reg) name version)]) + (for-each + (lambda (a) + (set! findings + (cons (make-finding + name version 'advisory + (string-append (advisory-id a) ": " + (advisory-summary a) + " [severity " (advisory-severity a) "]") + (advisory-action a) + (advisory-fixed-versions a name)) + findings))) + hits)) + ;; yank status (current, from the registry) + (let ([yanked? + (guard (e [#t #f]) + (release-info-yanked? + (registry-release-for reg (registry-lookup reg) + name version)))]) + (when yanked? + (set! findings + (cons (make-finding name version 'yanked + "version is yanked (excluded from new resolutions)" + #f '()) + findings))))))) + pkgs) + (let ([fs (reverse findings)]) + (make-audit-report + fs + ;; blocking when any advisory action blocks installs + (and (exists (lambda (f) + (and (eq? (finding-kind f) 'advisory) + (or (action-blocks-new? (finding-action f)) + (action-blocks-all? (finding-action f))))) + fs) + #t))))) + + ) ;; end library --- a/lib/std/pkg/cli.ss +++ b/lib/std/pkg/cli.ss @@ -28,7 +28,8 @@ cmd-init cmd-new cmd-pack cmd-verify cmd-add cmd-remove cmd-install cmd-update cmd-uninstall cmd-link cmd-unlink cmd-list cmd-env cmd-publish - cmd-build cmd-clean cmd-policy)) + cmd-build cmd-clean cmd-policy + cmd-audit cmd-search cmd-dir)) (def jpkg-version "0.1.0") @@ -74,13 +75,13 @@ (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")) + "check advisories, yanks, policy drift" cmd-audit) (list "publish" "jpkg publish --registry DIR --key FILE" "sign, attest, and publish an artifact" cmd-publish) - (list "search" "jpkg search QUERY ..." - "search configured package directories" (stub "phase 6")) + (list "search" "jpkg search QUERY" + "search configured package directories" cmd-search) (list "dir" "jpkg dir add|remove|list" - "manage registry/package-directory list" (stub "phase 6")) + "manage registry/package-directory list" cmd-dir) (list "list" "jpkg list" "list installed packages" cmd-list) (list "env" "jpkg env -- COMMAND ..." --- a/lib/std/pkg/commands.ss +++ b/lib/std/pkg/commands.ss @@ -9,7 +9,8 @@ (export cmd-init cmd-new cmd-pack cmd-verify cmd-add cmd-remove cmd-install cmd-update cmd-uninstall cmd-link cmd-unlink cmd-list cmd-env cmd-publish - cmd-build cmd-clean cmd-policy) + cmd-build cmd-clean cmd-policy + cmd-audit cmd-search cmd-dir) (import (chezscheme) (only (jerboa core) def try catch) @@ -44,6 +45,15 @@ run-build build-result-ok? build-result-log build-result-attestation build-result-backend plan-build build-plan-degraded?) + (only (std pkg audit) + audit-project audit-report-findings audit-report-blocking? + finding-name finding-version finding-kind finding-detail + finding-action finding-fixed) + (only (std pkg search) + search-packages + 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 crypto random) random-bytes)) (def (say fmt . args) @@ -367,6 +377,78 @@ (def (yn b) (if b "yes" "no")) + ;; ── audit / search / dir (phase 6) ───────────────────────────────────── + + (def (cmd-audit args) + (unless (null? args) + (jpkg-error "usage: jpkg audit")) + (let* ([report (audit-project)] + [findings (audit-report-findings report)]) + (if (null? findings) + (begin (say "no advisories or yanks affect the locked graph") 0) + (begin + (for-each + (lambda (f) + (case (finding-kind f) + [(advisory) + (say "~a ~a ADVISORY [~a]" (finding-name f) (finding-version f) + (finding-action f)) + (say " ~a" (finding-detail f)) + (when (pair? (finding-fixed f)) + (say " fixed in: ~a" + (string-join-list (finding-fixed f) ", ")))] + [(yanked) + (say "~a ~a YANKED" (finding-name f) (finding-version f)) + (say " ~a" (finding-detail f))])) + findings) + (say "") + (say "~a finding~a (~a)" (length findings) + (if (= (length findings) 1) "" "s") + (if (audit-report-blocking? report) + "BLOCKING — installs of affected versions are refused by policy" + "advisory")) + ;; exit 2 when a finding blocks installs, 1 otherwise + (if (audit-report-blocking? report) 2 1))))) + + (def (cmd-search args) + (unless (and (pair? args) (null? (cdr args))) + (jpkg-error "usage: jpkg search QUERY")) + (let ([rows (search-packages (car args))]) + (if (null? rows) + (begin (say "no packages match ~s" (car args)) 0) + (begin + (for-each + (lambda (r) + (say "~a ~a [~a]~a~a~a" + (search-row-name r) (search-row-version r) + (search-row-registry r) + (if (search-row-tuf? r) " tuf" "") + (if (search-row-provenance? r) " provenance" "") + (if (search-row-yanked? r) " YANKED" ""))) + rows) + 0)))) + + (def (cmd-dir args) + (cond + [(or (null? args) (and (null? (cdr args)) (string=? (car args) "list"))) + (let* ([listed (dir-list)] + [src (car listed)] [entries (cdr listed)]) + (say "package directories (~a):" + (if (eq? src 'env) "from JERBOA_PKG_REGISTRIES" "from config file")) + (if (null? entries) + (say " (none configured)") + (for-each (lambda (e) (say " ~a -> ~a" (car e) (cdr e))) entries)) + 0)] + [(and (= (length args) 3) (string=? (car args) "add")) + (dir-add! (cadr args) (caddr args)) + (say "added registry ~a -> ~a" (cadr args) (caddr args)) + 0] + [(and (= (length args) 2) (string=? (car args) "remove")) + (dir-remove! (cadr args)) + (say "removed registry ~a" (cadr args)) + 0] + [else (jpkg-error "usage: jpkg dir [list | add NAME PATH | remove NAME]")])) + (def (cmd-env args) ;; jpkg env -> print the env paths ;; jpkg env -- CMD ... -> run CMD with JERBOA_PKG_PATH set new file mode 100644 --- /dev/null +++ b/lib/std/pkg/search.ss @@ -0,0 +1,207 @@ +#!chezscheme +;;; (std pkg search) — package search across configured directories, and +;;; package-directory (registry list) management. +;;; +;;; Search builds an index from each configured registry's signed targets +;;; (TUF) or directory listing (plain), one row per package: +;;; name, latest non-yanked version, description, yanked?, provenance?, +;;; jerboa-req, registry. +;;; +;;; Ranking (docs/jpkg-plan.md "Search And Package Directories") prefers +;;; exact name, then verified (TUF) registries, then provenance presence, +;;; then recent maintained non-yanked versions. Security signals are +;;; surfaced but never presented as absolute safety. +;;; +;;; Package directories are the configured registries; `jpkg dir` edits +;;; $JERBOA_PKG_HOME/registries/config.sexp. + +(library (std pkg search) + (export search-index search-packages + search-row? search-row-name search-row-version + search-row-registry search-row-description + search-row-yanked? search-row-provenance? search-row-tuf? + dir-list dir-add! dir-remove!) + + (import (chezscheme) + (only (jerboa core) def defstruct try catch) + (only (std pkg util) + jpkg-error mkdir-p path-concat + read-file-bytevector write-file-bytevector + bytes->utf8-or-false) + (only (std pkg semver) semver-try-parse semver-compare semver-prerelease) + (only (std pkg registry) + registry-config registry-versions-for registry-release-for + release-info-yanked? release-info-dependencies) + (only (std pkg tuf) tuf-registry?)) + + (defstruct search-row + (name version registry description yanked? provenance? tuf? score)) + + ;; ── index ────────────────────────────────────────────────────────────── + + (def (jpkg-home*) + (or (getenv "JERBOA_PKG_HOME") + (let ([home (or (getenv "HOME") (jpkg-error "search: HOME not set"))]) + (path-concat home ".jerboa/pkg")))) + + (def (latest-non-prerelease versions) + (let ([parsed (filter (lambda (p) (and (cdr p) + (null? (semver-prerelease (cdr p))))) + (map (lambda (v) (cons v (semver-try-parse v))) versions))]) + (and (pair? parsed) + (car (fold-left (lambda (acc p) + (if (> (semver-compare (cdr p) (cdr acc)) 0) p acc)) + (car parsed) (cdr parsed)))))) + + (def (package-names reg-path) + ;; enumerate @scope/name from the packages/ tree (search is a + ;; convenience listing; install still goes through verified metadata) + (let ([pkgs-dir (path-concat reg-path "packages")] + [acc '()]) + (when (file-directory? pkgs-dir) + (for-each + (lambda (scope) + (when (and (> (string-length scope) 0) + (char=? (string-ref scope 0) #\@)) + (let ([scope-dir (path-concat pkgs-dir scope)]) + (when (file-directory? scope-dir) + (for-each + (lambda (pkg) + (set! acc (cons (string-append scope "/" pkg) acc))) + (directory-list scope-dir)))))) + (directory-list pkgs-dir))) + (list-sort string<? acc))) + + (def (provenance-present? reg-path name version) + (file-exists? + (path-concat reg-path + (string-append "packages/" name "/" version "/provenance.json")))) + + (def (search-index) + ;; one row per package across all configured registries + (let ([rows '()]) + (for-each + (lambda (cfg) + (let ([reg-name (car cfg)] [reg-path (cdr cfg)]) + (let ([tuf? (tuf-registry? reg-path)]) + (for-each + (lambda (name) + (let* ([versions (guard (e [#t '()]) + (registry-versions-for reg-name reg-path name))] + [latest (latest-non-prerelease versions)]) + (when latest + (let ([yanked? + (guard (e [#t #f]) + (release-info-yanked? + (registry-release-for reg-name reg-path name latest)))]) + (set! rows + (cons (make-search-row + name latest reg-name "" + yanked? + (provenance-present? reg-path name latest) + tuf? 0) + rows)))))) + (package-names reg-path))))) + (registry-config)) + (reverse rows))) + + ;; ── ranking + query ──────────────────────────────────────────────────── + + (def (string-contains-ci? hay needle) + (let ([h (string-downcase hay)] [n (string-downcase needle)]) + (let ([hl (string-length h)] [nl (string-length n)]) + (let loop ([i 0]) + (cond [(> (+ i nl) hl) #f] + [(string=? (substring h i (+ i nl)) n) #t] + [else (loop (+ i 1))]))))) + + (def (score-row row query) + (let ([s 0]) + (when (string=? (search-row-name row) query) (set! s (+ s 1000))) + (when (string-contains-ci? (search-row-name row) query) (set! s (+ s 100))) + (when (search-row-tuf? row) (set! s (+ s 30))) + (when (search-row-provenance? row) (set! s (+ s 20))) + (when (search-row-yanked? row) (set! s (- s 200))) + s)) + + (def (search-packages query) + ;; returns rows matching query, ranked desc, ties broken by name + (let* ([all (search-index)] + [matched (filter (lambda (r) + (string-contains-ci? (search-row-name r) query)) + all)] + [scored (map (lambda (r) + (make-search-row + (search-row-name r) (search-row-version r) + (search-row-registry r) (search-row-description r) + (search-row-yanked? r) (search-row-provenance? r) + (search-row-tuf? r) (score-row r query))) + matched)]) + (list-sort + (lambda (a b) + (if (= (search-row-score a) (search-row-score b)) + (string<? (search-row-name a) (search-row-name b)) + (> (search-row-score a) (search-row-score b)))) + scored))) + + ;; ── package directory (registry list) management ─────────────────────── + + (def (config-path) (path-concat (jpkg-home*) "registries/config.sexp")) + + (def (read-config) + ;; -> ((name . path) ...) + (let ([p (config-path)]) + (if (file-exists? p) + (let* ([text (or (bytes->utf8-or-false (read-file-bytevector p)) + (jpkg-error "dir: config not UTF-8"))] + [datum (with-input-from-string text read)]) + (if (and (pair? datum) (eq? (car datum) 'registries)) + (map (lambda (e) (cons (car e) (cadr e))) (cdr datum)) + '())) + '()))) + + (def (write-config! entries) + (mkdir-p (path-concat (jpkg-home*) "registries")) + (write-file-bytevector + (config-path) + (string->utf8 + (call-with-string-output-port + (lambda (out) + (display "(registries\n" out) + (for-each (lambda (e) + (display " (" out) (write (car e) out) + (display " " out) (write (cdr e) out) + (display ")\n" out)) + entries) + (display ")\n" out)))))) + + (def (dir-list) + ;; env override shadows the file (read-only) — report both honestly + (let ([env (getenv "JERBOA_PKG_REGISTRIES")]) + (if (and env (> (string-length env) 0)) + (cons 'env (registry-config)) + (cons 'file (read-config))))) + + (def (env-registries-set?) + (let ([e (getenv "JERBOA_PKG_REGISTRIES")]) + (and e (> (string-length e) 0)))) + + (def (dir-add! name path) + (when (env-registries-set?) + (jpkg-error "dir: JERBOA_PKG_REGISTRIES is set; unset it to edit the config file")) + (let ([entries (read-config)]) + (when (assoc name entries) + (jpkg-error "dir: registry ~s already configured" name)) + (write-config! (append entries (list (cons name path)))) + (void))) + + (def (dir-remove! name) + (when (env-registries-set?) + (jpkg-error "dir: JERBOA_PKG_REGISTRIES is set; unset it to edit the config file")) + (let ([entries (read-config)]) + (unless (assoc name entries) + (jpkg-error "dir: registry ~s is not configured" name)) + (write-config! (filter (lambda (e) (not (string=? (car e) name))) entries)) + (void))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/tests/test-jpkg-audit.ss @@ -0,0 +1,182 @@ +#!chezscheme +;;; tests/test-jpkg-audit.ss — phase 6: OSV advisory matching, jpkg audit +;;; against the lock, yank reporting, search ranking, and dir management. + +(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)) + +(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 (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 audit tests ---~%") + +;; ── OSV advisory matching ─────────────────────────────────────────────── + +(define adv-range + (parse-advisory + "{\"id\":\"JERBOA-2026-1\",\"aliases\":[\"CVE-2026-9\"],\"summary\":\"rce\",\"affected\":[{\"package\":{\"name\":\"@v/lib\"},\"ranges\":[{\"type\":\"SEMVER\",\"events\":[{\"introduced\":\"1.0.0\"},{\"fixed\":\"1.4.2\"}]}]}],\"severity\":[{\"type\":\"CVSS_V3\",\"score\":\"9.8\"}],\"database_specific\":{\"jpkg_action\":\"block-new\"}}")) + +(check "advisory-id" (string=? (advisory-id adv-range) "JERBOA-2026-1")) +(check "advisory-action" (eq? (advisory-action adv-range) 'block-new)) +(check "advisory-severity" (string=? (advisory-severity adv-range) "9.8")) +(check "range-lower-bound" (advisory-affects? adv-range "@v/lib" "1.0.0")) +(check "range-mid" (advisory-affects? adv-range "@v/lib" "1.4.1")) +(check "range-fixed-excluded" (not (advisory-affects? adv-range "@v/lib" "1.4.2"))) +(check "range-below-excluded" (not (advisory-affects? adv-range "@v/lib" "0.9.0"))) +(check "range-other-pkg" (not (advisory-affects? adv-range "@v/other" "1.1.0"))) +(check "fixed-versions" (equal? (advisory-fixed-versions adv-range "@v/lib") '("1.4.2"))) + +(define adv-versions + (parse-advisory + "{\"id\":\"J2\",\"affected\":[{\"package\":{\"name\":\"@v/p\"},\"versions\":[\"1.0.0\",\"1.0.1\"]}]}")) +(check "explicit-version-match" (advisory-affects? adv-versions "@v/p" "1.0.1")) +(check "explicit-version-nomatch" (not (advisory-affects? adv-versions "@v/p" "1.0.2"))) +(check "default-action-warn" (eq? (advisory-action adv-versions) 'warn)) + +(define adv-open + (parse-advisory + "{\"id\":\"J3\",\"affected\":[{\"package\":{\"name\":\"@v/q\"},\"ranges\":[{\"type\":\"SEMVER\",\"events\":[{\"introduced\":\"2.0.0\"}]}]}],\"database_specific\":{\"jpkg_action\":\"block-all\"}}")) +(check "open-range-affects" (advisory-affects? adv-open "@v/q" "5.0.0")) +(check "open-range-below" (not (advisory-affects? adv-open "@v/q" "1.9.0"))) +(check "block-all-action" (eq? (advisory-action adv-open) 'block-all)) + +(check "advisories-for-filters" + (= 1 (length (advisories-for (list adv-range adv-versions adv-open) + "@v/lib" "1.2.0")))) + +;; ── audit against a lock ──────────────────────────────────────────────── + +(define world (format "/tmp/jpkg-audit-~a" (random-suffix))) +(define reg (path-concat world "reg")) +(define proj (path-concat world "app")) +(define orig (current-directory)) +(mkdir-p world) +(putenv "JERBOA_PKG_HOME" (path-concat world "home")) +(putenv "JERBOA_PKG_REGISTRIES" (format "main=~a" reg)) + +(define (publish! name version) + (let ([d (path-concat world (format "s-~a" (random-suffix)))]) + (mkdir-p (path-concat d "src")) + (write-file-bytevector (path-concat d "jpkg.sexp") + (string->utf8 (format "(package (name ~s) (version ~s) (modules ((root \"src\"))))" name version))) + (write-file-bytevector (path-concat d "src/l.ss") (string->utf8 ";")) + (let-values ([(p dg s) (pack-project d (path-concat d ".jpkg"))]) + (registry-add-package! reg p) (delete-file p)))) + +(registry-generate-skeleton reg) +(publish! "@v/lib" "1.2.0") ;; vulnerable per adv-range +(publish! "@v/safe" "2.0.0") + +;; write an advisory into the (plain) registry +(mkdir-p (path-concat reg "advisories")) +(write-file-bytevector + (path-concat reg "advisories/JERBOA-2026-1.json") + (string->utf8 + "{\"id\":\"JERBOA-2026-1\",\"summary\":\"rce in @v/lib\",\"affected\":[{\"package\":{\"name\":\"@v/lib\"},\"ranges\":[{\"type\":\"SEMVER\",\"events\":[{\"introduced\":\"1.0.0\"},{\"fixed\":\"1.4.2\"}]}]}],\"severity\":[{\"type\":\"CVSS_V3\",\"score\":\"9.8\"}],\"database_specific\":{\"jpkg_action\":\"block-new\"}}")) + +(define (run-jpkg args) + (let-values ([(op og) (open-string-output-port)] + [(ep eg) (open-string-output-port)]) + (let ([code (parameterize ([current-output-port op] + [current-error-port ep]) + (jpkg-main args))]) + (list code (og) (eg))))) + +;; build a project that depends on both +(mkdir-p proj) +(current-directory proj) +(run-jpkg '("init" "@v/app")) +(run-jpkg '("add" "@v/lib")) +(run-jpkg '("add" "@v/safe")) + +(check "audit-flags-vulnerable" + (let ([r (run-jpkg '("audit"))]) + (and (= (car r) 2) ;; block-new => blocking => exit 2 + (s-contains? (cadr r) "JERBOA-2026-1") + (s-contains? (cadr r) "@v/lib") + (s-contains? (cadr r) "fixed in: 1.4.2") + (s-contains? (cadr r) "BLOCKING")))) + +(check "audit-clean-after-advisory-removed" + (begin + (delete-file (path-concat reg "advisories/JERBOA-2026-1.json")) + (let ([r (run-jpkg '("audit"))]) + (and (= (car r) 0) + (s-contains? (cadr r) "no advisories"))))) + +;; yank reporting +(check "audit-reports-yank" + (begin + (registry-yank! reg "@v/lib" "1.2.0") + (let ([r (run-jpkg '("audit"))]) + (and (s-contains? (cadr r) "YANKED") + (s-contains? (cadr r) "@v/lib"))))) + +;; ── search ─────────────────────────────────────────────────────────────── + +(check "search-finds-package" + (let ([r (run-jpkg '("search" "lib"))]) + (and (= (car r) 0) + (s-contains? (cadr r) "@v/lib")))) + +(check "search-exact-name-ranks-first" + (begin + (publish! "@v/liblong" "1.0.0") + (let ([rows (search-packages "@v/lib")]) + (and (pair? rows) + (string=? (search-row-name (car rows)) "@v/lib"))))) + +(check "search-shows-yanked-flag" + (let ([r (run-jpkg '("search" "@v/lib"))]) + (s-contains? (cadr r) "YANKED"))) + +(check "search-no-match" + (let ([r (run-jpkg '("search" "nonexistent-xyz"))]) + (and (= (car r) 0) (s-contains? (cadr r) "no packages match")))) + +;; ── dir management ─────────────────────────────────────────────────────── + +(check "dir-list-from-env" + (let ([r (run-jpkg '("dir" "list"))]) + (and (= (car r) 0) + (s-contains? (cadr r) "JERBOA_PKG_REGISTRIES") + (s-contains? (cadr r) "main")))) + +(check "dir-add-blocked-when-env-set" + (let ([r (run-jpkg (list "dir" "add" "extra" "/tmp/x"))]) + (= (car r) 1))) ;; env is set; refuses to edit file + +(check "dir-add-and-remove-file" + (begin + (putenv "JERBOA_PKG_REGISTRIES" "") + (let* ([r1 (run-jpkg (list "dir" "add" "local" (path-concat world "r2")))] + [r2 (run-jpkg '("dir" "list"))] + [r3 (run-jpkg '("dir" "remove" "local"))]) + (putenv "JERBOA_PKG_REGISTRIES" (format "main=~a" reg)) + (and (= (car r1) 0) + (s-contains? (cadr r2) "local") + (= (car r3) 0))))) + +(current-directory orig) +(remove-tree world) + +(printf "~%--- jpkg audit: ~a passed, ~a failed ---~%" pass fail) +(when (> fail 0) (exit 1)) --- a/tests/test-jpkg-cli.ss +++ b/tests/test-jpkg-cli.ss @@ -86,18 +86,13 @@ (check "unknown-exit-2" (= (car r) 2)) (check "unknown-message" (s-contains? (caddr r) "unknown command: frobnicate"))) -;; commands not yet implemented return 3 and say so on stderr. -;; Shrink this list as phases land. -(define *expected-stubs* - '("audit" "search" "dir")) - +;; every command is implemented now — none should report the stub message (for-each (lambda (cmd) (let ([r (call-capturing (list cmd))]) - (check (string-append "stub-" cmd "-exit-3") (= (car r) 3)) - (check (string-append "stub-" cmd "-message") - (s-contains? (caddr r) "not implemented yet")))) - *expected-stubs*) + (check (string-append "no-stub-" cmd) + (not (s-contains? (caddr r) "not implemented yet"))))) + (jpkg-command-names)) (printf "~%--- jpkg cli: ~a passed, ~a failed ---~%" pass fail) (when (> fail 0) (exit 1))