From fdf06e461a9afd20f39a74ad1ea618a2ad037701 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 8 May 2014 09:44:43 -0600 Subject: [PATCH] add `raco pkg catalog-archive` The `catalog-archive` command not only copies a catalog, but also copies all package sources referenced by the catalog to create a snapshot that doesn't depend on any external pieces. One reason you might want to do that is to download all packages on a machine with general network access, and then building packages on a (virtual) machine whose network access is limited. This commit also adds support for relative package sources in the catalog protocol, where a client converts a relative package source to an absolute one. Since the relative-to-absolute conversion happens on clients, relative sources will be of limited use until v6.0 and v6.0.1 become deprecated. A new `current-pkg-lookup-version` parameter corrects the misuse of `current-pkg-scope-version` for package-catalog queries. --- .../racket-doc/pkg/scribblings/apis.scrbl | 2 + .../pkg/scribblings/catalog-protocol.scrbl | 9 +- .../racket-doc/pkg/scribblings/lib.scrbl | 57 +++- .../racket-doc/pkg/scribblings/name.scrbl | 19 +- .../racket-doc/pkg/scribblings/pkg.scrbl | 48 ++- .../tests/pkg/test-catalogs-api.rkt | 4 +- .../racket-test/tests/pkg/tests-catalogs.rkt | 52 +++- racket/collects/pkg/db.rkt | 25 +- racket/collects/pkg/lib.rkt | 284 +++++++++++++++--- racket/collects/pkg/main.rkt | 29 +- 10 files changed, 456 insertions(+), 73 deletions(-) diff --git a/pkgs/racket-pkgs/racket-doc/pkg/scribblings/apis.scrbl b/pkgs/racket-pkgs/racket-doc/pkg/scribblings/apis.scrbl index 7928f6614b..8aa16e3c2d 100644 --- a/pkgs/racket-pkgs/racket-doc/pkg/scribblings/apis.scrbl +++ b/pkgs/racket-pkgs/racket-doc/pkg/scribblings/apis.scrbl @@ -40,7 +40,9 @@ to the @exec{raco pkg} sub-subcommands. @defthing[pkg-create-command procedure?]{Implements @command-ref{create}.} @defthing[pkg-catalog-show-command procedure?]{Implements @command-ref{catalog-show}.} @defthing[pkg-catalog-copy-command procedure?]{Implements @command-ref{catalog-copy}.} +@defthing[pkg-catalog-archive-command procedure?]{Implements @command-ref{catalog-archive}. + @history[#:added "6.0.17"]} @include-section["lib.scrbl"] @include-section["path.scrbl"] diff --git a/pkgs/racket-pkgs/racket-doc/pkg/scribblings/catalog-protocol.scrbl b/pkgs/racket-pkgs/racket-doc/pkg/scribblings/catalog-protocol.scrbl index 1d0fc92c7f..746cbc08bc 100644 --- a/pkgs/racket-pkgs/racket-doc/pkg/scribblings/catalog-protocol.scrbl +++ b/pkgs/racket-pkgs/racket-doc/pkg/scribblings/catalog-protocol.scrbl @@ -45,7 +45,12 @@ information about packages: @itemlist[ @item{@racket['source] (required) --- a @tech{package source} - string, typically a remote URL.} + string, typically a remote URL. If this source is a + relative path, then it is treated as relative to the + catalog. + + @history[#:changed "6.0.1.7" @elem{Added relative-path support + to clients of a catalog server.}]} @item{@racket['checksum] (requires) --- a string for a @tech{checksum}.} @@ -174,7 +179,7 @@ constructed in any way as long as it contains the following tables: @item{A @tt{tags} table with the form @verbatim[#:indent 2]{(pkg TEXT, - catalog TEXT, + catalog SMALLINT, tag TEXT)} where the @tt{pkg} and @tt{catalog} combination identifies a unique diff --git a/pkgs/racket-pkgs/racket-doc/pkg/scribblings/lib.scrbl b/pkgs/racket-pkgs/racket-doc/pkg/scribblings/lib.scrbl index 51b76b1db2..776e9a9ea6 100644 --- a/pkgs/racket-pkgs/racket-doc/pkg/scribblings/lib.scrbl +++ b/pkgs/racket-pkgs/racket-doc/pkg/scribblings/lib.scrbl @@ -42,6 +42,15 @@ Parameters that determine @tech{package scope} for management operations and, in the case of @racket['user] scope, the relevant installation name/version.} +@deftogether[( +@defparam[current-pkg-lookup-version s string?] +)]{ + +Parameter that determines the relevant Racket version for +extracting package information from a catalog. + +@history[#:added "6.0.1.7"]} + @defparam[current-pkg-error err procedure?]{ @@ -133,7 +142,9 @@ dependency.} [#:checksum checksum (or/c #f string?) #f] [#:in-place? in-place? boolean? #f] [#:namespace namespace namespace? (make-base-namespace)] - [#:strip strip (or/c #f 'source 'binary) #f]) + [#:strip strip (or/c #f 'source 'binary) #f] + [#:use-cache? use-cache? boolean? #f] + [#:quiet? quiet? boolean? #t]) (values string? path? (or/c #f string?) boolean? (listof module-path?))]{ Locates the implementation of the package specified by @racket[desc] @@ -151,6 +162,11 @@ removed from the prepared directory the same as when creating the corresponding kind of package. A directory that is staged in-place cannot be stripped. +If @racket[use-cache?] is true, then a local cache is consulted before +downloading a particular package with a particular checksum. Note that +the default for @racket[use-cache?] is @racket[#f], while the default +is @racket[#t] for other functions that accept @racket[#:use-cache?]. + The result is the package name, the directory containing the unpacked package content, the checksum (if any) for the unpacked package, whether the directory should be removed after the package content is no longer @@ -172,6 +188,9 @@ The package lock must be held (allowing writes if @racket[set?] is true); see @defproc[(pkg-create [format (or/c 'zip 'tgz 'plt 'MANIFEST)] [dir path-string?] + [#:source source (or/c 'dir 'name)] + [#:mode mode (or/c 'as-is 'source 'binary 'built)] + [#:dest dest-dir (or/c (and/c path-string? complete-path?) #f)] [#:quiet? quiet? boolean? #f] [#:from-command-line? from-command-line? boolean? #f]) void?]{ @@ -191,6 +210,7 @@ is true, error messages may suggest specific command-line flags for [#:update-deps? update-deps? boolean? #f] [#:force? force? boolean? #f] [#:ignore-checksums? ignore-checksums? boolean? #f] + [#:use-cache? use-cache? boolean? #t] [#:quiet? boolean? quiet? #f] [#:from-command-line? from-command-line? boolean? #f] [#:strip strip (or/c #f 'source 'binary) #f] @@ -229,6 +249,7 @@ The package lock must be held; see @racket[with-pkg-lock].} [#:update-deps? update-deps? boolean? #f] [#:force? force? boolean? #f] [#:ignore-checksums? ignore-checksums? boolean? #f] + [#:use-cache? use-cache? quiet? #t] [#:quiet? boolean? quiet? #f] [#:from-command-line? from-command-line? boolean? #f] [#:strip strip (or/c #f 'source 'binary) #f] @@ -289,6 +310,7 @@ The package lock must be held to allow reads; see (or/c #f 'fail 'force 'search-ask 'search-auto) #f] [#:force? force? boolean? #f] + [#:use-cache? use-cache? boolean? #t] [#:ignore-checksums? ignore-checksums? boolean? #f] [#:quiet? boolean? quiet? #f] [#:from-command-line? from-command-line? boolean? #f] @@ -316,8 +338,11 @@ The package lock must be held; see @racket[with-pkg-lock].} Implements @racket[pkg-catalog-show-command]. If @racket[all?] is true, then @racket[names] should be empty. -The @racket[current-pkg-scope-version] parameter determines the version -included in the catalog query.} +The @racket[current-pkg-lookup-version] parameter determines the version +included in the catalog query. + +@history[#:changed "6.0.1.7" @elem{Use @racket[current-pkg-lookup-version] + instead of @racket[current-pkg-scope-version].}]} @defproc[(pkg-catalog-copy [sources (listof path-string?)] @@ -325,13 +350,33 @@ included in the catalog query.} [#:from-config? from-config? boolean? #f] [#:merge? merge? boolean? #f] [#:force? force? boolean? #f] - [#:override? override? boolean? #f]) + [#:override? override? boolean? #f] + [#:relative-sources? relative-sources? boolean? #f]) void?]{ Implements @racket[pkg-catalog-copy-command]. -The @racket[current-pkg-scope-version] parameter determines the version -for extracting existing catalog information.} +The @racket[current-pkg-lookup-version] parameter determines the version +for extracting existing catalog information. + +@history[#:changed "6.0.1.7" @elem{Use @racket[current-pkg-lookup-version] + instead of @racket[current-pkg-scope-version].}]} + + +@defproc[(pkg-catalog-archive [dest-dir path-string?] + [sources (listof path-string?)] + [#:from-config? from-config? boolean? #f] + [#:state-catalog state-catalog (or/c #f path-string?) #f] + [#:relative-sources? relative-sources? boolean? #f] + [#:quiet? quiet? boolean? #f]) + void?]{ + +Implements @racket[pkg-catalog-archive-command]. + +The @racket[current-pkg-lookup-version] parameter determines the version +for extracting existing catalog information. + +@history[#:added "6.0.1.7"]} @defproc[(pkg-catalog-update-local [#:catalogs catalogs (listof string?) (pkg-config-catalogs)] diff --git a/pkgs/racket-pkgs/racket-doc/pkg/scribblings/name.scrbl b/pkgs/racket-pkgs/racket-doc/pkg/scribblings/name.scrbl index 8c2e66501d..d365c4f8a8 100644 --- a/pkgs/racket-pkgs/racket-doc/pkg/scribblings/name.scrbl +++ b/pkgs/racket-pkgs/racket-doc/pkg/scribblings/name.scrbl @@ -34,11 +34,24 @@ If a valid name cannot be inferred, the result is @racket[#f].} @defproc[(package-source->name+type [source string?] - [type (or/c package-source-format? #f) - #f]) + [type (or/c package-source-format? #f) #f] + [#:complain complain-proc (string? string? . -> . any) void] + [#:must-infer-name? must-infer-name? boolean? #f] + [#:link-dirs? link-dir? boolean?]) (values (or/c #f string?) (or/c package-source-format? #f))]{ Like @racket[package-source->name], but also returns the type of the source (which is useful when the type is inferred). If the source is -not well-formed, the second result can be @racket[#f].} +not well-formed, the second result can be @racket[#f]. + +The @racket[complain-proc] function is applied when @racket[source] is +ill-formed. The arguments to @racket[complain-proc] are +@racket[source] and an error message. + +If @racket[must-infer-name?] is true, then @racket[complain-proc] +is called if a valid name cannot be inferred from @racket[source]. + +If @racket[link-dirs?] is true, then a directory path is reported as +type @racket['link] instead of @racket['dir].} + diff --git a/pkgs/racket-pkgs/racket-doc/pkg/scribblings/pkg.scrbl b/pkgs/racket-pkgs/racket-doc/pkg/scribblings/pkg.scrbl index 414c2c26a4..1c6f5112f9 100644 --- a/pkgs/racket-pkgs/racket-doc/pkg/scribblings/pkg.scrbl +++ b/pkgs/racket-pkgs/racket-doc/pkg/scribblings/pkg.scrbl @@ -670,7 +670,7 @@ for @nonterm{key}. } @subcommand{@command/toc{catalog-copy} @nonterm{option} ... @nonterm{src-catalog} ... @nonterm{dest-catalog} ---- Copies information from @tech{package catalog} names by @nonterm{src-catalog}s +--- Copies information from the @tech{package catalog} named by @nonterm{src-catalog}s to a local database or directory @nonterm{dest-catalog}, which can be used as a new @tech{package catalog}. @@ -681,11 +681,11 @@ for @nonterm{key}. with information from earlier @nonterm{src-catalog}s taking precedence over later @nonterm{src-catalog}s. - The @exec{catalog-copy} sub-command accepts + The @exec{catalog-copy} sub-command accepts the following @nonterm{option}s: @itemlist[ - @item{@DFlag{from-config} --- Adds the currently configured + @item{@DFlag{from-config} --- Adds the currently configured @tech{package catalogs} to the end of the @nonterm{src-catalog}s list.} @item{@DFlag{force} --- Replaces @nonterm{dest-catalog} if it exists already.} @item{@DFlag{merge} --- Adds to @nonterm{dest-catalog} if it exists already. By default, @@ -693,11 +693,42 @@ for @nonterm{key}. over new information.} @item{@DFlag{override} --- Changes merging so that new information takes precedence over information already in @nonterm{dest-catalog}.} - @item{@DFlag{version} @nonterm{version} or @Flag{v} @nonterm{version} --- Copy catalog + @item{@DFlag{relative} --- Write package sources to @nonterm{dest-catalog} in relative-path form, + when possible.} + @item{@DFlag{version} @nonterm{version} or @Flag{v} @nonterm{version} --- Copy catalog results specific to @nonterm{version} (for catalogs that make a distinction), instead of the installation's Racket version.} ] } + +@subcommand{@command/toc{catalog-archive} @nonterm{option} ... @nonterm{dest-dir} @nonterm{src-catalog} ... +--- Copies information from the @tech{package catalog} named by @nonterm{src-catalog}s + to a @filepath{catalog} directory catalog in @nonterm{dest-dir}, and also copies + all package sources to a @filepath{pkgs} directory in @nonterm{dest-dir}. + + Packages sources are downloaded and repacked as needed, so that + all packages are written to the @filepath{pkgs} directory as + @filepath{.zip} archives. This conversion may change the checksum + on each archived package. + + The @exec{catalog-archive} sub-command accepts + the following @nonterm{option}s: + + @itemlist[ + @item{@DFlag{from-config} --- Adds the currently configured + @tech{package catalogs} to the end of the @nonterm{src-catalog}s list.} + @item{@DFlag{state} @nonterm{state-database} --- To enable incremental + updating, Reads and writes the database @nonterm{state-database}, which must have the suffix + @filepath{.sqlite}, as the current state of @nonterm{dest-dir}.} + @item{@DFlag{relative} --- Write package sources to @nonterm{dest-catalog} in relative-path form.} + @item{@DFlag{version} @nonterm{version} or @Flag{v} @nonterm{version} --- Copy catalog + results specific to @nonterm{version} + (for catalogs that make a distinction), instead of the installation's Racket version.} + ] + + @history[#:added "6.0.17"] +} + @; ---------------------------------------- @section[#:tag "metadata"]{Package Metadata} @@ -966,6 +997,15 @@ package name resolution, and then directs all package-name resolution to the snapshot. You can configure resolution for specific package names by editing the snapshot. +You can go even further with + +@commandline{raco pkg catalog-archive --from-config /home/joe/snapshot/} + +which not only takes a snapshot of the catalog, but also takes a +snapshot of all package sources (so that you do not depend on the +original sources). + + @subsection{Why is the package manager so different than @|Planet1|?} There are two fundamental differences between @|Planet1| and this package manager. diff --git a/pkgs/racket-pkgs/racket-test/tests/pkg/test-catalogs-api.rkt b/pkgs/racket-pkgs/racket-test/tests/pkg/test-catalogs-api.rkt index 2ee5f51863..866f7702ee 100644 --- a/pkgs/racket-pkgs/racket-test/tests/pkg/test-catalogs-api.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/pkg/test-catalogs-api.rkt @@ -2,7 +2,7 @@ (require pkg/lib rackunit) -;; The `test-api' function is meant to be called via "test-catalogs.rkt" +;; The `test-api' function is meant to be called via "tests-catalogs.rkt" (provide test-api) (define (test-api) @@ -43,4 +43,4 @@ (define-values (cksum2 mods2 deps2) (get-pkg-content (pkg-desc "pkg-test2" 'name #f #f #f))) - (check-equal? deps2 '("pkg-test1"))) \ No newline at end of file + (check-equal? deps2 '("pkg-test1"))) diff --git a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-catalogs.rkt b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-catalogs.rkt index 282afd745f..11ac8e84e3 100644 --- a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-catalogs.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-catalogs.rkt @@ -3,6 +3,7 @@ (prefix-in db: pkg/db) racket/file racket/format + racket/string "shelly.rkt" "util.rkt") @@ -39,6 +40,7 @@ (db:set-pkg-modules! "fish" "local" "123" '((lib "fish/main.rkt") (lib "fish/food.rkt"))) (db:set-pkg-dependencies! "fish" "local" "123" '("ocean" ("water" "1.0") ("crash-helmet" #:platform windows)))) + $ "raco pkg catalog-show fish" =stdout> #rx"Checksum: 123" $ "raco pkg catalog-show fish" =stdout> #rx"ocean" $ "raco pkg catalog-show fish" =stdout> #rx"water version 1.0" @@ -52,7 +54,7 @@ $ "raco pkg catalog-show --only-names --all" =stdout> #rx"fish" $ "raco pkg catalog-show --modules fish" =stdout> #rx"fish/food" $ "raco pkg catalog-show fish" =stdout> #rx"water version 1.0" - + (delete-file (build-path dir "pkgs")) (delete-file (build-path dir "pkgs-all")) $ "raco pkg catalog-show fish" =stdout> #rx"Checksum: 123" @@ -98,6 +100,54 @@ (try-merge dir) (try-merge db) + ;; catalog-archive: + + (define archive-d (build-path d "archive")) + + $ (~a "raco pkg catalog-archive " archive-d " http://localhost:9990") + $ (~a "test -f " archive-d "/pkgs/pkg-test1.zip") + + (define rx:pkg-test1 (regexp + (~a (regexp-quote (~a "Source: " archive-d "/pkgs/pkg-test1.zip")) + ".*" + (regexp-quote (~a "Checksum: " (file->string + (build-path archive-d + "pkgs" + "pkg-test1.zip.CHECKSUM"))))))) + + $ (~a "raco pkg catalog-show --catalog file://" archive-d "/catalog pkg-test1") + =stdout> rx:pkg-test1 + + (delete-directory/files archive-d) + $ "raco pkg config --set catalogs http://localhost:9990" + $ (~a "raco pkg catalog-archive --from-config --relative" + " --state " (build-path archive-d "state.sqlite") + " " archive-d) + =stdout> #rx"== Archiving pkg-test1 ==" + $ (~a "raco pkg catalog-show --catalog file://" archive-d "/catalog pkg-test1") + =stdout> rx:pkg-test1 + $ (~a "grep archive " archive-d "/catalog/pkg/pkg-test1") ; relative path => no "archive" + =exit> 1 + $ (~a "test -f " archive-d "/pkgs/pkg-test2.zip") + $ (~a "test -f " archive-d "/pkgs/pkg-test2-snd.zip") =exit> 1 + + ;; Incremental update: + $ (~a "raco pkg catalog-archive --from-config --relative" + " --state " (build-path archive-d "state.sqlite") + " " archive-d + " http://localhost:9991") + =stdout> #rx"== Archiving pkg-test2-snd ==" + $ (~a "test -f " archive-d "/pkgs/pkg-test2.zip") + $ (~a "test -f " archive-d "/pkgs/pkg-test2-snd.zip") + $ (~a "test -f " archive-d "/pkgs/pkg-test2-snd.zip.CHECKSUM") + + ;; Delete package not in source archives: + $ (~a "raco pkg catalog-archive --from-config --relative" + " --state " (build-path archive-d "state.sqlite") + " " archive-d) + $ (~a "test -f " archive-d "/pkgs/pkg-test2-snd.zip") =exit> 1 + $ (~a "test -f " archive-d "/pkgs/pkg-test2-snd.zip.CHECKSUM") =exit> 1 + (delete-directory/files d))) diff --git a/racket/collects/pkg/db.rkt b/racket/collects/pkg/db.rkt index 9d1b1c3591..7e420ef157 100644 --- a/racket/collects/pkg/db.rkt +++ b/racket/collects/pkg/db.rkt @@ -82,14 +82,18 @@ " author TEXT," " source TEXT," " checksum TEXT," - " desc TEXT)"))) + " desc TEXT)") + ;; index: + "(name, catalog)")) (define (prepare-tags-table db) (prepare-table db "tags" (~a "(pkg TEXT," - " catalog TEXT," - " tag TEXT)"))) + " catalog SMALLINT," + " tag TEXT)") + ;; index: + "(pkg, catalog)")) (define (prepare-modules-table db) (prepare-table db @@ -97,7 +101,9 @@ (~a "(name TEXT," " pkg TEXT," " catalog SMALLINT," - " checksum TEXT)"))) + " checksum TEXT)") + ;; index: + "(pkg, catalog, checksum)")) (define (prepare-dependencies-table db) (prepare-table db @@ -107,7 +113,9 @@ " onplatform TEXT," " pkg TEXT," " catalog SMALLINT," - " checksum TEXT)"))) + " checksum TEXT)") + ;; index: + "(pkg, catalog, checksum)")) (define current-pkg-catalog-file (make-parameter (build-path @@ -548,9 +556,12 @@ (pkg-checksum new) (pkg-desc new)))))))))) -(define (prepare-table db which desc) +(define (prepare-table db which desc [index #f]) (when (null? (query-rows db (~a "SELECT name FROM sqlite_master" " WHERE type='table' AND name='" which "'"))) (query-exec db (~a "CREATE TABLE " which " " - desc)))) + desc)) + (when index + (query-exec db (~a "CREATE INDEX " which "_index " + "ON " which " " index))))) diff --git a/racket/collects/pkg/lib.rkt b/racket/collects/pkg/lib.rkt index 92a0bc51ba..cf79b90360 100644 --- a/racket/collects/pkg/lib.rkt +++ b/racket/collects/pkg/lib.rkt @@ -41,6 +41,8 @@ p)))) (define current-pkg-scope-version (make-parameter (get-installation-name))) +(define current-pkg-lookup-version + (make-parameter (version))) (define current-pkg-error (make-parameter (lambda args (apply error 'pkg args)))) (define current-no-pkg-db @@ -417,7 +419,7 @@ [query (append (url-query addr/no-query) (list - (cons 'version (current-pkg-scope-version))))])) + (cons 'version (current-pkg-lookup-version))))])) ;; Take a package-info hash table and lift any version-specific ;; information in 'versions. @@ -426,7 +428,7 @@ (let ([v (hash-ref ht 'versions #f)]) (cond [(hash? v) - (or (for/or ([vers (in-list (list (current-pkg-scope-version) + (or (for/or ([vers (in-list (list (current-pkg-lookup-version) 'default))]) (define ht2 (hash-ref v vers #f)) (and ht2 @@ -437,37 +439,105 @@ ht)] [else ht])))) +;; If the 'source field in `ht` is a relative path, treat +;; it as relative to `i` and make it absolute: +(define (source->absolute-source i ht) + (cond + [ht + (define s (hash-ref ht 'source #f)) + (define new-ht + (cond + [s + (define-values (name type) (package-source->name+type s #f)) + (cond + [(and (or (eq? type 'dir) (eq? type 'file)) + (not (complete-path? s))) + (define full-path + (cond + [(equal? "file" (url-scheme i)) + (define path (url->path i)) + (define dir (if (db-path? path) + (let-values ([(base name dir?) (split-path path)]) + base) + path)) + (path->string (simplify-path (path->complete-path s dir)))] + [else + (url->string (combine-url/relative i s))])) + (hash-set ht 'source full-path)] + [else ht])] + [else ht])) + (let ([v (hash-ref new-ht 'versions #f)]) + (if v + ;; Adjust version-specific sources: + (hash-set new-ht 'versions + (for/hash ([(k ht) (in-hash v)]) + (values k (source->absolute-source i ht)))) + ;; No further adjustments: + new-ht))] + [else #f])) + +;; Make sources in `ht` relative to `dir`, when possible: +(define (source->relative-source dir ht) + (define s (hash-ref ht 'source #f)) + (define new-ht + (cond + [s + (define-values (name type) (package-source->name+type s #f)) + (cond + [(or (eq? type 'dir) (eq? type 'file)) + (hash-set ht + 'source + (string-join (map (lambda (s) + (case s + [(up) ".."] + [(same) "."] + [else (path-element->string s)])) + (explode-path (find-relative-path dir s))) + "/"))] + [else ht])] + [else ht])) + (let ([v (hash-ref new-ht 'versions #f)]) + (if v + ;; Adjust version-specific sources: + (hash-set new-ht 'versions + (for/hash ([(k ht) (in-hash new-ht)]) + (values k (source->relative-source dir ht)))) + ;; No further adjustments: + new-ht))) + (define (package-catalog-lookup pkg details? download-printf) (or (for/or ([i (in-list (pkg-catalogs))]) (if download-printf (download-printf "Resolving ~s via ~a\n" pkg (url->string i)) (log-pkg-debug "consulting catalog ~a" (url->string i))) - (select-info-version - (catalog-dispatch - i - ;; Server: - (lambda (i) - (define addr (add-version-query - (combine-url/relative i (format "pkg/~a" pkg)))) - (log-pkg-debug "resolving via ~a" (url->string addr)) - (read-from-server - 'package-catalog-lookup - addr - (lambda (v) (and (hash? v) - (for/and ([k (in-hash-keys v)]) - (symbol? k)))) - (lambda (s) #f))) - ;; Local database: - (lambda () - (define pkgs (db:get-pkgs #:name pkg)) - (and (pair? pkgs) - (db-pkg-info (car pkgs) details?))) - ;; Local directory: - (lambda (path) - (define pkg-path (build-path path "pkg" pkg)) - (and (file-exists? pkg-path) - (call-with-input-file* pkg-path read)))))) + (source->absolute-source + i + (select-info-version + (catalog-dispatch + i + ;; Server: + (lambda (i) + (define addr (add-version-query + (combine-url/relative i (format "pkg/~a" pkg)))) + (log-pkg-debug "resolving via ~a" (url->string addr)) + (read-from-server + 'package-catalog-lookup + addr + (lambda (v) (and (hash? v) + (for/and ([k (in-hash-keys v)]) + (symbol? k)))) + (lambda (s) #f))) + ;; Local database: + (lambda () + (define pkgs (db:get-pkgs #:name pkg)) + (and (pair? pkgs) + (db-pkg-info (car pkgs) details?))) + ;; Local directory: + (lambda (path) + (define pkg-path (build-path path "pkg" pkg)) + (and (file-exists? pkg-path) + (call-with-input-file* pkg-path read))))))) (pkg-error (~a "cannot find package on catalogs\n" " package: ~a") pkg))) @@ -1322,14 +1392,16 @@ (define (pkg-stage desc #:namespace [metadata-ns (make-metadata-namespace)] #:in-place? [in-place? #f] - #:strip [strip-mode #f]) + #:strip [strip-mode #f] + #:use-cache? [use-cache? #f] + #:quiet? [quiet? #t]) (define i (stage-package/info (pkg-desc-source desc) (pkg-desc-type desc) (pkg-desc-name desc) #:given-checksum (pkg-desc-checksum desc) - #:use-cache? #f + #:use-cache? use-cache? #t - void + (if quiet? void printf) metadata-ns #:in-place? in-place? #:strip strip-mode)) @@ -2606,16 +2678,18 @@ (delete-directory/files tmp-dir)))) (define (pkg-create create:format dir-or-name + #:pkg-name [given-pkg-name #f] #:dest [dest-dir #f] #:source [source 'dir] #:mode [mode 'as-is] #:quiet? [quiet? #f] #:from-command-line? [from-command-line? #f]) (define pkg-name - (if (eq? source 'dir) - (path->string (let-values ([(base name dir?) (split-path dir-or-name)]) - name)) - dir-or-name)) + (or given-pkg-name + (if (eq? source 'dir) + (path->string (let-values ([(base name dir?) (split-path dir-or-name)]) + name)) + dir-or-name))) (define dir (if (eq? source 'dir) dir-or-name @@ -2646,10 +2720,11 @@ #:from-command-line? from-command-line?)])) (define (pkg-catalog-copy srcs dest - #:from-config? [from-config? #f] - #:merge? [merge? #f] - #:force? [force? #f] - #:override? [override? #f]) + #:from-config? [from-config? #f] + #:merge? [merge? #f] + #:force? [force? #f] + #:override? [override? #f] + #:relative-sources? [relative-sources? #f]) (define src-paths (for/list ([src (in-list (append srcs (if from-config? @@ -2663,7 +2738,7 @@ [(regexp-match? #rx"^file://" src) (url->path (string->url src))] [(regexp-match? #rx"^[a-zA-Z]*://" src) - (pkg-error (~a "unrecognized URL scheme for an catalog\n" + (pkg-error (~a "unrecognized URL scheme for a catalog\n" " URL: ~a") src)] [else (path->complete-path src)])) @@ -2692,6 +2767,13 @@ dest)] [else (path->complete-path dest)])) + (define dest-dir + (and relative-sources? + (if (db-path? dest-path) + (let-values ([(base name dir?) (split-path dest-path)]) + base) + dest-path))) + (unless (or force? merge?) (when (or (file-exists? dest-path) (directory-exists? dest-path) @@ -2700,7 +2782,7 @@ " path: ~a") dest-path))) - (define details + (define absolute-details (let ([src-paths (if (and merge? (or (file-exists? dest-path) (directory-exists? dest-path))) @@ -2715,6 +2797,11 @@ (path->url src-path) src-path))]) (get-all-pkg-details-from-catalogs)))) + (define details + (if relative-sources? + (for/hash ([(k ht) (in-hash absolute-details)]) + (values k (source->relative-source dest-dir ht))) + absolute-details)) (when (and force? (not merge?)) (cond @@ -2921,7 +3008,7 @@ (for/fold ([ht ht]) ([(k v) (in-hash one-ht)]) (if (hash-ref ht k #f) ht - (hash-set ht k v))))) + (hash-set ht k (source->absolute-source i v)))))) (define (extract-pkg-dependencies get-info #:build-deps? [build-deps? #t] @@ -3100,6 +3187,104 @@ (db:set-pkg-modules! name catalog checksum modules) (db:set-pkg-dependencies! name catalog checksum deps))))))) +(define (pkg-catalog-archive dest-dir + src-catalogs + #:from-config? [from-config? #f] + #:state-catalog [state-catalog #f] + #:relative-sources? [relative-sources? #f] + #:quiet? [quiet? #f]) + (when (and state-catalog + (not (db-path? (if (path? state-catalog) + state-catalog + (string->path state-catalog))))) + (pkg-error (~a "bad state file path\n" + " given: ~a\n" + " expected: path with \".sqlite\" extension") + state-catalog)) + ;; Take a snapshot of the source catalog: + (define temp-catalog-file (make-temporary-file "pkg~a.sqlite")) + (pkg-catalog-update-local #:catalogs (append src-catalogs + (if from-config? + (pkg-config-catalogs) + null)) + #:set-catalogs? #t + #:catalog-file temp-catalog-file + #:quiet? quiet?) + (define pkgs + (parameterize ([db:current-pkg-catalog-file temp-catalog-file]) + (db:get-pkgs))) + ;; Reset state catalog to new packages: + (when state-catalog + (parameterize ([db:current-pkg-catalog-file state-catalog]) + (db:set-catalogs! '("local")) + (db:set-pkgs! "local" (map db:pkg-name pkgs)))) + ;; Remove any package not in `pkgs`: + (define pkgs-dir (build-path dest-dir "pkgs")) + (when (directory-exists? pkgs-dir) + (define keep-pkgs (list->set (map db:pkg-name pkgs))) + (for ([f (in-list (directory-list pkgs-dir))]) + (cond + [(regexp-match #rx"^(.*)[.]zip(?:[.]CHECKSUM)?$" f) + => (lambda (m) + (unless (set-member? keep-pkgs (cadr m)) + (unless quiet? + (printf/flush "Removing old package file ~a\n" f)) + (delete-file (build-path pkgs-dir f))))]))) + ;; Check on each new package: + (for ([pkg (in-list (sort pkgs stringstring (path-replace-suffix pkg-file #".zip.CHECKSUM"))) + (parameterize ([db:current-pkg-catalog-file temp-catalog-file]) + (db:set-pkg! name (db:pkg-catalog pkg) + (db:pkg-author pkg) + (path->string pkg-file) + new-checksum + (db:pkg-desc pkg)))) + (define dest-catalog (build-path dest-dir "catalog")) + (unless quiet? + (printf/flush "Creating catalog ~a\n" dest-catalog)) + (pkg-catalog-copy (list temp-catalog-file) + (build-path dest-dir "catalog") + #:force? #t + #:override? #t + #:relative-sources? relative-sources?) + (delete-file temp-catalog-file)) + (define (choose-catalog-file) (define default (db:current-pkg-catalog-file)) (if (file-exists? default) @@ -3146,6 +3331,8 @@ (parameter/c package-scope/c)] [current-pkg-scope-version (parameter/c string?)] + [current-pkg-lookup-version + (parameter/c string?)] [current-pkg-error (parameter/c procedure?)] [current-pkg-catalogs @@ -3173,6 +3360,7 @@ (->* ((or/c 'zip 'tgz 'plt 'MANIFEST) path-string?) (#:source (or/c 'dir 'name) + #:pkg-name (or/c #f string?) #:mode (or/c 'as-is 'source 'binary 'built) #:quiet? boolean? #:from-command-line? boolean? @@ -3243,7 +3431,15 @@ (#:from-config? any/c #:merge? boolean? #:force? boolean? - #:override? boolean?) + #:override? boolean? + #:relative-sources? boolean?) + void?)] + [pkg-catalog-archive + (->* (path-string? (listof string?)) + (#:from-config? boolean? + #:state-catalog (or/c path-string? #f) + #:relative-sources? boolean? + #:quiet? boolean?) void?)] [default-pkg-scope (-> package-scope/c)] @@ -3258,7 +3454,9 @@ [pkg-stage (->* (pkg-desc?) (#:namespace namespace? #:in-place? boolean? - #:strip (or/c #f 'source 'binary)) + #:strip (or/c #f 'source 'binary) + #:use-cache? boolean? + #:quiet? boolean?) (values string? path? (or/c #f string?) diff --git a/racket/collects/pkg/main.rkt b/racket/collects/pkg/main.rkt index 0a3fb76894..e6ff182cf9 100644 --- a/racket/collects/pkg/main.rkt +++ b/racket/collects/pkg/main.rkt @@ -421,8 +421,8 @@ (parameterize ([current-pkg-catalogs (and catalog (list (catalog->url catalog)))] [current-pkg-error (pkg-error 'catalog-show)] - [current-pkg-scope-version (or version - (current-pkg-scope-version))]) + [current-pkg-lookup-version (or version + (current-pkg-lookup-version))]) (pkg-catalog-show pkg-name #:all? all #:only-names? only-names @@ -437,19 +437,38 @@ [#:bool merge () "Merge to existing database"] #:once-each [#:bool override () "While merging, override existing with new"] + [#:bool relative () "Make source paths relative when possible"] [(#:str vers #f) version ("-v") "Copy information suitable for Racket "] #:args catalog (parameterize ([current-pkg-error (pkg-error 'catalog-copy)]) (when (null? catalog) ((current-pkg-error) "need a destination catalog")) - (parameterize ([current-pkg-scope-version (or version - (current-pkg-scope-version))]) + (parameterize ([current-pkg-lookup-version (or version + (current-pkg-lookup-version))]) (pkg-catalog-copy (drop-right catalog 1) (last catalog) #:from-config? from-config #:force? force #:merge? merge - #:override? override)))]))])) + #:override? override + #:relative-sources? relative)))] + ;; ---------------------------------------- + [catalog-archive + "Copy catalog plus packages" + #:once-each + [#:bool from-config () "Include currently configured catalogs last"] + [(#:str state-database #f) state () "Read/write as state of "] + [(#:str vers #f) version ("-v") "Copy information suitable for Racket "] + [#:bool relative () "Make source paths relative when possible"] + #:args (dest-dir . src-catalog) + (parameterize ([current-pkg-error (pkg-error 'catalog-archive)] + [current-pkg-lookup-version (or version + (current-pkg-lookup-version))]) + (pkg-catalog-archive dest-dir + src-catalog + #:from-config? from-config + #:state-catalog state + #:relative-sources? relative))]))])) (make-commands #:scope-flags ([(#:sym scope [installation user] #f) scope ()