suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add raco pkg catalog-archive

Browse Source 
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 2014-05-08 09:44:43 -06:00
parent e5d4aed2fb
commit fdf06e461a
10 changed files with 456 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/racket-pkgs/racket-doc/pkg/scribblings/apis.scrbl
View File

@ -40,7 +40,9 @@ to the @exec{raco pkg} sub-subcommands.
@defthing[pkg-create-command procedure?]{Implements @command-ref{create}.} @defthing[pkg-create-command procedure?]{Implements @command-ref{create}.}
@defthing[pkg-catalog-show-command procedure?]{Implements @command-ref{catalog-show}.} @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-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["lib.scrbl"]
@include-section["path.scrbl"] @include-section["path.scrbl"]

9
pkgs/racket-pkgs/racket-doc/pkg/scribblings/catalog-protocol.scrbl
View File

@ -45,7 +45,12 @@ information about packages:
@itemlist[ @itemlist[
@item{@racket['source] (required) --- a @tech{package source} @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 @item{@racket['checksum] (requires) --- a string for a
@tech{checksum}.} @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 @item{A @tt{tags} table with the form
@verbatim[#:indent 2]{(pkg TEXT, @verbatim[#:indent 2]{(pkg TEXT,
catalog TEXT, catalog SMALLINT,
tag TEXT)} tag TEXT)}
where the @tt{pkg} and @tt{catalog} combination identifies a unique where the @tt{pkg} and @tt{catalog} combination identifies a unique

57
pkgs/racket-pkgs/racket-doc/pkg/scribblings/lib.scrbl
View File

@ -42,6 +42,15 @@ Parameters that determine @tech{package scope} for management
operations and, in the case of @racket['user] scope, the relevant operations and, in the case of @racket['user] scope, the relevant
installation name/version.} 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?]{ @defparam[current-pkg-error err procedure?]{
@ -133,7 +142,9 @@ dependency.}
[#:checksum checksum (or/c #f string?) #f] [#:checksum checksum (or/c #f string?) #f]
[#:in-place? in-place? boolean? #f] [#:in-place? in-place? boolean? #f]
[#:namespace namespace namespace? (make-base-namespace)] [#: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?))]{ (values string? path? (or/c #f string?) boolean? (listof module-path?))]{
Locates the implementation of the package specified by @racket[desc] 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 corresponding kind of package. A directory that is staged in-place
cannot be stripped. 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 result is the package name, the directory containing the unpacked package content,
the checksum (if any) for the unpacked package, whether the the checksum (if any) for the unpacked package, whether the
directory should be removed after the package content is no longer 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)] @defproc[(pkg-create [format (or/c 'zip 'tgz 'plt 'MANIFEST)]
[dir path-string?] [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] [#:quiet? quiet? boolean? #f]
[#:from-command-line? from-command-line? boolean? #f]) [#:from-command-line? from-command-line? boolean? #f])
void?]{ void?]{
@ -191,6 +210,7 @@ is true, error messages may suggest specific command-line flags for
[#:update-deps? update-deps? boolean? #f] [#:update-deps? update-deps? boolean? #f]
[#:force? force? boolean? #f] [#:force? force? boolean? #f]
[#:ignore-checksums? ignore-checksums? boolean? #f] [#:ignore-checksums? ignore-checksums? boolean? #f]
[#:use-cache? use-cache? boolean? #t]
[#:quiet? boolean? quiet? #f] [#:quiet? boolean? quiet? #f]
[#:from-command-line? from-command-line? boolean? #f] [#:from-command-line? from-command-line? boolean? #f]
[#:strip strip (or/c #f 'source 'binary) #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] [#:update-deps? update-deps? boolean? #f]
[#:force? force? boolean? #f] [#:force? force? boolean? #f]
[#:ignore-checksums? ignore-checksums? boolean? #f] [#:ignore-checksums? ignore-checksums? boolean? #f]
[#:use-cache? use-cache? quiet? #t]
[#:quiet? boolean? quiet? #f] [#:quiet? boolean? quiet? #f]
[#:from-command-line? from-command-line? boolean? #f] [#:from-command-line? from-command-line? boolean? #f]
[#:strip strip (or/c #f 'source 'binary) #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) (or/c #f 'fail 'force 'search-ask 'search-auto)
#f] #f]
[#:force? force? boolean? #f] [#:force? force? boolean? #f]
[#:use-cache? use-cache? boolean? #t]
[#:ignore-checksums? ignore-checksums? boolean? #f] [#:ignore-checksums? ignore-checksums? boolean? #f]
[#:quiet? boolean? quiet? #f] [#:quiet? boolean? quiet? #f]
[#:from-command-line? from-command-line? boolean? #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, Implements @racket[pkg-catalog-show-command]. If @racket[all?] is true,
then @racket[names] should be empty. then @racket[names] should be empty.
The @racket[current-pkg-scope-version] parameter determines the version The @racket[current-pkg-lookup-version] parameter determines the version
included in the catalog query.} 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?)] @defproc[(pkg-catalog-copy [sources (listof path-string?)]
@ -325,13 +350,33 @@ included in the catalog query.}
[#:from-config? from-config? boolean? #f] [#:from-config? from-config? boolean? #f]
[#:merge? merge? boolean? #f] [#:merge? merge? boolean? #f]
[#:force? force? boolean? #f] [#:force? force? boolean? #f]
[#:override? override? boolean? #f]) [#:override? override? boolean? #f]
[#:relative-sources? relative-sources? boolean? #f])
void?]{ void?]{
Implements @racket[pkg-catalog-copy-command]. Implements @racket[pkg-catalog-copy-command].
The @racket[current-pkg-scope-version] parameter determines the version The @racket[current-pkg-lookup-version] parameter determines the version
for extracting existing catalog information.} 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)] @defproc[(pkg-catalog-update-local [#:catalogs catalogs (listof string?) (pkg-config-catalogs)]

19
pkgs/racket-pkgs/racket-doc/pkg/scribblings/name.scrbl
View File

@ -34,11 +34,24 @@ If a valid name cannot be inferred, the result is @racket[#f].}
@defproc[(package-source->name+type [source string?] @defproc[(package-source->name+type [source string?]
[type (or/c package-source-format? #f) [type (or/c package-source-format? #f) #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?) (values (or/c #f string?)
(or/c package-source-format? #f))]{ (or/c package-source-format? #f))]{
Like @racket[package-source->name], but also returns the type of the 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 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].}

42
pkgs/racket-pkgs/racket-doc/pkg/scribblings/pkg.scrbl
View File

@ -670,7 +670,7 @@ for @nonterm{key}.
} }
@subcommand{@command/toc{catalog-copy} @nonterm{option} ... @nonterm{src-catalog} ... @nonterm{dest-catalog} @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}, to a local database or directory @nonterm{dest-catalog},
which can be used as a new @tech{package catalog}. which can be used as a new @tech{package catalog}.
@ -693,11 +693,42 @@ for @nonterm{key}.
over new information.} over new information.}
@item{@DFlag{override} --- Changes merging so that new information takes precedence @item{@DFlag{override} --- Changes merging so that new information takes precedence
over information already in @nonterm{dest-catalog}.} over information already in @nonterm{dest-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 @item{@DFlag{version} @nonterm{version} or @Flag{v} @nonterm{version} --- Copy catalog
results specific to @nonterm{version} results specific to @nonterm{version}
(for catalogs that make a distinction), instead of the installation's Racket 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} @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 directs all package-name resolution to the snapshot. You can configure
resolution for specific package names by editing the snapshot. 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|?} @subsection{Why is the package manager so different than @|Planet1|?}
There are two fundamental differences between @|Planet1| and this package manager. There are two fundamental differences between @|Planet1| and this package manager.

2
pkgs/racket-pkgs/racket-test/tests/pkg/test-catalogs-api.rkt
View File

@ -2,7 +2,7 @@
(require pkg/lib (require pkg/lib
rackunit) 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) (provide test-api)
(define (test-api) (define (test-api)

50
pkgs/racket-pkgs/racket-test/tests/pkg/tests-catalogs.rkt
View File

@ -3,6 +3,7 @@
(prefix-in db: pkg/db) (prefix-in db: pkg/db)
racket/file racket/file
racket/format racket/format
racket/string
"shelly.rkt" "shelly.rkt"
"util.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-modules! "fish" "local" "123" '((lib "fish/main.rkt") (lib "fish/food.rkt")))
(db:set-pkg-dependencies! "fish" "local" "123" (db:set-pkg-dependencies! "fish" "local" "123"
'("ocean" ("water" "1.0") ("crash-helmet" #:platform windows)))) '("ocean" ("water" "1.0") ("crash-helmet" #:platform windows))))
$ "raco pkg catalog-show fish" =stdout> #rx"Checksum: 123" $ "raco pkg catalog-show fish" =stdout> #rx"Checksum: 123"
$ "raco pkg catalog-show fish" =stdout> #rx"ocean" $ "raco pkg catalog-show fish" =stdout> #rx"ocean"
$ "raco pkg catalog-show fish" =stdout> #rx"water version 1.0" $ "raco pkg catalog-show fish" =stdout> #rx"water version 1.0"
@ -98,6 +100,54 @@
(try-merge dir) (try-merge dir)
(try-merge db) (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" $ "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))) (delete-directory/files d)))

25
racket/collects/pkg/db.rkt
View File

@ -82,14 +82,18 @@
" author TEXT," " author TEXT,"
" source TEXT," " source TEXT,"
" checksum TEXT," " checksum TEXT,"
" desc TEXT)"))) " desc TEXT)")
;; index:
"(name, catalog)"))
(define (prepare-tags-table db) (define (prepare-tags-table db)
(prepare-table db (prepare-table db
"tags" "tags"
(~a "(pkg TEXT," (~a "(pkg TEXT,"
" catalog TEXT," " catalog SMALLINT,"
" tag TEXT)"))) " tag TEXT)")
;; index:
"(pkg, catalog)"))
(define (prepare-modules-table db) (define (prepare-modules-table db)
(prepare-table db (prepare-table db
@ -97,7 +101,9 @@
(~a "(name TEXT," (~a "(name TEXT,"
" pkg TEXT," " pkg TEXT,"
" catalog SMALLINT," " catalog SMALLINT,"
" checksum TEXT)"))) " checksum TEXT)")
;; index:
"(pkg, catalog, checksum)"))
(define (prepare-dependencies-table db) (define (prepare-dependencies-table db)
(prepare-table db (prepare-table db
@ -107,7 +113,9 @@
" onplatform TEXT," " onplatform TEXT,"
" pkg TEXT," " pkg TEXT,"
" catalog SMALLINT," " catalog SMALLINT,"
" checksum TEXT)"))) " checksum TEXT)")
;; index:
"(pkg, catalog, checksum)"))
(define current-pkg-catalog-file (define current-pkg-catalog-file
(make-parameter (build-path (make-parameter (build-path
@ -548,9 +556,12 @@
(pkg-checksum new) (pkg-checksum new)
(pkg-desc new)))))))))) (pkg-desc new))))))))))
(define (prepare-table db which desc) (define (prepare-table db which desc [index #f])
(when (null? (when (null?
(query-rows db (~a "SELECT name FROM sqlite_master" (query-rows db (~a "SELECT name FROM sqlite_master"
" WHERE type='table' AND name='" which "'"))) " WHERE type='table' AND name='" which "'")))
(query-exec db (~a "CREATE TABLE " which " " (query-exec db (~a "CREATE TABLE " which " "
desc)))) desc))
(when index
(query-exec db (~a "CREATE INDEX " which "_index "
"ON " which " " index)))))

284
racket/collects/pkg/lib.rkt
View File

@ -41,6 +41,8 @@
p)))) p))))
(define current-pkg-scope-version (define current-pkg-scope-version
(make-parameter (get-installation-name))) (make-parameter (get-installation-name)))
(define current-pkg-lookup-version
(make-parameter (version)))
(define current-pkg-error (define current-pkg-error
(make-parameter (lambda args (apply error 'pkg args)))) (make-parameter (lambda args (apply error 'pkg args))))
(define current-no-pkg-db (define current-no-pkg-db
@ -417,7 +419,7 @@
[query (append [query (append
(url-query addr/no-query) (url-query addr/no-query)
(list (list
(cons 'version (current-pkg-scope-version))))])) (cons 'version (current-pkg-lookup-version))))]))
;; Take a package-info hash table and lift any version-specific ;; Take a package-info hash table and lift any version-specific
;; information in 'versions. ;; information in 'versions.
@ -426,7 +428,7 @@
(let ([v (hash-ref ht 'versions #f)]) (let ([v (hash-ref ht 'versions #f)])
(cond (cond
[(hash? v) [(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))]) 'default))])
(define ht2 (hash-ref v vers #f)) (define ht2 (hash-ref v vers #f))
(and ht2 (and ht2
@ -437,37 +439,105 @@
ht)] ht)]
[else 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) (define (package-catalog-lookup pkg details? download-printf)
(or (or
(for/or ([i (in-list (pkg-catalogs))]) (for/or ([i (in-list (pkg-catalogs))])
(if download-printf (if download-printf
(download-printf "Resolving ~s via ~a\n" pkg (url->string i)) (download-printf "Resolving ~s via ~a\n" pkg (url->string i))
(log-pkg-debug "consulting catalog ~a" (url->string i))) (log-pkg-debug "consulting catalog ~a" (url->string i)))
(select-info-version (source->absolute-source
(catalog-dispatch i
i (select-info-version
;; Server: (catalog-dispatch
(lambda (i) i
(define addr (add-version-query ;; Server:
(combine-url/relative i (format "pkg/~a" pkg)))) (lambda (i)
(log-pkg-debug "resolving via ~a" (url->string addr)) (define addr (add-version-query
(read-from-server (combine-url/relative i (format "pkg/~a" pkg))))
'package-catalog-lookup (log-pkg-debug "resolving via ~a" (url->string addr))
addr (read-from-server
(lambda (v) (and (hash? v) 'package-catalog-lookup
(for/and ([k (in-hash-keys v)]) addr
(symbol? k)))) (lambda (v) (and (hash? v)
(lambda (s) #f))) (for/and ([k (in-hash-keys v)])
;; Local database: (symbol? k))))
(lambda () (lambda (s) #f)))
(define pkgs (db:get-pkgs #:name pkg)) ;; Local database:
(and (pair? pkgs) (lambda ()
(db-pkg-info (car pkgs) details?))) (define pkgs (db:get-pkgs #:name pkg))
;; Local directory: (and (pair? pkgs)
(lambda (path) (db-pkg-info (car pkgs) details?)))
(define pkg-path (build-path path "pkg" pkg)) ;; Local directory:
(and (file-exists? pkg-path) (lambda (path)
(call-with-input-file* pkg-path read)))))) (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" (pkg-error (~a "cannot find package on catalogs\n"
" package: ~a") " package: ~a")
pkg))) pkg)))
@ -1322,14 +1392,16 @@
(define (pkg-stage desc (define (pkg-stage desc
#:namespace [metadata-ns (make-metadata-namespace)] #:namespace [metadata-ns (make-metadata-namespace)]
#:in-place? [in-place? #f] #: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) (define i (stage-package/info (pkg-desc-source desc)
(pkg-desc-type desc) (pkg-desc-type desc)
(pkg-desc-name desc) (pkg-desc-name desc)
#:given-checksum (pkg-desc-checksum desc) #:given-checksum (pkg-desc-checksum desc)
#:use-cache? #f #:use-cache? use-cache?
#t #t
void (if quiet? void printf)
metadata-ns metadata-ns
#:in-place? in-place? #:in-place? in-place?
#:strip strip-mode)) #:strip strip-mode))
@ -2606,16 +2678,18 @@
(delete-directory/files tmp-dir)))) (delete-directory/files tmp-dir))))
(define (pkg-create create:format dir-or-name (define (pkg-create create:format dir-or-name
#:pkg-name [given-pkg-name #f]
#:dest [dest-dir #f] #:dest [dest-dir #f]
#:source [source 'dir] #:source [source 'dir]
#:mode [mode 'as-is] #:mode [mode 'as-is]
#:quiet? [quiet? #f] #:quiet? [quiet? #f]
#:from-command-line? [from-command-line? #f]) #:from-command-line? [from-command-line? #f])
(define pkg-name (define pkg-name
(if (eq? source 'dir) (or given-pkg-name
(path->string (let-values ([(base name dir?) (split-path dir-or-name)]) (if (eq? source 'dir)
name)) (path->string (let-values ([(base name dir?) (split-path dir-or-name)])
dir-or-name)) name))
dir-or-name)))
(define dir (define dir
(if (eq? source 'dir) (if (eq? source 'dir)
dir-or-name dir-or-name
@ -2646,10 +2720,11 @@
#:from-command-line? from-command-line?)])) #:from-command-line? from-command-line?)]))
(define (pkg-catalog-copy srcs dest (define (pkg-catalog-copy srcs dest
#:from-config? [from-config? #f] #:from-config? [from-config? #f]
#:merge? [merge? #f] #:merge? [merge? #f]
#:force? [force? #f] #:force? [force? #f]
#:override? [override? #f]) #:override? [override? #f]
#:relative-sources? [relative-sources? #f])
(define src-paths (define src-paths
(for/list ([src (in-list (append srcs (for/list ([src (in-list (append srcs
(if from-config? (if from-config?
@ -2663,7 +2738,7 @@
[(regexp-match? #rx"^file://" src) [(regexp-match? #rx"^file://" src)
(url->path (string->url src))] (url->path (string->url src))]
[(regexp-match? #rx"^[a-zA-Z]*://" 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") " URL: ~a")
src)] src)]
[else (path->complete-path src)])) [else (path->complete-path src)]))
@ -2692,6 +2767,13 @@
dest)] dest)]
[else (path->complete-path 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?) (unless (or force? merge?)
(when (or (file-exists? dest-path) (when (or (file-exists? dest-path)
(directory-exists? dest-path) (directory-exists? dest-path)
@ -2700,7 +2782,7 @@
" path: ~a") " path: ~a")
dest-path))) dest-path)))
(define details (define absolute-details
(let ([src-paths (if (and merge? (let ([src-paths (if (and merge?
(or (file-exists? dest-path) (or (file-exists? dest-path)
(directory-exists? dest-path))) (directory-exists? dest-path)))
@ -2715,6 +2797,11 @@
(path->url src-path) (path->url src-path)
src-path))]) src-path))])
(get-all-pkg-details-from-catalogs)))) (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?)) (when (and force? (not merge?))
(cond (cond
@ -2921,7 +3008,7 @@
(for/fold ([ht ht]) ([(k v) (in-hash one-ht)]) (for/fold ([ht ht]) ([(k v) (in-hash one-ht)])
(if (hash-ref ht k #f) (if (hash-ref ht k #f)
ht ht
(hash-set ht k v))))) (hash-set ht k (source->absolute-source i v))))))
(define (extract-pkg-dependencies get-info (define (extract-pkg-dependencies get-info
#:build-deps? [build-deps? #t] #:build-deps? [build-deps? #t]
@ -3100,6 +3187,104 @@
(db:set-pkg-modules! name catalog checksum modules) (db:set-pkg-modules! name catalog checksum modules)
(db:set-pkg-dependencies! name catalog checksum deps))))))) (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 (choose-catalog-file)
(define default (db:current-pkg-catalog-file)) (define default (db:current-pkg-catalog-file))
(if (file-exists? default) (if (file-exists? default)
@ -3146,6 +3331,8 @@
(parameter/c package-scope/c)] (parameter/c package-scope/c)]
[current-pkg-scope-version [current-pkg-scope-version
(parameter/c string?)] (parameter/c string?)]
[current-pkg-lookup-version
(parameter/c string?)]
[current-pkg-error [current-pkg-error
(parameter/c procedure?)] (parameter/c procedure?)]
[current-pkg-catalogs [current-pkg-catalogs
@ -3173,6 +3360,7 @@
(->* ((or/c 'zip 'tgz 'plt 'MANIFEST) (->* ((or/c 'zip 'tgz 'plt 'MANIFEST)
path-string?) path-string?)
(#:source (or/c 'dir 'name) (#:source (or/c 'dir 'name)
#:pkg-name (or/c #f string?)
#:mode (or/c 'as-is 'source 'binary 'built) #:mode (or/c 'as-is 'source 'binary 'built)
#:quiet? boolean? #:quiet? boolean?
#:from-command-line? boolean? #:from-command-line? boolean?
@ -3243,7 +3431,15 @@
(#:from-config? any/c (#:from-config? any/c
#:merge? boolean? #:merge? boolean?
#:force? 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?)] void?)]
[default-pkg-scope [default-pkg-scope
(-> package-scope/c)] (-> package-scope/c)]
@ -3258,7 +3454,9 @@
[pkg-stage (->* (pkg-desc?) [pkg-stage (->* (pkg-desc?)
(#:namespace namespace? (#:namespace namespace?
#:in-place? boolean? #:in-place? boolean?
#:strip (or/c #f 'source 'binary)) #:strip (or/c #f 'source 'binary)
#:use-cache? boolean?
#:quiet? boolean?)
(values string? (values string?
path? path?
(or/c #f string?) (or/c #f string?)

29
racket/collects/pkg/main.rkt
View File

@ -421,8 +421,8 @@
(parameterize ([current-pkg-catalogs (and catalog (parameterize ([current-pkg-catalogs (and catalog
(list (catalog->url catalog)))] (list (catalog->url catalog)))]
[current-pkg-error (pkg-error 'catalog-show)] [current-pkg-error (pkg-error 'catalog-show)]
[current-pkg-scope-version (or version [current-pkg-lookup-version (or version
(current-pkg-scope-version))]) (current-pkg-lookup-version))])
(pkg-catalog-show pkg-name (pkg-catalog-show pkg-name
#:all? all #:all? all
#:only-names? only-names #:only-names? only-names
@ -437,19 +437,38 @@
[#:bool merge () "Merge to existing database"] [#:bool merge () "Merge to existing database"]
#:once-each #:once-each
[#:bool override () "While merging, override existing with new"] [#: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>"] [(#:str vers #f) version ("-v") "Copy information suitable for Racket <vers>"]
#:args catalog #:args catalog
(parameterize ([current-pkg-error (pkg-error 'catalog-copy)]) (parameterize ([current-pkg-error (pkg-error 'catalog-copy)])
(when (null? catalog) (when (null? catalog)
((current-pkg-error) "need a destination catalog")) ((current-pkg-error) "need a destination catalog"))
(parameterize ([current-pkg-scope-version (or version (parameterize ([current-pkg-lookup-version (or version
(current-pkg-scope-version))]) (current-pkg-lookup-version))])
(pkg-catalog-copy (drop-right catalog 1) (pkg-catalog-copy (drop-right catalog 1)
(last catalog) (last catalog)
#:from-config? from-config #:from-config? from-config
#:force? force #:force? force
#:merge? merge #: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 (make-commands
#:scope-flags #:scope-flags
([(#:sym scope [installation user] #f) scope () ([(#:sym scope [installation user] #f) scope ()