jpkg: built-in default @lisp registry + bare-name resolution
ober
93cb0e9a681190c49e8ba5487907dc8dbe1f9dfc
--- a/lib/std/pkg/project.ss +++ b/lib/std/pkg/project.ss @@ -54,7 +54,9 @@ registry-fetch-blob registry-verify-authorship release-info-artifact-sha256 release-info-artifact-size release-info-manifest-sha256 release-info-dependencies - release-info-yanked?) + release-info-yanked? + default-registry-name default-registry-local-path + ensure-default-registry-synced!) (only (std pkg store) jpkg-home store-has? store-put! store-path store-verify) (only (std pkg artifact) artifact-extract artifact-info-manifest)) @@ -64,6 +66,9 @@ ;; versions of it; other registries are never consulted for that name. (def (multi-registry-provider) + ;; On first use of the built-in default registry, sync its metadata from + ;; the public mirror so the local cache is populated. + (ensure-default-registry-synced!) (let ([cfg (registry-config)] [owner-cache '()]) (define (owner-of name) @@ -380,15 +385,33 @@ ;; ── commands ─────────────────────────────────────────────────────────── + (def (default-scope) + ;; The default scope applied when a package spec lacks an explicit @scope. + ;; Override with $JPKG_DEFAULT_SCOPE (without the @); the canonical + ;; upstream registry is @lisp. + (let ([env (getenv "JPKG_DEFAULT_SCOPE")]) + (if (and env (> (string-length env) 0) + (char=? (string-ref env 0) #\@)) + env + (string-append "@" (or env "lisp"))))) + (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))]))) + ;; A bare name without @scope (e.g. "ssh" or "ssh@^1.0") is auto-prefixed + ;; with the default scope (e.g. "@lisp/ssh"). A name that already starts + ;; with @scope is used as-is. + (let ([spec + (if (and (> (string-length spec) 0) + (char=? (string-ref spec 0) #\@)) + spec + (string-append (default-scope) "/" spec))]) + (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)]) @@ -428,29 +451,43 @@ 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)]) + ;; Apply default-scope resolution so `jpkg remove ssh` matches `jpkg add ssh`. + (let* ([resolved + (if (and (> (string-length name) 0) + (char=? (string-ref name 0) #\@)) + name + (string-append (default-scope) "/" name))]) + (unless (valid-package-name? resolved) + (jpkg-error "invalid package name ~s" resolved)) + (let* ([m (parse-manifest-file "jpkg.sexp")] + [deps (manifest-dependencies m)]) + (unless (assoc resolved deps) + (jpkg-error "~a is not a dependency" resolved)) + (let* ([m2 (manifest-with-deps + m (filter (lambda (d) (not (string=? (car d) resolved))) deps))] + [provider (multi-registry-provider)] + [new-pkgs (project-resolve m2 provider)]) (write-lock-preserving-links! new-pkgs) (write-manifest! m2) (project-install) - new-pkgs))) + new-pkgs)))) (def (project-update names) + ;; Apply default-scope resolution so `jpkg update ssh` matches `jpkg add ssh`. (let* ([m (parse-manifest-file "jpkg.sexp")] - [deps (manifest-dependencies m)]) + [deps (manifest-dependencies m)] + [resolved + (map (lambda (n) + (if (and (> (string-length n) 0) + (char=? (string-ref n 0) #\@)) + n + (string-append (default-scope) "/" n))) + names)]) (for-each (lambda (n) (unless (assoc n deps) (jpkg-error "~a is not a dependency of this project" n))) - names) + resolved) (let* ([provider (multi-registry-provider)] [new-pkgs (project-resolve m provider)]) (write-lock-preserving-links! new-pkgs) @@ -458,9 +495,15 @@ new-pkgs))) (def (project-uninstall name) - (let ([lnk (path-concat ".jpkg/deps" (env-dir-name name))]) + ;; Apply default-scope resolution. + (let* ([resolved + (if (and (> (string-length name) 0) + (char=? (string-ref name 0) #\@)) + name + (string-append (default-scope) "/" name))] + [lnk (path-concat ".jpkg/deps" (env-dir-name resolved))]) (unless (file-exists? lnk #f) - (jpkg-error "~a is not installed in this environment" name)) + (jpkg-error "~a is not installed in this environment" resolved)) (delete-file lnk))) (def (project-list) --- a/lib/std/pkg/registry.ss +++ b/lib/std/pkg/registry.ss @@ -34,15 +34,24 @@ registry-add-signed-package! registry-publishers registry-verify-authorship - registry-yank!) - - (import (chezscheme) - (only (jerboa core) def defstruct try catch) + registry-yank! + default-registry-name + default-registry-mirror + default-registry-local-path + default-registry-synced? + ensure-default-registry-synced! + registry-sync! + http-fetch!) + + (import (except (chezscheme) hash-table?) + (only (jerboa core) def defstruct try catch + hash-ref hash-get hash-for-each hash-keys hash-table?) (only (std pkg util) - jpkg-error mkdir-p path-concat + jpkg-error mkdir-p path-concat path-dirname read-file-bytevector write-file-bytevector sha256-hex-of-bytevector bytes->utf8-or-false - string-split-char) + string-split-char + string-suffix-of? string-prefix-of?) (only (std pkg canonical) canonical-json) (only (std pkg manifest) parse-manifest-string valid-package-name? @@ -71,8 +80,107 @@ (let ([home (or (getenv "HOME") (jpkg-error "registry: HOME not set"))]) (path-concat home ".jerboa/pkg")))) + ;; ── default registry (the canonical @lisp mirror) ────────────────────── + ;; + ;; The multicall ships with a built-in default registry pointing at the + ;; public @lisp TUF mirror on GitHub Pages. The mirror is just a static + ;; directory tree (metadata/, packages/, blobs/, etc.) served over HTTPS. + ;; On first use we sync metadata + publishers + transparency + all + ;; release.json files into a local cache under $JERBOA_PKG_HOME/registries/lisp/ + ;; so the existing TUF/registry code reads everything locally. Blobs + ;; (large .jpkg files) are fetched on demand from the mirror during install. + + (def default-registry-name "lisp") + (def default-registry-mirror + (or (getenv "JPKG_DEFAULT_REGISTRY_MIRROR") + "https://ober.github.io/jerboa-registry/")) + + (def (default-registry-local-path) + (path-concat (jpkg-home*) (path-concat "registries" default-registry-name))) + + (def (http-fetch! url dest) + ;; Fetch URL via curl into DEST. Returns #t on success, #f otherwise. + ;; Uses --fail --silent --show-error so curl returns non-zero on 4xx/5xx + ;; without polluting stdout. We shell out because std/net/request is a + ;; heavy import for this one-off use; curl is universally available. + (let* ([curl (or (getenv "JPKG_CURL") "curl")] + [cmd (string-append + curl + " --fail --silent --show-error --location" + " --connect-timeout 15 --max-time 60" + " -o " (shell-quote-arg dest) + " " (shell-quote-arg url))] + [rc (system cmd)]) + (= rc 0))) + + (def (shell-quote-arg s) + (string-append + "'" + (apply string-append + (map (lambda (c) (if (char=? c #\') "'\"'\"'" (string c))) + (string->list s))) + "'")) + + (def (default-registry-synced?) + ;; Synced iff metadata/root.json exists in the local cache. + (file-exists? (path-concat (default-registry-local-path) "metadata/root.json"))) + + (def (registry-sync! name mirror-url local-path) + ;; Full sync of metadata, publishers, transparency, and all release.json + ;; from a mirror URL into local-path. Blobs are NOT synced (fetched on + ;; demand). Returns #t on success. + (define (fetch relpath) + (let ([dest (path-concat local-path relpath)]) + (mkdir-p (path-dirname dest)) + (or (file-exists? dest) ;; don't re-fetch + (http-fetch! (string-append (string-trim-suffix mirror-url "/") "/" relpath) dest)))) + (define (string-trim-suffix s suffix) + (if (string-suffix-of? suffix s) + (substring s 0 (- (string-length s) (string-length suffix))) + s)) + ;; Fetch core TUF metadata + (let ([meta-files '("metadata/root.json" + "metadata/timestamp.json" + "metadata/snapshot.json" + "metadata/targets.json" + "publishers.json" + "transparency.json")]) + (for-each (lambda (f) (fetch f)) meta-files)) + ;; Fetch all release.json files (for every package/version). + ;; We parse targets.json (JSON) to get the list of targets — release.json + ;; paths are under packages/<scope>/<name>/<version>/release.json. + (let ([targets-path (path-concat local-path "metadata/targets.json")]) + (when (file-exists? targets-path) + (let* ([bv (read-file-bytevector targets-path)] + [text (or (bytes->utf8-or-false bv) "")] + [obj (string->json-object text)]) + (when (hash-table? obj) + ;; obj shape: {"signatures": [...], "signed": {"targets": {<path>: {...}}}} + (let* ([signed (hash-get obj "signed")] + [targets (and signed (hash-get signed "targets"))]) + (when (hash-table? targets) + (hash-for-each + (lambda (path _entry) + (when (string-prefix-of? "packages/" path) + (fetch path))) + targets))))))) + #t) + + (def (ensure-default-registry-synced!) + ;; Sync the default registry from its mirror on first use. + (unless (default-registry-synced?) + (let ([local (default-registry-local-path)] + [mirror default-registry-mirror]) + (mkdir-p (path-concat local "metadata")) + (registry-sync! default-registry-name mirror local)))) + (def (registry-config) - ;; -> ((name . path) ...) in priority order + ;; -> ((name . path) ...) in priority order. + ;; Built-in default: the @lisp registry at $JERBOA_PKG_HOME/registries/lisp/ + ;; (synced on first use from default-registry-mirror). Override with + ;; JERBOA_PKG_REGISTRIES or the config file — if either is non-empty, + ;; the default is suppressed (so power users can opt out by setting + ;; JERBOA_PKG_REGISTRIES="" explicitly to mean "no defaults"). (let ([env (getenv "JERBOA_PKG_REGISTRIES")]) (cond [(and env (> (string-length env) 0)) @@ -97,7 +205,13 @@ (jpkg-error "registry: bad config entry ~s" e)) (cons (car e) (cadr e))) (cdr datum))) - '()))]))) + ;; No explicit config: use the built-in default. + ;; Suppress with JPKG_NO_DEFAULT_REGISTRY=1. + (let ([no-default (getenv "JPKG_NO_DEFAULT_REGISTRY")]) + (if (and no-default (> (string-length no-default) 0)) + '() + (list (cons default-registry-name + (default-registry-local-path)))))))]))) (def (registry-lookup name) ;; registry name -> path @@ -350,16 +464,36 @@ (path-concat (path-concat reg-path "blobs/sha256") digest)) (def (registry-fetch-blob reg-path digest dest) - ;; copy blob to dest; verify digest BEFORE handing it over + ;; Copy blob to dest; verify digest BEFORE handing it over. + ;; For the default @lisp registry, blobs live on a public mirror and + ;; are fetched on demand (the local cache only stores metadata). (let ([src (registry-blob-path reg-path digest)]) (unless (file-exists? src) - (jpkg-error "registry: blob ~a not found" digest)) + ;; If this is the default registry, try fetching the blob from the + ;; mirror. The reg-path will match default-registry-local-path. + (let ([local-default (default-registry-local-path)]) + (unless (and (string=? reg-path local-default) + (begin + (mkdir-p (path-concat local-default "blobs/sha256")) + (http-fetch! + (string-append + (string-trim-slash default-registry-mirror) + "/blobs/sha256/" digest) + src))) + (jpkg-error "registry: blob ~a not found" digest)))) (let ([bv (read-file-bytevector src)]) (unless (string=? (sha256-hex-of-bytevector bv) digest) (jpkg-error "registry: blob ~a fails digest check (corrupt mirror?)" digest)) (write-file-bytevector dest bv) dest))) + (def (string-trim-slash s) + ;; Strip trailing slash from a URL or path. + (if (and (> (string-length s) 0) + (char=? (string-ref s (- (string-length s) 1)) #\/)) + (substring s 0 (- (string-length s) 1)) + s)) + ;; ── generation (tests, staging, later `jpkg publish`) ────────────────── (def (registry-generate-skeleton reg-path)