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.
This commit is contained in:
Matthew Flatt
parent
e5d4aed2fb
commit
fdf06e461a
|
|
@ -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"]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)]
|
||||
|
|
|
|||
|
|
@ -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].}
|
||||
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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")))
|
||||
(check-equal? deps2 '("pkg-test1")))
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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)))))
|
||||
|
|
|
|||
|
|
@ -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 string<? #:key db:pkg-name))])
|
||||
(define name (db:pkg-name pkg))
|
||||
(define current-checksum (and state-catalog
|
||||
(parameterize ([db:current-pkg-catalog-file state-catalog])
|
||||
(define l (db:get-pkgs #:name (db:pkg-name pkg)))
|
||||
(and (= 1 (length l))
|
||||
(db:pkg-checksum (car l))))))
|
||||
(unless (and current-checksum
|
||||
(equal? current-checksum (db:pkg-checksum pkg)))
|
||||
(unless quiet?
|
||||
(printf/flush "== Archiving ~a ==\nchecksum: ~a\n" (db:pkg-name pkg) (db:pkg-checksum pkg)))
|
||||
;; Download/unpack existing package:
|
||||
(define-values (staged-name staged-dir staged-checksum clean? staged-mods)
|
||||
(pkg-stage
|
||||
(pkg-desc (db:pkg-source pkg) #f (db:pkg-name pkg) (db:pkg-checksum pkg) #f)
|
||||
#:in-place? #t
|
||||
#:use-cache? #t
|
||||
#:quiet? quiet?))
|
||||
(make-directory* (build-path dest-dir "pkgs"))
|
||||
;; Repack:
|
||||
(pkg-create 'zip
|
||||
staged-dir
|
||||
#:pkg-name name
|
||||
#:dest (build-path dest-dir "pkgs")
|
||||
#:quiet? quiet?)
|
||||
(when clean? (delete-directory/files staged-dir))
|
||||
;; Record packed result:
|
||||
(when state-catalog
|
||||
(parameterize ([db:current-pkg-catalog-file state-catalog])
|
||||
(db:set-pkg! name "local"
|
||||
(db:pkg-author pkg)
|
||||
(db:pkg-source pkg)
|
||||
staged-checksum
|
||||
(db:pkg-desc pkg)))))
|
||||
;; Record packed result:
|
||||
(define pkg-file (build-path dest-dir "pkgs" (format "~a.zip" name)))
|
||||
(define new-checksum
|
||||
(file->string (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?)
|
||||
|
|
|
|||
|
|
@ -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 <vers>"]
|
||||
#: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 <state-database> as state of <dest-dir>"]
|
||||
[(#:str vers #f) version ("-v") "Copy information suitable for Racket <vers>"]
|
||||
[#: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 ()
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user