jpkg phase 2: lockfile, resolver, project environments
ober
af24a6327faeffc87614dcce8c2bbe5086ccdc56
--- a/docs/jpkg-plan.md +++ b/docs/jpkg-plan.md @@ -554,7 +554,18 @@ Tracked per phase as implementation lands. Tests live in `tests/test-jpkg*.ss` (`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 2 (lockfile and resolver): DONE. Deterministic backtracking + resolver with chained conflict explanations, yank exclusion (exact pins + excepted), no implicit pre-releases (`resolve.ss`); strict jpkg.lock + with sorted deterministic rendering and link entries flagged + non-reproducible (`lock.ss`); static local registry layout + (`packages/@scope/name/VER/release.json`, `blobs/sha256/`) + generator + used by tests and later publish (`registry.ss`); project environments + as symlink views over the store (`.jpkg/deps/*` -> + `$JERBOA_PKG_HOME/src/<digest>`), exact-lock `install`, registry + 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 4 (signing and provenance): not started. - Phase 5 (sandbox builds): not started. --- a/lib/std/pkg/cli.ss +++ b/lib/std/pkg/cli.ss @@ -24,7 +24,10 @@ (import (chezscheme) (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)) + (only (std pkg commands) + 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)) (def jpkg-version "0.1.0") @@ -48,19 +51,19 @@ (list "new" "jpkg new NAME" "create a new package template" cmd-new) (list "add" "jpkg add PKG[@VERSION]" - "add dependency and update lockfile" (stub "phase 2")) + "add dependency and update lockfile" cmd-add) (list "remove" "jpkg remove PKG" - "remove dependency and update lockfile" (stub "phase 2")) + "remove dependency and update lockfile" cmd-remove) (list "install" "jpkg install" - "install exactly what jpkg.lock describes" (stub "phase 2")) + "install exactly what jpkg.lock describes" cmd-install) (list "update" "jpkg update [PKG ...]" - "resolve newer allowed versions" (stub "phase 2")) + "resolve newer allowed versions" cmd-update) (list "uninstall" "jpkg uninstall PKG" - "remove from the project environment" (stub "phase 2")) + "remove from the project environment" cmd-uninstall) (list "link" "jpkg link PKG PATH" - "link a local development checkout" (stub "phase 2")) + "link a local development checkout" cmd-link) (list "unlink" "jpkg unlink PKG" - "remove local development link" (stub "phase 2")) + "remove local development link" cmd-unlink) (list "build" "jpkg build [PKG ...]" "build under policy-controlled sandbox" (stub "phase 5")) (list "clean" "jpkg clean [PKG ...]" @@ -78,9 +81,9 @@ (list "dir" "jpkg dir add|remove|list" "manage registry/package-directory list" (stub "phase 6")) (list "list" "jpkg list" - "list installed packages" (stub "phase 2")) + "list installed packages" cmd-list) (list "env" "jpkg env -- COMMAND ..." - "run command with package environment" (stub "phase 2")) + "run command with package environment" cmd-env) (list "policy" "jpkg policy" "inspect or explain active policy" (stub "phase 5")))) --- a/lib/std/pkg/commands.ss +++ b/lib/std/pkg/commands.ss @@ -6,13 +6,15 @@ ;;; Phase 1: init, new, pack, verify. (library (std pkg commands) - (export cmd-init cmd-new cmd-pack cmd-verify) + (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) (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?) + write-file-bytevector string-suffix-of? string-join-list) (only (std pkg manifest) manifest-template parse-manifest-file manifest-name manifest-version valid-package-name?) @@ -20,7 +22,14 @@ 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?)) + (only (std pkg tarball) tar-entry-dir?) + (only (std pkg lock) + locked-package-name locked-package-version + locked-package-registry locked-package-link) + (only (std pkg project) + project-add project-remove project-install project-update + project-uninstall project-list project-env-paths + project-link project-unlink project-verify-lock)) (def (say fmt . args) (let ([p (current-output-port)]) @@ -131,12 +140,29 @@ ;; ── verify ───────────────────────────────────────────────────────────── + (def (verify-lock-report strict?) + (when (file-exists? "jpkg.lock") + (for-each + (lambda (entry) + (case (cadr entry) + [(ok) (say "ok: ~a artifact verified in store" (car entry))] + [(missing) (say "note: ~a not in local store (run jpkg install)" (car entry))] + [(linked) (say "note: ~a is a local link (non-reproducible)" (car entry))])) + (project-verify-lock strict?)))) + (def (cmd-verify args) (cond - ;; no args: verify the project manifest + ;; no args: verify the project manifest (+ lock if present) [(null? args) (let ([m (parse-manifest-file "jpkg.sexp")]) (say "ok: jpkg.sexp valid (~a ~a)" (manifest-name m) (manifest-version m)) + (verify-lock-report #f) + 0)] + ;; --strict: also fail on local links + [(and (null? (cdr args)) (string=? (car args) "--strict")) + (let ([m (parse-manifest-file "jpkg.sexp")]) + (say "ok: jpkg.sexp valid (~a ~a)" (manifest-name m) (manifest-version m)) + (verify-lock-report #t) 0)] ;; verify an artifact file [(and (null? (cdr args)) (string-suffix-of? ".jpkg" (car args))) @@ -150,6 +176,112 @@ (say " size: ~a bytes" (artifact-info-size info)) (say " files: ~a" (length files)) 0)] - [else (jpkg-error "usage: jpkg verify [FILE.jpkg]")])) + [else (jpkg-error "usage: jpkg verify [--strict | FILE.jpkg]")])) + + ;; ── phase 2: dependency + environment commands ───────────────────────── + + (def (say-packages pkgs) + (for-each + (lambda (p) + (if (locked-package-link p) + (say " ~a -> ~a (linked)" (locked-package-name p) + (locked-package-link p)) + (say " ~a ~a (~a)" (locked-package-name p) + (locked-package-version p) (locked-package-registry p)))) + pkgs)) + + (def (cmd-add args) + (unless (and (pair? args) (null? (cdr args))) + (jpkg-error "usage: jpkg add PKG[@VERSION]")) + (let ([pkgs (project-add (car args))]) + (say "resolved ~a package~a:" (length pkgs) + (if (= (length pkgs) 1) "" "s")) + (say-packages pkgs) + 0)) + + (def (cmd-remove args) + (unless (and (pair? args) (null? (cdr args))) + (jpkg-error "usage: jpkg remove PKG")) + (let ([pkgs (project-remove (car args))]) + (say "removed ~a; ~a package~a remain" (car args) (length pkgs) + (if (= (length pkgs) 1) "" "s")) + 0)) + + (def (cmd-install args) + (unless (null? args) + (jpkg-error "usage: jpkg install (installs exactly jpkg.lock)")) + (let ([pkgs (project-install)]) + (say "installed ~a package~a from jpkg.lock" (length pkgs) + (if (= (length pkgs) 1) "" "s")) + (say-packages pkgs) + 0)) + + (def (cmd-update args) + (let ([pkgs (project-update args)]) + (say "resolved ~a package~a:" (length pkgs) + (if (= (length pkgs) 1) "" "s")) + (say-packages pkgs) + 0)) + + (def (cmd-uninstall args) + (unless (and (pair? args) (null? (cdr args))) + (jpkg-error "usage: jpkg uninstall PKG")) + (project-uninstall (car args)) + (say "uninstalled ~a from the project environment" (car args)) + 0) + + (def (cmd-link args) + (unless (and (pair? args) (pair? (cdr args)) (null? (cddr args))) + (jpkg-error "usage: jpkg link PKG PATH")) + (project-link (car args) (cadr args)) + (say "linked ~a -> ~a (recorded in jpkg.lock as non-reproducible)" + (car args) (cadr args)) + 0) + + (def (cmd-unlink args) + (unless (and (pair? args) (null? (cdr args))) + (jpkg-error "usage: jpkg unlink PKG")) + (project-unlink (car args)) + (say "unlinked ~a" (car args)) + 0) + + (def (cmd-list args) + (unless (null? args) + (jpkg-error "usage: jpkg list")) + (let ([pkgs (project-list)]) + (if (null? pkgs) + (say "no packages locked (jpkg.lock absent or empty)") + (say-packages pkgs)) + 0)) + + (def (cmd-env args) + ;; jpkg env -> print the env paths + ;; jpkg env -- CMD ... -> run CMD with JERBOA_PKG_PATH set + (cond + [(null? args) + (for-each (lambda (p) (say "~a" p)) (project-env-paths)) + 0] + [(string=? (car args) "--") + (when (null? (cdr args)) + (jpkg-error "usage: jpkg env -- COMMAND [ARGS ...]")) + (let* ([paths (project-env-paths)] + [joined (string-join-list paths ":")] + [quoted (map (lambda (a) + (string-append + "'" + (apply string-append + (map (lambda (c) + (if (char=? c #\') + "'\"'\"'" + (string c))) + (string->list a))) + "'")) + (cdr args))] + [old (getenv "JERBOA_PKG_PATH")]) + (putenv "JERBOA_PKG_PATH" joined) + (let ([rc (system (string-join-list quoted " "))]) + (when old (putenv "JERBOA_PKG_PATH" old)) + (if (= rc 0) 0 1)))] + [else (jpkg-error "usage: jpkg env [-- COMMAND ...]")])) ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/pkg/lock.ss @@ -0,0 +1,217 @@ +#!chezscheme +;;; (std pkg lock) — jpkg.lock: the project security boundary. +;;; +;;; Records the exact resolved graph; `jpkg install` materializes exactly +;;; this and nothing else. Sexp data with the same guarded-reader rules +;;; as the manifest. Rendering is deterministic (entries sorted by name). +;;; +;;; (lock +;;; (version 1) +;;; (packages +;;; ((name "@scope/dep") +;;; (version "1.2.3") +;;; (registry "local") +;;; (artifact-sha256 "...") +;;; (artifact-size 1234) +;;; (manifest-sha256 "...") +;;; (dependencies (("@scope/x" "^1.0.0"))) +;;; (yanked #f) +;;; (link "PATH")))) ; local dev override only (dev mode) + +(library (std pkg lock) + (export locked-package? make-locked-package + locked-package-name locked-package-version locked-package-registry + locked-package-artifact-sha256 locked-package-artifact-size + locked-package-manifest-sha256 locked-package-dependencies + locked-package-yanked? locked-package-link + lock-render lock-parse-string lock-parse-file lock-write-file + lock-file-name) + + (import (chezscheme) + (only (jerboa core) def defstruct try catch) + (only (std pkg util) + jpkg-error read-file-bytevector write-file-bytevector + bytes->utf8-or-false string-join-list) + (only (std pkg manifest) valid-package-name?) + (only (std pkg semver) semver-parse range-parse) + (only (std pkg store) valid-digest?)) + + (def lock-file-name "jpkg.lock") + (def lock-format-version 1) + + (defstruct locked-package + (name version registry artifact-sha256 artifact-size manifest-sha256 + dependencies yanked? link)) + ;; link: #f, or a local path string for dev-mode overrides; linked + ;; packages have #f digests and are non-reproducible by definition. + + ;; ── guarded reading (same discipline as manifests) ───────────────────── + + (def max-lock-bytes (* 4 1024 1024)) + (def max-nodes 200000) + (def max-depth 32) + + (def (check-data! x) + (let ([nodes 0]) + (let walk ([x x] [depth 0]) + (set! nodes (+ nodes 1)) + (when (> nodes max-nodes) (jpkg-error "lock: too many nodes")) + (when (> depth max-depth) (jpkg-error "lock: 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 "lock: string too long"))] + [(symbol? x) (void)] + [(and (integer? x) (exact? x)) (void)] + [(boolean? x) (void)] + [else (jpkg-error "lock: disallowed datum ~s" x)])))) + + ;; ── parsing ──────────────────────────────────────────────────────────── + + (def (field-of clauses key required? what) + (let ([hits (filter (lambda (c) (and (pair? c) (eq? (car c) key))) clauses)]) + (cond + [(null? hits) + (if required? (jpkg-error "lock: package missing ~a" what) #f)] + [(pair? (cdr hits)) (jpkg-error "lock: duplicate package field ~a" what)] + [else + (let ([c (car hits)]) + (unless (= (length c) 2) + (jpkg-error "lock: bad package field ~a" what)) + (cadr c))]))) + + (def (parse-locked-package clauses) + (unless (list? clauses) (jpkg-error "lock: bad package entry")) + (for-each + (lambda (c) + (unless (and (pair? c) + (memq (car c) '(name version registry artifact-sha256 + artifact-size manifest-sha256 + dependencies yanked link))) + (jpkg-error "lock: unknown package field ~s" c))) + clauses) + (let* ([name (field-of clauses 'name #t "name")] + [version (field-of clauses 'version #t "version")] + [registry (field-of clauses 'registry #t "registry")] + [link (field-of clauses 'link #f "link")] + [asha (field-of clauses 'artifact-sha256 (not link) "artifact-sha256")] + [asize (field-of clauses 'artifact-size (not link) "artifact-size")] + [msha (field-of clauses 'manifest-sha256 (not link) "manifest-sha256")] + [deps (or (field-of clauses 'dependencies #f "dependencies") '())] + [yanked (or (field-of clauses 'yanked #f "yanked") #f)]) + (unless (valid-package-name? name) + (jpkg-error "lock: invalid package name ~s" name)) + (semver-parse version) + (unless (and (string? registry) (> (string-length registry) 0)) + (jpkg-error "lock: bad registry for ~a" name)) + (when link + (unless (and (string? link) (> (string-length link) 0)) + (jpkg-error "lock: bad link path for ~a" name))) + (unless link + (unless (valid-digest? asha) + (jpkg-error "lock: bad artifact-sha256 for ~a" name)) + (unless (and (integer? asize) (exact? asize) (>= asize 0)) + (jpkg-error "lock: bad artifact-size for ~a" name)) + (unless (valid-digest? msha) + (jpkg-error "lock: bad manifest-sha256 for ~a" name))) + (unless (list? deps) (jpkg-error "lock: bad dependencies for ~a" name)) + (unless (boolean? yanked) (jpkg-error "lock: bad yanked for ~a" name)) + (make-locked-package + name version registry + (and (not link) asha) + (and (not link) asize) + (and (not link) msha) + (map (lambda (d) + (unless (and (list? d) (= (length d) 2) + (valid-package-name? (car d)) (string? (cadr d))) + (jpkg-error "lock: bad dependency entry ~s for ~a" d name)) + (range-parse (cadr d)) + (cons (car d) (cadr d))) + deps) + yanked + link))) + + (def (lock-parse-string text) + (when (> (string-length text) max-lock-bytes) + (jpkg-error "lock: file too large")) + (let* ([port (open-string-input-port text)] + [datum (try (read port) (catch (e) (jpkg-error "lock: unreadable")))]) + (when (eof-object? datum) (jpkg-error "lock: empty file")) + (let ([extra (try (read port) (catch (e) (jpkg-error "lock: trailing junk")))]) + (unless (eof-object? extra) + (jpkg-error "lock: more than one top-level form"))) + (check-data! datum) + (unless (and (pair? datum) (eq? (car datum) 'lock) (list? (cdr datum))) + (jpkg-error "lock: top-level form must be (lock ...)")) + (let ([version-clause (assq 'version (cdr datum))] + [packages-clause (assq 'packages (cdr datum))]) + (unless (and version-clause (equal? (cdr version-clause) + (list lock-format-version))) + (jpkg-error "lock: unsupported lock format version")) + (unless (and packages-clause (= (length packages-clause) 2) + (list? (cadr packages-clause))) + (jpkg-error "lock: missing (packages ...)")) + (let ([pkgs (map parse-locked-package (cadr packages-clause))]) + ;; names must be unique and sorted (deterministic file) + (let loop ([ps pkgs]) + (when (and (pair? ps) (pair? (cdr ps))) + (unless (string<? (locked-package-name (car ps)) + (locked-package-name (cadr ps))) + (jpkg-error "lock: packages not sorted/unique")) + (loop (cdr ps)))) + pkgs)))) + + (def (lock-parse-file path) + (unless (file-exists? path) + (jpkg-error "lock: ~a not found (run `jpkg add` or `jpkg update` first)" path)) + (let ([text (or (bytes->utf8-or-false (read-file-bytevector path)) + (jpkg-error "lock: file not UTF-8"))]) + (lock-parse-string text))) + + ;; ── rendering ────────────────────────────────────────────────────────── + + (def (w x) (call-with-string-output-port (lambda (p) (write x p)))) + + (def (render-package p) + (string-append + " ((name " (w (locked-package-name p)) ")\n" + " (version " (w (locked-package-version p)) ")\n" + " (registry " (w (locked-package-registry p)) ")\n" + (if (locked-package-link p) + (string-append " (link " (w (locked-package-link p)) ")\n") + (string-append + " (artifact-sha256 " (w (locked-package-artifact-sha256 p)) ")\n" + " (artifact-size " (number->string (locked-package-artifact-size p)) ")\n" + " (manifest-sha256 " (w (locked-package-manifest-sha256 p)) ")\n")) + " (dependencies (" + (string-join-list + (map (lambda (d) (string-append "(" (w (car d)) " " (w (cdr d)) ")")) + (locked-package-dependencies p)) + " ") + "))\n" + " (yanked " (if (locked-package-yanked? p) "#t" "#f") "))")) + + (def (lock-render pkgs) + (let ([sorted (list-sort (lambda (a b) + (string<? (locked-package-name a) + (locked-package-name b))) + pkgs)]) + (string-append + ";; jpkg.lock — generated by jpkg; records the exact resolved\n" + ";; dependency graph. Do not edit by hand.\n" + "(lock\n" + " (version " (number->string lock-format-version) ")\n" + " (packages\n" + " (" (string-join-list (map render-package sorted) "\n") "))\n" + " )\n"))) + + (def (lock-write-file path pkgs) + (let ([text (lock-render pkgs)]) + ;; render must round-trip before it can be written + (let ([parsed (lock-parse-string text)]) + (unless (= (length parsed) (length pkgs)) + (jpkg-error "lock: render round-trip failed"))) + (write-file-bytevector path (string->utf8 text)))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/pkg/project.ss @@ -0,0 +1,421 @@ +#!chezscheme +;;; (std pkg project) — project operations: resolve, lock, install, +;;; environments over the content-addressed store. +;;; +;;; The project is the current directory: jpkg.sexp (manifest), jpkg.lock +;;; (exact graph), .jpkg/deps/* (environment links into the unpacked +;;; source cache under $JERBOA_PKG_HOME/src/<artifact-digest>). +;;; +;;; Security invariants: +;;; - `install` materializes EXACTLY jpkg.lock; it never resolves. +;;; - artifacts enter the store only via store-put! (full validation). +;;; - a package name, once locked to a registry, cannot silently move +;;; to a different registry (dependency-confusion guard). +;;; - linked (dev) packages are explicit lock entries with no digests, +;;; and are flagged as non-reproducible. + +(library (std pkg project) + (export project-resolve project-lock-packages + project-install project-add project-remove project-update + project-uninstall project-list project-env-paths + project-link project-unlink + project-verify-lock + multi-registry-provider + env-dir-name) + + (import (chezscheme) + (only (jerboa core) def try catch) + (only (std pkg util) + jpkg-error mkdir-p remove-tree path-concat + read-file-bytevector write-file-bytevector + random-suffix string-join-list string-split-char) + (only (std pkg manifest) + parse-manifest-file manifest-name manifest-version + manifest-dependencies manifest-modules + manifest->sexp-text make-manifest + manifest-description manifest-license manifest-source + manifest-jerboa-req manifest-dev-dependencies + manifest-capabilities valid-package-name?) + (only (std pkg semver) + semver-try-parse semver-compare semver-prerelease range-parse) + (only (std pkg lock) + make-locked-package locked-package-name locked-package-version + locked-package-registry locked-package-artifact-sha256 + locked-package-artifact-size locked-package-manifest-sha256 + locked-package-dependencies locked-package-yanked? + locked-package-link + 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 + release-info-artifact-sha256 release-info-artifact-size + release-info-manifest-sha256 release-info-dependencies + release-info-yanked?) + (only (std pkg store) + jpkg-home store-has? store-put! store-path store-verify) + (only (std pkg artifact) artifact-extract artifact-info-manifest)) + + ;; ── provider over configured registries ──────────────────────────────── + ;; A name is OWNED by the first configured registry that has any + ;; versions of it; other registries are never consulted for that name. + + (def (multi-registry-provider) + (let ([cfg (registry-config)] + [owner-cache '()]) + (define (owner-of name) + (cond + [(assoc name owner-cache) => cdr] + [else + (let loop ([cs cfg]) + (cond + [(null? cs) + (set! owner-cache (cons (cons name #f) owner-cache)) + #f] + [(pair? (registry-package-versions (cdr (car cs)) name)) + (set! owner-cache (cons (cons name (car cs)) owner-cache)) + (car cs)] + [else (loop (cdr cs))]))])) + (when (null? cfg) + (jpkg-error "no registries configured (set JERBOA_PKG_REGISTRIES or ~a)" + "registries/config.sexp")) + (lambda (op . args) + (case op + [(versions) + (let ([o (owner-of (car args))]) + (if o (registry-package-versions (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))]) + (list (cons 'dependencies (release-info-dependencies rel)) + (cons 'yanked (release-info-yanked? rel)) + (cons 'registry (car o)) + (cons 'artifact-sha256 (release-info-artifact-sha256 rel)) + (cons 'artifact-size (release-info-artifact-size rel)) + (cons 'manifest-sha256 (release-info-manifest-sha256 rel)))))] + [else (jpkg-error "provider: bad op ~s" op)])))) + + ;; ── resolve -> locked packages ───────────────────────────────────────── + + (def (project-resolve m provider) + ;; manifest + provider -> list of locked-package (no link entries) + (let ([solution (resolve-dependencies (manifest-dependencies m) provider)]) + (map (lambda (s) + (let* ([name (car s)] [version (cadr s)] + [rel (provider 'release name version)]) + (make-locked-package + name version (cdr (assq 'registry rel)) + (cdr (assq 'artifact-sha256 rel)) + (cdr (assq 'artifact-size rel)) + (cdr (assq 'manifest-sha256 rel)) + (cdr (assq 'dependencies rel)) + (cdr (assq 'yanked rel)) + #f))) + solution))) + + ;; guard: a name locked to registry R must not silently move to R' + (def (check-registry-pinning! old-pkgs new-pkgs) + (for-each + (lambda (np) + (let ([op (find (lambda (o) (string=? (locked-package-name o) + (locked-package-name np))) + old-pkgs)]) + (when (and op + (not (locked-package-link op)) + (not (string=? (locked-package-registry op) + (locked-package-registry np)))) + (jpkg-error + "dependency-confusion guard: ~a was locked to registry ~s but now resolves from ~s; refusing (remove the lock entry explicitly if this is intended)" + (locked-package-name np) + (locked-package-registry op) + (locked-package-registry np))))) + new-pkgs)) + + (def (project-lock-packages) + (if (file-exists? lock-file-name) (lock-parse-file lock-file-name) '())) + + (def (write-lock-preserving-links! new-pkgs) + ;; keep existing link entries unless shadowed by a resolved package + (let* ([old (project-lock-packages)] + [links (filter locked-package-link old)] + [kept (filter (lambda (l) + (not (find (lambda (n) (string=? (locked-package-name n) + (locked-package-name l))) + new-pkgs))) + links)]) + (check-registry-pinning! old new-pkgs) + (lock-write-file lock-file-name (append new-pkgs kept)))) + + ;; ── environment materialization ──────────────────────────────────────── + + (def (env-dir-name name) + ;; "@scope/name" -> "scope-name" + (list->string + (map (lambda (c) (if (char=? c #\/) #\- c)) + (string->list (substring name 1 (string-length name)))))) + + (def (src-cache-dir digest) + (path-concat (jpkg-home) (path-concat "src" digest))) + + (def (ensure-unpacked! p) + ;; store artifact -> unpacked source cache; verifies lock digests + (let* ([digest (locked-package-artifact-sha256 p)] + [dest (src-cache-dir digest)]) + (unless (file-directory? dest) + (let ([tmp (string-append dest ".tmp-" (random-suffix))]) + (let ([info (artifact-extract (store-path digest) tmp)]) + (let ([m (artifact-info-manifest info)]) + (unless (and (string=? (manifest-name m) (locked-package-name p)) + (string=? (manifest-version m) (locked-package-version p))) + (remove-tree tmp) + (jpkg-error "install: artifact ~a is ~a@~a, lock says ~a@~a" + digest (manifest-name m) (manifest-version m) + (locked-package-name p) (locked-package-version p))))) + (if (file-directory? dest) + (remove-tree tmp) ;; another process won the race + (rename-file tmp dest)))) + dest)) + + ;; libc symlink(2). Static builds have the symbol linked in; dynamic + ;; builds need libc/libSystem loaded first (same dance as std os posix). + (def _libc + (or (try (load-shared-object "libc.so.7") (catch (e) #f)) ;; FreeBSD + (try (load-shared-object "libc.so.6") (catch (e) #f)) ;; glibc + (try (load-shared-object "libc.so") (catch (e) #f)) ;; musl + (try (load-shared-object "/usr/lib/libSystem.B.dylib") ;; macOS + (catch (e) #f)) + (try (load-shared-object "libSystem.dylib") (catch (e) #f)))) + + (def c-symlink + (try (foreign-procedure "symlink" (string string) int) + (catch (e) #f))) + + (def (link-into-env! name target) + (mkdir-p ".jpkg/deps") + (let ([lnk (path-concat ".jpkg/deps" (env-dir-name name))] + [abs-target (if (and (> (string-length target) 0) + (char=? (string-ref target 0) #\/)) + target + (path-concat (current-directory) target))]) + (when (file-exists? lnk #f) (delete-file lnk)) + ;; symlink: cheap view over the store (or the linked checkout) + (unless (and c-symlink (= 0 (c-symlink abs-target lnk))) + (jpkg-error "install: failed to link ~a" name)) + lnk)) + + (def (fetch-into-store! p) + (let ([digest (locked-package-artifact-sha256 p)]) + (unless (store-has? digest) + (let* ([reg-path (registry-lookup (locked-package-registry p))] + [tmp (format "/tmp/jpkg-fetch-~a.jpkg" (random-suffix))]) + (registry-fetch-blob reg-path digest tmp) + (store-put! tmp digest) ;; validates structure + digest + (delete-file tmp))) + (unless (store-verify digest) + (jpkg-error "install: stored artifact ~a fails verification" digest)))) + + (def (project-install) + ;; install EXACTLY what jpkg.lock describes + (let ([pkgs (lock-parse-file lock-file-name)]) + (for-each + (lambda (p) + (if (locked-package-link p) + (let ([path (locked-package-link p)]) + (unless (file-directory? path) + (jpkg-error "install: linked path ~a missing for ~a" + path (locked-package-name p))) + (link-into-env! (locked-package-name p) path)) + (begin + (fetch-into-store! p) + (link-into-env! (locked-package-name p) (ensure-unpacked! p))))) + pkgs) + ;; prune env entries not in the lock + (when (file-directory? ".jpkg/deps") + (let ([valid (map (lambda (p) (env-dir-name (locked-package-name p))) pkgs)]) + (for-each (lambda (e) + (unless (member e valid) + (let ([p (path-concat ".jpkg/deps" e)]) + (if (file-directory? p) + (remove-tree p) + (delete-file p))))) + (directory-list ".jpkg/deps")))) + pkgs)) + + ;; ── manifest editing ─────────────────────────────────────────────────── + + (def (manifest-with-deps m deps) + (make-manifest + (manifest-name m) (manifest-version m) (manifest-description m) + (manifest-license m) (manifest-source m) (manifest-jerboa-req m) + (manifest-modules m) deps (manifest-dev-dependencies m) + (manifest-capabilities m))) + + (def (write-manifest! m) + (write-file-bytevector "jpkg.sexp" (string->utf8 (manifest->sexp-text m)))) + + ;; ── commands ─────────────────────────────────────────────────────────── + + (def (parse-pkg-spec spec) + ;; "PKG" or "PKG@VERSION-OR-RANGE" -> (values name range-or-#f) + (let loop ([i 1]) ;; skip the leading @ of the scope + (cond + [(>= i (string-length spec)) (values spec #f)] + [(char=? (string-ref spec i) #\@) + (values (substring spec 0 i) + (substring spec (+ i 1) (string-length spec)))] + [else (loop (+ i 1))]))) + + (def (project-add spec) + (let-values ([(name want) (parse-pkg-spec spec)]) + (unless (valid-package-name? name) + (jpkg-error "invalid package name ~s" name)) + (let* ([m (parse-manifest-file "jpkg.sexp")] + [provider (multi-registry-provider)] + [range + (if want + (begin (range-parse want) want) ;; validate, keep as written + ;; default: caret on the highest non-prerelease version + (let* ([vs (provider 'versions name)] + [parsed (filter + (lambda (p) + (and (cdr p) + (null? (semver-prerelease (cdr p))))) + (map (lambda (v) (cons v (semver-try-parse v))) + vs))]) + (when (null? parsed) + (jpkg-error "package ~a not found in any registry" name)) + (let ([best (fold-left + (lambda (acc p) + (if (> (semver-compare (cdr p) (cdr acc)) 0) + p acc)) + (car parsed) (cdr parsed))]) + (string-append "^" (car best)))))] + [deps (cons (cons name range) + (filter (lambda (d) (not (string=? (car d) name))) + (manifest-dependencies m)))] + [m2 (manifest-with-deps m (list-sort + (lambda (a b) (string<? (car a) (car b))) + deps))] + [new-pkgs (project-resolve m2 provider)]) + (write-lock-preserving-links! new-pkgs) + (write-manifest! m2) + (project-install) + new-pkgs))) + + (def (project-remove name) + (unless (valid-package-name? name) + (jpkg-error "invalid package name ~s" name)) + (let* ([m (parse-manifest-file "jpkg.sexp")] + [deps (manifest-dependencies m)]) + (unless (assoc name deps) + (jpkg-error "~a is not a dependency" name)) + (let* ([m2 (manifest-with-deps + m (filter (lambda (d) (not (string=? (car d) name))) deps))] + [provider (multi-registry-provider)] + [new-pkgs (project-resolve m2 provider)]) + (write-lock-preserving-links! new-pkgs) + (write-manifest! m2) + (project-install) + new-pkgs))) + + (def (project-update names) + (let* ([m (parse-manifest-file "jpkg.sexp")] + [deps (manifest-dependencies m)]) + (for-each + (lambda (n) + (unless (assoc n deps) + (jpkg-error "~a is not a dependency of this project" n))) + names) + (let* ([provider (multi-registry-provider)] + [new-pkgs (project-resolve m provider)]) + (write-lock-preserving-links! new-pkgs) + (project-install) + new-pkgs))) + + (def (project-uninstall name) + (let ([lnk (path-concat ".jpkg/deps" (env-dir-name name))]) + (unless (file-exists? lnk #f) + (jpkg-error "~a is not installed in this environment" name)) + (delete-file lnk))) + + (def (project-list) + (project-lock-packages)) + + ;; ── link / unlink (dev mode) ─────────────────────────────────────────── + + (def (project-link name path) + (unless (valid-package-name? name) + (jpkg-error "invalid package name ~s" name)) + (let ([mpath (path-concat path "jpkg.sexp")]) + (unless (file-exists? mpath) + (jpkg-error "link: ~a has no jpkg.sexp" path)) + (let ([lm (parse-manifest-file mpath)]) + (unless (string=? (manifest-name lm) name) + (jpkg-error "link: ~a declares name ~a, not ~a" + path (manifest-name lm) name))) + (let* ([old (project-lock-packages)] + [others (filter (lambda (p) (not (string=? (locked-package-name p) + name))) + old)] + [entry (make-locked-package + name "0.0.0" "local-link" #f #f #f '() #f path)]) + (lock-write-file lock-file-name (append others (list entry))) + (link-into-env! name path) + entry))) + + (def (project-unlink name) + (let* ([old (project-lock-packages)] + [entry (find (lambda (p) (and (string=? (locked-package-name p) name) + (locked-package-link p))) + old)]) + (unless entry + (jpkg-error "~a is not linked" name)) + (lock-write-file lock-file-name + (filter (lambda (p) (not (eq? p entry))) old)) + (let ([lnk (path-concat ".jpkg/deps" (env-dir-name name))]) + (when (file-exists? lnk #f) (delete-file lnk))) + ;; if it is also a manifest dependency, a fresh update restores it + (void))) + + ;; ── env paths ────────────────────────────────────────────────────────── + + (def (dep-root-path name) + ;; library root inside an installed dep: <link>/<modules.root> + (let* ([base (path-concat ".jpkg/deps" (env-dir-name name))] + [mpath (path-concat base "jpkg.sexp")]) + (if (file-exists? mpath) + (let* ([m (parse-manifest-file mpath)] + [root (if (manifest-modules m) + (cdr (assq 'root (manifest-modules m))) + "src")]) + (if (string=? root ".") base (path-concat base root))) + base))) + + (def (project-env-paths) + ;; absolute-ish (project-relative) library paths for all locked deps + (map (lambda (p) (dep-root-path (locked-package-name p))) + (project-lock-packages))) + + ;; ── verify (lock + store) ────────────────────────────────────────────── + + (def (project-verify-lock strict?) + ;; returns list of (name status) where status in ok/missing/linked + (let ([pkgs (project-lock-packages)]) + (map + (lambda (p) + (cond + [(locked-package-link p) + (when strict? + (jpkg-error "verify --strict: ~a is a local link (non-reproducible)" + (locked-package-name p))) + (list (locked-package-name p) 'linked)] + [(not (store-has? (locked-package-artifact-sha256 p))) + (list (locked-package-name p) 'missing)] + [(store-verify (locked-package-artifact-sha256 p)) + (list (locked-package-name p) 'ok)] + [else (jpkg-error "verify: stored artifact for ~a fails digest check" + (locked-package-name p))])) + pkgs))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/pkg/registry.ss @@ -0,0 +1,252 @@ +#!chezscheme +;;; (std pkg registry) — package registries: local/static layout access +;;; and the test/staging registry generator. +;;; +;;; Layout (docs/jpkg-plan.md "Registry Model"): +;;; packages/@scope/name/1.2.3/release.json +;;; blobs/sha256/<digest> +;;; (metadata/* TUF roles arrive in phase 3) +;;; +;;; release.json is canonical JSON with the data the resolver needs +;;; WITHOUT downloading artifacts: artifact digest/size, manifest digest, +;;; dependencies, capabilities, yanked flag. +;;; +;;; Registry configuration: an ordered list of (name . path) pairs from +;;; JERBOA_PKG_REGISTRIES ("name=path,name=path") or +;;; $JERBOA_PKG_HOME/registries/config.sexp: (registries ("name" "path") ...) + +(library (std pkg registry) + (export registry-config + registry-lookup + registry-package-versions + registry-release + registry-blob-path + registry-fetch-blob + release-info? release-info-name release-info-version + release-info-artifact-sha256 release-info-artifact-size + release-info-manifest-sha256 release-info-dependencies + release-info-capabilities release-info-yanked? + registry-generate-skeleton + registry-add-package! + registry-yank!) + + (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 + sha256-hex-of-bytevector bytes->utf8-or-false + string-split-char) + (only (std pkg canonical) canonical-json) + (only (std pkg manifest) + parse-manifest-string valid-package-name? + manifest-name manifest-version manifest-dependencies + manifest-capabilities manifest->canonical-json) + (only (std pkg semver) semver-try-parse) + (only (std pkg store) valid-digest?) + (only (std pkg artifact) + 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 text json) string->json-object)) + + ;; ── configuration ────────────────────────────────────────────────────── + + (def (jpkg-home*) + (or (getenv "JERBOA_PKG_HOME") + (let ([home (or (getenv "HOME") (jpkg-error "registry: HOME not set"))]) + (path-concat home ".jerboa/pkg")))) + + (def (registry-config) + ;; -> ((name . path) ...) in priority order + (let ([env (getenv "JERBOA_PKG_REGISTRIES")]) + (cond + [(and env (> (string-length env) 0)) + (map (lambda (spec) + (let ([parts (string-split-char spec #\=)]) + (unless (= (length parts) 2) + (jpkg-error "registry: bad JERBOA_PKG_REGISTRIES entry ~s" spec)) + (cons (car parts) (cadr parts)))) + (string-split-char env #\,))] + [else + (let ([cfg (path-concat (jpkg-home*) "registries/config.sexp")]) + (if (file-exists? cfg) + (let* ([bv (read-file-bytevector cfg)] + [text (or (bytes->utf8-or-false bv) + (jpkg-error "registry: config not UTF-8"))] + [datum (with-input-from-string text read)]) + (unless (and (pair? datum) (eq? (car datum) 'registries)) + (jpkg-error "registry: bad config (want (registries (NAME PATH) ...))")) + (map (lambda (e) + (unless (and (list? e) (= (length e) 2) + (string? (car e)) (string? (cadr e))) + (jpkg-error "registry: bad config entry ~s" e)) + (cons (car e) (cadr e))) + (cdr datum))) + '()))]))) + + (def (registry-lookup name) + ;; registry name -> path + (let ([cfg (registry-config)]) + (cond + [(assoc name cfg) => cdr] + [else (jpkg-error "registry: unknown registry ~s (configured: ~s)" + name (map car cfg))]))) + + ;; ── reading ──────────────────────────────────────────────────────────── + + (defstruct release-info + (name version artifact-sha256 artifact-size manifest-sha256 + dependencies capabilities yanked?)) + + (def (package-dir reg-path name)