raco pkg: support "git://..." and "http[s]://[...].git" sources
Use the `net/git-checkout` library to support git repository servers in general, instead of supporting only GitHub. A HTTP(S) source is treated as a repository source when it ends with the ".git" suffix.
This commit is contained in:
Matthew Flatt
parent
ce464810d5
commit
fbdfa36594
|
|
@ -22,6 +22,7 @@
|
|||
(define sc-install-pkg-dir (string-constant install-pkg-dir))
|
||||
(define sc-install-pkg-dir-url (string-constant install-pkg-dir-url))
|
||||
(define sc-install-pkg-file-url (string-constant install-pkg-file-url))
|
||||
(define sc-install-pkg-git (string-constant install-pkg-git))
|
||||
(define sc-install-pkg-github (string-constant install-pkg-github))
|
||||
(define sc-install-pkg-name (string-constant install-pkg-name))
|
||||
(define sc-install-pkg-inferred-as (string-constant install-pkg-inferred-as))
|
||||
|
|
@ -224,6 +225,7 @@
|
|||
sc-install-pkg-dir
|
||||
sc-install-pkg-file-url
|
||||
sc-install-pkg-dir-url
|
||||
sc-install-pkg-git
|
||||
sc-install-pkg-github
|
||||
sc-install-pkg-name)]))
|
||||
(define link-dir-checkbox (new check-box%
|
||||
|
|
@ -360,14 +362,16 @@
|
|||
[(2) 'dir]
|
||||
[(3) 'file-url]
|
||||
[(4) 'dir-url]
|
||||
[(5) 'github]
|
||||
[(6) 'name]))
|
||||
[(5) 'git]
|
||||
[(6) 'github]
|
||||
[(7) 'name]))
|
||||
|
||||
(define/private (type->str type)
|
||||
(case type
|
||||
[(file) sc-install-pkg-file]
|
||||
[(name) sc-install-pkg-name]
|
||||
[(dir) sc-install-pkg-dir]
|
||||
[(git) sc-install-pkg-git]
|
||||
[(github) sc-install-pkg-github]
|
||||
[(file-url) sc-install-pkg-file-url]
|
||||
[(dir-url) sc-install-pkg-dir-url]
|
||||
|
|
|
|||
|
|
@ -140,7 +140,7 @@ looking for a package.
|
|||
There are other ways to distribute and reference packages. For
|
||||
example, a package can be installed directly from a @filepath{.zip}
|
||||
file---available locally or served from on a web site---or from a
|
||||
Github repository. Such direct references make sense when a package is
|
||||
Git repository. Such direct references make sense when a package is
|
||||
not yet ready for wide distribution or when it will never be of
|
||||
interest to a wide audience. So, you may find non-catalog references
|
||||
in mailing-list posts, recommended by your friends, or advertised in
|
||||
|
|
@ -178,7 +178,7 @@ The argument that you provide to @command-ref{install} does not have
|
|||
to be a package name that is recognized by a @tech{package
|
||||
catalog}. In general, each argument to @command-ref{install} is a
|
||||
@tech{package source}. A @tech{package source} can refer to a
|
||||
@filepath{.zip} file, a @filepath{.tar} file, a Github repository, a
|
||||
@filepath{.zip} file, a @filepath{.tar} file, a Git repository, a
|
||||
directory-structured web site, or a few other possibilities. In each
|
||||
of those cases, a @tech{package name} is inferred from the
|
||||
@tech{package source}. After the package is installed, you use the
|
||||
|
|
@ -191,7 +191,7 @@ implementations. It simply maps each @tech{package name} to a
|
|||
@tech{package catalog}, it gets back a @tech{package source} for the
|
||||
actual package implementation, so each package installed from a
|
||||
@tech{package catalog} is actually installed from a @filepath{.zip}
|
||||
file, Github repository, etc. Registering with a @tech{package
|
||||
file, Git repository, etc. Registering with a @tech{package
|
||||
catalog} is just a way of making your package easier to find and
|
||||
update.
|
||||
|
||||
|
|
@ -214,7 +214,7 @@ name} that was resolved by a @tech{package catalog}, then the
|
|||
@tech{package catalog} is consulted again to get the current
|
||||
@tech{checksum} for the package, and the package is updated if the
|
||||
@tech{checksum} doesn't match the current installation. If the package
|
||||
was installed directly from a Github reference, then Github is
|
||||
was installed directly from a Git reference, then the Git repository is
|
||||
consulted to get the current commit of a particular branch, and the
|
||||
package is updated if the commit identifier doesn't match the
|
||||
@tech{checksum} of the current installation.
|
||||
|
|
@ -263,7 +263,7 @@ supply the @DFlag{demote} flag to @command-ref{remove}.
|
|||
@section[#:tag "how-to-create"]{Creating Packages}
|
||||
|
||||
A package normally starts life as a directory containing module files
|
||||
and grows up to become a Github repository that is registered with a
|
||||
and grows up to become a Git repository that is registered with a
|
||||
@tech{package catalog}.
|
||||
|
||||
So, to create a package, first make a directory and select its name,
|
||||
|
|
@ -369,7 +369,7 @@ on GitHub, then
|
|||
repository for your package}. After that, your @tech{package source}
|
||||
is:
|
||||
|
||||
@inset{@exec{git://github.com/@nonterm{user}/@nonterm{package}}}
|
||||
@inset{@exec{https://github.com/@nonterm{user}/@nonterm{package}.git}}
|
||||
|
||||
If you want the package to be @nonterm{branch} instead of @exec{master},
|
||||
then add @filepath{#@nonterm{branch}} to the end of the package source.
|
||||
|
|
@ -380,7 +380,12 @@ Whenever you
|
|||
|
||||
your changes will automatically be discovered by those who use
|
||||
@exec{raco pkg update} after installing from your
|
||||
github-based @tech{package source}.
|
||||
GitHub-based @tech{package source}.
|
||||
|
||||
As of Racket version 6.1.1.1, other Git repository services can work
|
||||
just as well as GitHub---including Gitorious or BitBucket---as long as
|
||||
the server supports either the ``smart'' HTTP(S) protocol or the
|
||||
native Git protocol (but use a @exec{git://} path for the latter).
|
||||
|
||||
@; - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
|
||||
|
|
@ -431,11 +436,11 @@ You only need to go to this site @emph{once} to list your package. The
|
|||
server will periodically check the package source you designate for
|
||||
updates.
|
||||
|
||||
If you use this server, and if you use GitHub for deployment, then you
|
||||
will never need to open a web browser to update your package for end
|
||||
users. You just need to push to your GitHub repository, then within 24
|
||||
hours, the PLT @tech{package catalog} will notice, and @exec{raco
|
||||
pkg update} will work on your user's machines.
|
||||
If you use this server, and if you use a public Git repository for
|
||||
deployment, then you will never need to open a web browser to update
|
||||
your package for end users. You just need to push to your Git
|
||||
repository, then within 24 hours, the PLT @tech{package catalog} will
|
||||
notice, and @exec{raco pkg update} will work on your user's machines.
|
||||
|
||||
@; - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
|
||||
|
|
@ -539,7 +544,7 @@ Finally, when listing your package on
|
|||
@url{http://pkgs.racket-lang-org}, you should supply a GitHub source
|
||||
using the URL format
|
||||
@tt{github://github.com/@nonterm{user}/@nonterm{repo}/@nonterm{rev}@optional{/@nonterm{path}}} (not
|
||||
the @tt{git:} format).
|
||||
the @tt{git://} or @exec{http://} format).
|
||||
|
||||
@subsubsection{Version Exceptions}
|
||||
|
||||
|
|
@ -550,7 +555,7 @@ when installing a given package using a specific version of Racket.
|
|||
|
||||
For example, a package that uses on Racket 6.0-specific features could provide
|
||||
a @tech{version exception} for Racket 5.3.6 using a different branch in the
|
||||
package's Github repository, or a different zip archive, as package source.
|
||||
package's GitHub repository, or a different zip archive, as package source.
|
||||
Users installing the package from Racket 6.0 will use the default source for
|
||||
the package, while those using Racket 5.3.5 will use the alternative branch /
|
||||
archive.
|
||||
|
|
|
|||
|
|
@ -126,7 +126,7 @@ scope}.}
|
|||
@defproc[(pkg-desc? [v any/c]) boolean?]
|
||||
@defproc[(pkg-desc [source string?]
|
||||
[type (or/c #f 'file 'dir 'link 'static-link
|
||||
'file-url 'dir-url 'github 'name)]
|
||||
'file-url 'dir-url 'git 'github 'name)]
|
||||
[name (or/c string? #f)]
|
||||
[checksum (or/c string? #f)]
|
||||
[auto? boolean?])
|
||||
|
|
|
|||
|
|
@ -14,13 +14,15 @@ extracting a package name.}
|
|||
@defproc[(package-source-format? [v any/c]) boolean?]{
|
||||
|
||||
Returns @racket[#t] if @racket[v] is @racket['name] , @racket['file],
|
||||
@racket['dir], @racket['github], @racket['file-url],
|
||||
@racket['dir], @racket['git], @racket['github], @racket['file-url],
|
||||
@racket['dir-url], @racket['link], or @racket['static-link], and
|
||||
returns @racket[#f] otherwise.
|
||||
|
||||
The @racket['link] and @racket['static-link] formats are the same as
|
||||
@racket['dir] in terms of parsing, but they are treated differently
|
||||
for tasks such as package installation.}
|
||||
for tasks such as package installation.
|
||||
|
||||
@history[#:changed "6.1.1.1" @elem{Added @racket['git].}]}
|
||||
|
||||
|
||||
@defproc[(package-source->name [source string?]
|
||||
|
|
|
|||
|
|
@ -118,6 +118,7 @@ The @tech{package source} types are:
|
|||
|
||||
@itemlist[
|
||||
|
||||
@; ----------------------------------------
|
||||
@item{a local file path naming an archive (as a plain path or @litchar{file://} URL)
|
||||
--- The name of the package
|
||||
is the basename of the archive file. The @tech{checksum} for archive
|
||||
|
|
@ -148,6 +149,7 @@ package name is the filename without its suffix.
|
|||
@elem{Changed treatment of an archive that contains all
|
||||
content within a top-level directory.}]}
|
||||
|
||||
@; ----------------------------------------
|
||||
@item{a local directory (as a plain path or @litchar{file://} URL)
|
||||
--- The name of the package is the name of the
|
||||
directory. The @tech{checksum} is not present.
|
||||
|
|
@ -178,6 +180,7 @@ that could be inferred as a file archive.
|
|||
The inferred package name is from the URL's file name in the same
|
||||
way as for a file package source.}
|
||||
|
||||
@; ----------------------------------------
|
||||
@item{a remote URL naming a directory --- The remote directory must
|
||||
contain a file named @filepath{MANIFEST} that lists all the contingent
|
||||
files. These are downloaded into a local directory and then the rules
|
||||
|
|
@ -192,24 +195,70 @@ source whose @tech{checksum} is found at
|
|||
|
||||
A package source is inferred to be a URL the same for a directory or
|
||||
file, and it is treated as a directory URL when it does not end with a
|
||||
path element that has an archive file suffix. The inferred package name
|
||||
is the directory name.}
|
||||
path element that has an archive file suffix or a @filepath{.git}
|
||||
suffix. The inferred package name is the directory name.
|
||||
|
||||
@item{a remote URL naming a GitHub repository --- The format for such
|
||||
@history[#:changed "6.1.1.1" @elem{Added special-casing of the @filepath{.git} suffix.}]}
|
||||
|
||||
@; ----------------------------------------
|
||||
@item{a remote URL naming a Git repository --- The format for such
|
||||
URLs is:
|
||||
|
||||
@inset{@nonterm{scheme}@exec{://@nonterm{host}/}...@exec{/}@nonterm{repo}@;
|
||||
@optional{@exec{.git}}@optional{@exec{/}}@optional{@exec{?path=}@nonterm{path}}@;
|
||||
@optional{@exec{#}@nonterm{rev}}}
|
||||
|
||||
where @nonterm{scheme} is @litchar{git}, @litchar{http}, or
|
||||
@litchar{https}, and where @nonterm{host} is any address other than
|
||||
@litchar{github.com} (which is treated more specifically as a GitHub
|
||||
reference). The @nonterm{path} can contain multiple
|
||||
@litchar{/}-separated elements to form a path within the repository,
|
||||
and it defaults to the empty path. The @nonterm{rev} can be a branch,
|
||||
tag, or commit, and it defaults to @exec{master}.
|
||||
|
||||
@margin-note{Due to properties of the Git protocol, the archive might
|
||||
be accessed more efficiently when @nonterm{rev} refers to a branch or
|
||||
tag (even if it is written as a commit). In those cases, the content
|
||||
typically can be obtained without downloading irrelevant history.}
|
||||
|
||||
For example, @filepath{http://bitbucket.org/game/tic-tac-toe#master}
|
||||
is a Git package source.
|
||||
|
||||
A checkout of the repository at @nonterm{rev} provides the content of
|
||||
the package, and @nonterm{scheme} determines the protocol
|
||||
that is used to clone the repository. The package's @tech{checksum}
|
||||
is the hash identifying @nonterm{rev} if @nonterm{rev} is a branch or
|
||||
tag, otherwise @nonterm{rev} itself serves as the @tech{checksum}.
|
||||
|
||||
A package source is inferred to be a Git reference when it starts with
|
||||
@litchar{git://} and the host is not @litchar{github.com}. A package
|
||||
source is also inferred to be a Git reference when it starts with
|
||||
@litchar{http://} or @litchar{https://} and the last non-empty path
|
||||
element ends in @litchar{.git}; a @litchar{.git} suffix is added if
|
||||
the source is otherwise specified to be a Git reference. The inferred
|
||||
package name is the last element of @nonterm{path} if it is non-empty,
|
||||
otherwise the inferred name is @nonterm{repo}.
|
||||
|
||||
@history[#:changed "6.1.1.1" @elem{Added Git repository support.}]}
|
||||
|
||||
@; ----------------------------------------
|
||||
@item{a remote URL naming a GitHub repository --- The format for such
|
||||
URLs is the same as for a Git repository reference starting
|
||||
@litchar{git://}, but with @litchar{github.com} as the host:
|
||||
|
||||
@inset{@exec{git://github.com/}@nonterm{user}@exec{/}@nonterm{repo}@;
|
||||
@optional{@exec{.git}}@optional{@exec{/}}@optional{@exec{?path=}@nonterm{path}}@;
|
||||
@optional{@exec{#}@nonterm{rev}}}
|
||||
|
||||
where @nonterm{path} can contain multiple @litchar{/}-separated
|
||||
elements to form a path within the repository, and defaults to the
|
||||
empty path. The @nonterm{rev} can be a branch, tag, or commit, and it
|
||||
defaults to @exec{master}.
|
||||
|
||||
For example, @filepath{git://github.com/game/tic-tac-toe#master}
|
||||
is a GitHub package source.
|
||||
|
||||
@margin-note{A Github repository source that starts with
|
||||
@litchar{git://} obtains the same content that would be accessed if
|
||||
@litchar{github.com} were not treated specially. The special treatment
|
||||
is preserved for historical reasons and because GitHub provides an
|
||||
interface that is always efficient.}
|
||||
|
||||
For backward compatibility, an older format is also supported:
|
||||
|
||||
@inset{@exec{github://github.com/}@nonterm{user}@exec{/}@nonterm{repo}@;
|
||||
|
|
@ -221,13 +270,14 @@ GitHub for any commit) is used as a remote URL archive path. The
|
|||
is a branch or tag, otherwise @nonterm{rev} itself serves as the
|
||||
@tech{checksum}.
|
||||
|
||||
A package source is inferred to be a GitHub reference when it
|
||||
starts with @litchar{git://} or @litchar{github://}; a package source that is otherwise
|
||||
specified as a GitHub reference is automatically prefixed with
|
||||
@filepath{git://github.com/}. The inferred package name
|
||||
is the last element of @nonterm{path} if it is
|
||||
non-empty, otherwise the inferred name is @nonterm{repo}.}
|
||||
A package source is inferred to be a GitHub reference when it starts
|
||||
with @litchar{git://github.com/} or @litchar{github://}; a package
|
||||
source that is otherwise specified as a GitHub reference is
|
||||
automatically prefixed with @litchar{git://github.com/}. The inferred
|
||||
package name is the last element of @nonterm{path} if it is non-empty,
|
||||
otherwise the inferred name is @nonterm{repo}.}
|
||||
|
||||
@; ----------------------------------------
|
||||
@item{a @tech{package name} --- A @tech{package catalog} is
|
||||
consulted to determine the source and @tech{checksum} for the package.
|
||||
|
||||
|
|
@ -342,7 +392,7 @@ sub-commands.
|
|||
@itemlist[
|
||||
|
||||
@item{@DFlag{type} @nonterm{type} or @Flag{t} @nonterm{type} --- specifies an interpretation of the package source,
|
||||
where @nonterm{type} is either @exec{file}, @exec{dir}, @exec{file-url}, @exec{dir-url}, @exec{github},
|
||||
where @nonterm{type} is either @exec{file}, @exec{dir}, @exec{file-url}, @exec{dir-url}, @exec{git}, @exec{github},
|
||||
or @exec{name}.}
|
||||
|
||||
@item{@DFlag{name} @nonterm{pkg} or @Flag{n} @nonterm{pkg} --- specifies the name of the package,
|
||||
|
|
@ -351,7 +401,7 @@ sub-commands.
|
|||
|
||||
@item{@DFlag{checksum} @nonterm{checksum} --- specifies a checksum for the package,
|
||||
which normally makes sense only when a single @nonterm{pkg-source} is provided. The use of
|
||||
@nonterm{checksum} depends on @nonterm{pkg-source}: for a GitHub source, @nonterm{checksum} selects a checksum;
|
||||
@nonterm{checksum} depends on @nonterm{pkg-source}: for a Git or GitHub source, @nonterm{checksum} selects a checksum;
|
||||
for a @tech{package name}, file path, or remote URL as a source, @nonterm{checksum} specifies an expected checksum;
|
||||
for a directory path (including a remote directory URL without a @filepath{.CHECKSUM} file) as a source,
|
||||
@nonterm{checksum} assigns a checksum.}
|
||||
|
|
@ -589,7 +639,7 @@ the given @nonterm{pkg}s.
|
|||
@subcommand{@command/toc{create} @nonterm{option} ... @nonterm{directory-or-package}
|
||||
--- Bundles a package into an archive. Bundling
|
||||
is not needed for a package that is provided directly from a
|
||||
GitHub repository or other non-archive formats. The @exec{create}
|
||||
Git repository or other non-archive formats. The @exec{create}
|
||||
sub-command can create an archive from a directory (the default) or
|
||||
from an installed package. It can also adjust the archive's content
|
||||
to include only sources, only compiled bytecode and rendered documentation,
|
||||
|
|
@ -1051,7 +1101,7 @@ resolution through a @tech{package catalog}.
|
|||
If you want to control the resolution of package names (including
|
||||
specific @tech{checksum}s) but not necessary keep a copy of all package
|
||||
code (assuming that old @tech{checksum}s remain available, such as
|
||||
through Github), you can create a snapshot of the @tech{package name}
|
||||
through GitHub), you can create a snapshot of the @tech{package name}
|
||||
to @tech{package source} mapping by using @command-ref{catalog-copy}.
|
||||
For example,
|
||||
|
||||
|
|
|
|||
|
|
@ -45,8 +45,8 @@
|
|||
(check-equal-values? (parse "ocean/fish.tar.gz" #f) (values "fish" 'file #t))
|
||||
(check-equal-values? (parse "fish.plt" 'file) (values "fish" 'file #t))
|
||||
(check-equal-values? (parse "fish.tar.gz" 'file) (values "fish" 'file #t))
|
||||
(check-equal-values? (parse "fish.other" 'file #rx"archive") (values "fish" 'file #f))
|
||||
(check-equal-values? (parse "fish" 'file #rx"archive") (values "fish" 'file #f))
|
||||
(check-equal-values? (parse "fish.other" 'file #rx"archive") (values #f 'file #f))
|
||||
(check-equal-values? (parse "fish" 'file #rx"archive") (values #f 'file #f))
|
||||
(check-equal-values? (parse "fish!" 'file #rx"archive") (values #f 'file #f))
|
||||
(check-equal-values? (parse "" 'file #rx"ill-formed") (values #f 'file #f))
|
||||
|
||||
|
|
@ -70,10 +70,10 @@
|
|||
(check-equal-values? (parse "http://racket-lang.org/fish.plt" #f) (values "fish" 'file-url #t))
|
||||
(check-equal-values? (parse "https://racket-lang.org/fish.plt" #f) (values "fish" 'file-url #t))
|
||||
(check-equal-values? (parse "http://racket-lang.org/fish.tar.gz" #f) (values "fish" 'file-url #t))
|
||||
(check-equal-values? (parse "http://racket-lang.org/fish" 'file-url #rx"archive") (values "fish" 'file-url #f))
|
||||
(check-equal-values? (parse "http://racket-lang.org/fish" 'file-url #rx"archive") (values #f 'file-url #f))
|
||||
(check-equal-values? (parse "fish.zip" 'file-url) (values "fish" 'file-url #t))
|
||||
(check-equal-values? (parse "dir/fish.zip" 'file-url) (values "fish" 'file-url #t))
|
||||
(check-equal-values? (parse "fish/" 'file-url #rx"archive") (values "fish" 'file-url #f))
|
||||
(check-equal-values? (parse "fish/" 'file-url #rx"archive") (values #f 'file-url #f))
|
||||
(check-equal-values? (parse "http://racket-lang.org/fish!.zip" 'file-url) (values #f 'file-url #t))
|
||||
|
||||
(check-equal-values? (parse "http://racket-lang.org/fish/" #f) (values "fish" 'dir-url #t))
|
||||
|
|
@ -81,6 +81,8 @@
|
|||
(check-equal-values? (parse "http://racket-lang.org/fish" 'dir-url) (values "fish" 'dir-url #t))
|
||||
(check-equal-values? (parse "http://racket-lang.org/fish.plt" 'dir-url) (values #f 'dir-url #t))
|
||||
(check-equal-values? (parse "http://racket-lang.org/fish" #f) (values "fish" 'dir-url #t))
|
||||
(check-equal-values? (parse "http://racket-lang.org/." 'file-url #rx"indicator") (values #f 'file-url #t))
|
||||
(check-equal-values? (parse "http://racket-lang.org/.." 'file-url #rx"indicator") (values #f 'file-url #t))
|
||||
|
||||
(check-equal-values? (parse "github://notgithub.com/racket/fish/master" #f #rx"github.com") (values #f 'github #f))
|
||||
(check-equal-values? (parse "github://github.com/racket/fish/master" #f) (values "fish" 'github #t))
|
||||
|
|
@ -92,8 +94,9 @@
|
|||
(check-equal-values? (parse "github://github.com/racket/fish/master" 'github) (values "fish" 'github #t))
|
||||
(check-equal-values? (parse "github://github.com/fish/master" 'github #rx"three") (values #f 'github #f))
|
||||
(check-equal-values? (parse "github://github.com/racket/fish.more/release" 'github) (values #f 'github #t))
|
||||
(check-equal-values? (parse "github://github.com/racket/./release" #f #rx"indicator") (values #f 'github #f))
|
||||
(check-equal-values? (parse "github://github.com/../fish/release" #f #rx"indicator") (values #f 'github #f))
|
||||
|
||||
(check-equal-values? (parse "git://not-github.com/racket/fish" #f #rx"github.com") (values #f 'github #f))
|
||||
(check-equal-values? (parse "git://github.com/racket/fish" #f) (values "fish" 'github #t))
|
||||
(check-equal-values? (parse "git://github.com/racket/fish/" #f) (values "fish" 'github #t))
|
||||
(check-equal-values? (parse "git://github.com/racket/fish.git" #f) (values "fish" 'github #t))
|
||||
|
|
@ -103,8 +106,34 @@
|
|||
(check-equal-values? (parse "git://github.com/racket/fish?path=catfish#release" #f) (values "catfish" 'github #t))
|
||||
(check-equal-values? (parse "git://github.com/racket/fish?path=catfish/" #f) (values "catfish" 'github #t))
|
||||
(check-equal-values? (parse "git://github.com/racket/fish?path=catfish/bill" #f) (values "bill" 'github #t))
|
||||
(check-equal-values? (parse "git://github.com/racket/fish/?path=catfish/bill" #f) (values "bill" 'github #t))
|
||||
(check-equal-values? (parse "git://github.com/racket/fish/master" 'github #rx"two") (values #f 'github #f))
|
||||
(check-equal-values? (parse "git://github.com/racket/fish.more" 'github) (values #f 'github #t))
|
||||
(check-equal-values? (parse "git://github.com/racket/." #f #rx"indicator") (values #f 'github #f))
|
||||
(check-equal-values? (parse "git://github.com/../fish" #f #rx"indicator") (values #f 'github #f))
|
||||
|
||||
(check-equal-values? (parse "git://not-github.com/racket/fish" #f #f) (values "fish" 'git #t))
|
||||
(check-equal-values? (parse "git://not-github.com/fish" #f #f) (values "fish" 'git #t))
|
||||
(check-equal-values? (parse "git://not-github.com/fish.git" #f #f) (values "fish" 'git #t))
|
||||
(check-equal-values? (parse "git://not-github.com/fish.git/" #f #f) (values "fish" 'git #t))
|
||||
(check-equal-values? (parse "git://not-github.com/" #f #rx"empty") (values #f 'git #f))
|
||||
(check-equal-values? (parse "git://not-github.com/fish.git//" #f #rx"empty") (values #f 'git #f))
|
||||
(check-equal-values? (parse "git://not-github.com/fish#release" #f) (values "fish" 'git #t))
|
||||
(check-equal-values? (parse "git://not-github.com/fish?path=catfish/bill" #f) (values "bill" 'git #t))
|
||||
(check-equal-values? (parse "git://not-github.com/fish/?path=catfish/bill" #f) (values "bill" 'git #t))
|
||||
(check-equal-values? (parse "git://not-github.com/../fish.git/" #f) (values "fish" 'git #t))
|
||||
(check-equal-values? (parse "git://not-github.com/.././" #f #rx"indicator") (values #f 'git #f))
|
||||
|
||||
(check-equal-values? (parse "http://racket-lang.org/racket/fish" 'git #f) (values "fish" 'git #t))
|
||||
(check-equal-values? (parse "https://racket-lang.org/racket/fish" 'git #f) (values "fish" 'git #t))
|
||||
(check-equal-values? (parse "https://racket-lang.org/racket/fish?path=catfish" 'git #f) (values "catfish" 'git #t))
|
||||
(check-equal-values? (parse "http://racket-lang.org/racket/fish.git" 'git #f) (values "fish" 'git #t))
|
||||
(check-equal-values? (parse "http://racket-lang.org/racket/fish.git" #f #f) (values "fish" 'git #t))
|
||||
(check-equal-values? (parse "http://racket-lang.org/racket/fish.git/" 'git #f) (values "fish" 'git #t))
|
||||
(check-equal-values? (parse "http://racket-lang.org/racket/fish.git/" #f #f) (values "fish" 'git #t))
|
||||
(check-equal-values? (parse "http://racket-lang.org/racket/fish.git#release" #f #f) (values "fish" 'git #t))
|
||||
(check-equal-values? (parse "http://racket-lang.org/racket/fish.git?path=catfish" #f #f) (values "catfish" 'git #t))
|
||||
(check-equal-values? (parse "http://racket-lang.org/racket/.." 'git #rx"indicator") (values #f 'git #f))
|
||||
|
||||
(check-equal-values? (parse "racket/fish" 'github) (values "fish" 'github #t))
|
||||
(check-equal-values? (parse "racket/fish.git" 'github) (values "fish" 'github #t))
|
||||
|
|
@ -125,6 +154,7 @@
|
|||
(check-equal-values? (parse "" 'static-link) (values #f 'static-link #f))
|
||||
(check-equal-values? (parse "" 'file-url) (values #f 'file-url #f))
|
||||
(check-equal-values? (parse "" 'dir-url) (values #f 'dir-url #f))
|
||||
(check-equal-values? (parse "" 'git) (values #f 'git #f))
|
||||
(check-equal-values? (parse "" 'github #rx"empty") (values #f 'github #f))
|
||||
|
||||
(void))
|
||||
|
|
|
|||
|
|
@ -2,8 +2,7 @@
|
|||
(require rackunit
|
||||
racket/system
|
||||
racket/match
|
||||
(for-syntax racket/base
|
||||
syntax/parse)
|
||||
racket/format
|
||||
racket/file
|
||||
racket/runtime-path
|
||||
racket/path
|
||||
|
|
@ -16,43 +15,53 @@
|
|||
;; todo: to move the test packages to the "plt" account on GitHub
|
||||
|
||||
(pkg-tests
|
||||
(shelly-begin
|
||||
(shelly-install
|
||||
"remote/github" "git://github.com/mflatt/pkg-test?path=pkg-test1"
|
||||
$ "racket -l racket/base -l pkg-test1/number -e '(number)'" =stdout> "1\n")
|
||||
(shelly-install "remote/github with slash"
|
||||
"git://github.com/mflatt/pkg-test?path=pkg-test1/")
|
||||
(shelly-install
|
||||
"remote/github with auto prefix and with branch"
|
||||
"--type github mflatt/pkg-test?path=pkg-test1/#alt"
|
||||
$ "racket -l racket/base -l pkg-test1/number -e '(number)'" =stdout> "10\n")
|
||||
(shelly-install
|
||||
"remote/github with tag"
|
||||
"git://github.com/mflatt/pkg-test?path=pkg-test1/#hundred"
|
||||
$ "racket -l racket/base -l pkg-test1/number -e '(number)'" =stdout> "100\n")
|
||||
(shelly-install
|
||||
"remote/github with commit"
|
||||
"git://github.com/mflatt/pkg-test?path=pkg-test1/#f9b4eef22"
|
||||
$ "racket -l racket/base -l pkg-test1/number -e '(number)'" =stdout> "100\n")
|
||||
(shelly-install
|
||||
"remote/github with checksum"
|
||||
"--checksum f9b4eef22cdd9ab88b254cb027fc1ebe7fb596fd git://github.com/mflatt/pkg-test?path=pkg-test1"
|
||||
$ "racket -l racket/base -l pkg-test1/number -e '(number)'" =stdout> "100\n"
|
||||
$ "raco pkg update pkg-test1"
|
||||
$ "racket -l racket/base -l pkg-test1/number -e '(number)'" =stdout> "1\n")
|
||||
|
||||
(hash-set! *index-ht-1* "pkg-test1-github-different-checksum"
|
||||
(hasheq 'checksum
|
||||
"f9b4eef22cdd9ab88b254cb027fc1ebe7fb596fd"
|
||||
'source
|
||||
"git://github.com/mflatt/pkg-test?path=pkg-test1"))
|
||||
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"remote/name package"
|
||||
$ "raco pkg config --set catalogs http://localhost:9990"
|
||||
$ "racket -l pkg-test1/number" =exit> 1
|
||||
$ "raco pkg install pkg-test1-github-different-checksum"
|
||||
(define (test-remote url)
|
||||
(shelly-begin
|
||||
(shelly-install "remote/git"
|
||||
(~a url "?path=pkg-test1")
|
||||
$ "racket -l racket/base -l pkg-test1/number -e '(number)'" =stdout> "1\n")
|
||||
(shelly-install "remote/git with slash"
|
||||
(~a url "?path=pkg-test1/"))
|
||||
(shelly-install
|
||||
"remote/git with tag"
|
||||
(~a url "?path=pkg-test1/#hundred")
|
||||
$ "racket -l racket/base -l pkg-test1/number -e '(number)'" =stdout> "100\n")
|
||||
(shelly-install
|
||||
"remote/git with commit"
|
||||
(~a url "?path=pkg-test1/#f9b4eef22")
|
||||
$ "racket -l racket/base -l pkg-test1/number -e '(number)'" =stdout> "100\n")
|
||||
(shelly-install
|
||||
"remote/git with checksum"
|
||||
(~a "--checksum f9b4eef22cdd9ab88b254cb027fc1ebe7fb596fd " url "?path=pkg-test1")
|
||||
$ "racket -l racket/base -l pkg-test1/number -e '(number)'" =stdout> "100\n"
|
||||
$ "raco pkg remove pkg-test1-github-different-checksum"
|
||||
$ "racket -l pkg-test1/number" =exit> 1))))
|
||||
$ "raco pkg update pkg-test1"
|
||||
$ "racket -l racket/base -l pkg-test1/number -e '(number)'" =stdout> "1\n")
|
||||
|
||||
(hash-set! *index-ht-1* "pkg-test1-git-different-checksum"
|
||||
(hasheq 'checksum
|
||||
"f9b4eef22cdd9ab88b254cb027fc1ebe7fb596fd"
|
||||
'source
|
||||
(~a url "?path=pkg-test1")))
|
||||
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"remote/name package"
|
||||
$ "raco pkg config --set catalogs http://localhost:9990"
|
||||
$ "racket -l pkg-test1/number" =exit> 1
|
||||
$ "raco pkg install pkg-test1-git-different-checksum"
|
||||
$ "racket -l racket/base -l pkg-test1/number -e '(number)'" =stdout> "100\n"
|
||||
$ "raco pkg remove pkg-test1-git-different-checksum"
|
||||
$ "racket -l pkg-test1/number" =exit> 1))))
|
||||
|
||||
(test-remote "git://github.com/mflatt/pkg-test")
|
||||
(test-remote "https://github.com/mflatt/pkg-test.git")
|
||||
(test-remote "https://bitbucket.org/mflatt/pkg-test.git")
|
||||
|
||||
(shelly-install
|
||||
"remote/github with auto prefix and with branch"
|
||||
"--type github mflatt/pkg-test?path=pkg-test1/#alt"
|
||||
$ "racket -l racket/base -l pkg-test1/number -e '(number)'" =stdout> "10\n")
|
||||
(shelly-install
|
||||
"remote/git type"
|
||||
"--type git https://bitbucket.org/mflatt/pkg-test?path=pkg-test1#alt"
|
||||
$ "racket -l racket/base -l pkg-test1/number -e '(number)'" =stdout> "10\n"))
|
||||
|
|
|
|||
|
|
@ -1828,6 +1828,7 @@ please adhere to these guidelines:
|
|||
(install-pkg-dir "Directory")
|
||||
(install-pkg-dir-url "Remote Directory")
|
||||
(install-pkg-file-url "Remote File")
|
||||
(install-pkg-git "Git Repository")
|
||||
(install-pkg-github "Github")
|
||||
(install-pkg-name "Name (consulting resolver)")
|
||||
(install-pkg-inferred-as "Type inferred to be ~a") ; ~a gets install-pkg-{file,dir,...}
|
||||
|
|
|
|||
|
|
@ -59,7 +59,7 @@
|
|||
(-> string? (or/c path-string? #f))]
|
||||
[pkg-desc
|
||||
(-> string?
|
||||
(or/c #f 'file 'dir 'link 'static-link 'file-url 'dir-url 'github 'name)
|
||||
(or/c #f 'file 'dir 'link 'static-link 'file-url 'dir-url 'git 'github 'name)
|
||||
(or/c string? #f)
|
||||
(or/c string? #f)
|
||||
boolean?
|
||||
|
|
|
|||
|
|
@ -520,9 +520,9 @@
|
|||
#:catalog-flags
|
||||
([(#:str catalog #f) catalog () "Use <catalog> instead of configured catalogs"])
|
||||
#:install-type-flags
|
||||
([(#:sym type [file dir file-url dir-url github name] #f) type ("-t")
|
||||
([(#:sym type [file dir file-url dir-url git github name] #f) type ("-t")
|
||||
("Type of <pkg-source>;"
|
||||
"valid <types>s are: file, dir, file-url, dir-url, github, or name;"
|
||||
"valid <types>s are: file, dir, file-url, dir-url, git, github, or name;"
|
||||
"if not specified, the type is inferred syntactically")]
|
||||
[(#:str name #f) name ("-n") ("Name of package, instead of inferred"
|
||||
"(makes sense only when a single <pkg-source> is given)")]
|
||||
|
|
|
|||
|
|
@ -22,9 +22,10 @@
|
|||
|
||||
(define rx:package-name #rx"^[-_a-zA-Z0-9]+$")
|
||||
(define rx:archive #rx"[.](plt|zip|tar|tgz|tar[.]gz)$")
|
||||
(define rx:git #rx"[.]git$")
|
||||
|
||||
(define package-source-format?
|
||||
(or/c 'name 'file 'dir 'github 'file-url 'dir-url 'link 'static-link))
|
||||
(or/c 'name 'file 'dir 'git 'github 'file-url 'dir-url 'link 'static-link))
|
||||
|
||||
(define (validate-name name complain inferred?)
|
||||
(and name
|
||||
|
|
@ -42,12 +43,11 @@
|
|||
|
||||
(define (extract-archive-name name+ext complain)
|
||||
(validate-name
|
||||
(path->string
|
||||
(if (regexp-match #rx#"[.]tar[.]gz$" (if (path? name+ext)
|
||||
(path->bytes name+ext)
|
||||
name+ext))
|
||||
(path-replace-suffix (path-replace-suffix name+ext #"") #"")
|
||||
(path-replace-suffix name+ext #"")))
|
||||
(and name+ext
|
||||
(path->string
|
||||
(if (regexp-match #rx#"[.]tar[.]gz$" name+ext)
|
||||
(path-replace-suffix (path-replace-suffix name+ext #"") #"")
|
||||
(path-replace-suffix name+ext #""))))
|
||||
complain
|
||||
#t))
|
||||
|
||||
|
|
@ -58,6 +58,26 @@
|
|||
(and (not (equal? "" (path/param-path (car p))))
|
||||
(path/param-path (car p))))]))
|
||||
|
||||
(define (num-empty p)
|
||||
(let loop ([p (reverse p)])
|
||||
(cond
|
||||
[(null? p) 0]
|
||||
[else (if (equal? "" (path/param-path (car p)))
|
||||
(add1 (loop (cdr p)))
|
||||
0)])))
|
||||
|
||||
(define (extract-git-name url p complain-name)
|
||||
(let ([a (assoc 'path (url-query url))])
|
||||
(define sub (and a (cdr a) (string-split (cdr a) "/")))
|
||||
(if (pair? sub)
|
||||
(validate-name (last sub) complain-name #t)
|
||||
(let ([s (last-non-empty p)])
|
||||
(validate-name (regexp-replace #rx"[.]git$" s "") complain-name #t)))))
|
||||
|
||||
(define (string-and-regexp-match? rx s)
|
||||
(and (string? s)
|
||||
(regexp-match? rx s)))
|
||||
|
||||
(define-syntax-rule (cor v complain)
|
||||
(or v (begin complain #f)))
|
||||
|
||||
|
|
@ -78,14 +98,16 @@
|
|||
(eq? type 'file)
|
||||
(and (path-string? s)
|
||||
(regexp-match rx:archive s)))
|
||||
(unless (path-string? s)
|
||||
(complain "ill-formed path"))
|
||||
(unless (regexp-match rx:archive s)
|
||||
(complain "path does not end with a recognized archive suffix"))
|
||||
(define-values (base name+ext dir?) (if (path-string? s)
|
||||
(split-path s)
|
||||
(values #f #f #f)))
|
||||
(define name (and name+ext (extract-archive-name name+ext complain-name)))
|
||||
(define name
|
||||
(and (cor (path-string? s)
|
||||
(complain "ill-formed path"))
|
||||
(cor (regexp-match rx:archive s)
|
||||
(complain "path does not end with a recognized archive suffix"))
|
||||
(let ()
|
||||
(define-values (base name+ext dir?) (if (path-string? s)
|
||||
(split-path s)
|
||||
(values #f #f #f)))
|
||||
(extract-archive-name name+ext complain-name))))
|
||||
(values name 'file)]
|
||||
[(if type
|
||||
(or (eq? type 'dir)
|
||||
|
|
@ -111,8 +133,7 @@
|
|||
[(if type
|
||||
(eq? type 'name)
|
||||
(regexp-match? rx:package-name s))
|
||||
(validate-name s complain #f)
|
||||
(values (and (regexp-match? rx:package-name s) s) 'name)]
|
||||
(values (validate-name s complain #f) 'name)]
|
||||
[(and (eq? type 'github)
|
||||
(not (regexp-match? #rx"^git(?:hub)?://" s)))
|
||||
(package-source->name+type
|
||||
|
|
@ -120,6 +141,7 @@
|
|||
'github)]
|
||||
[(if type
|
||||
(or (eq? type 'github)
|
||||
(eq? type 'git)
|
||||
(eq? type 'file-url)
|
||||
(eq? type 'dir-url))
|
||||
(regexp-match? #rx"^(https?|github|git)://" s))
|
||||
|
|
@ -136,66 +158,98 @@
|
|||
(unless (or (equal? (url-scheme url) "github")
|
||||
(equal? (url-scheme url) "git"))
|
||||
(complain "URL scheme is not 'git' or 'github'"))
|
||||
(define github?
|
||||
(or (eq? type 'github)
|
||||
(equal? (url-scheme url) "github")
|
||||
(equal? (url-host url) "github.com")))
|
||||
(define name
|
||||
(and (cor (pair? p)
|
||||
(complain "URL path is empty"))
|
||||
(cor (equal? "github.com" (url-host url))
|
||||
(complain "URL host is not 'github.com'"))
|
||||
(or (not github?)
|
||||
(cor (equal? "github.com" (url-host url))
|
||||
(complain "URL host is not 'github.com'")))
|
||||
(if (equal? (url-scheme url) "git")
|
||||
;; git://
|
||||
(and (cor (or (= (length p) 2)
|
||||
(and (= (length p) 3)
|
||||
(equal? "" (path/param-path (caddr p)))))
|
||||
(complain "URL does not have two path elements (name and repo)"))
|
||||
(let ([a (assoc 'path (url-query url))])
|
||||
(define sub (and a (cdr a) (string-split (cdr a) "/")))
|
||||
(if (pair? sub)
|
||||
(validate-name (last sub) complain-name #t)
|
||||
(let ([s (path/param-path (cadr p))])
|
||||
(validate-name (regexp-replace #rx"[.]git$" s "") complain-name #t)))))
|
||||
(and (if github?
|
||||
(and
|
||||
(cor (or (= (length p) 2)
|
||||
(and (= (length p) 3)
|
||||
(equal? "" (path/param-path (caddr p)))))
|
||||
(complain "URL does not have two path elements (name and repo)"))
|
||||
(cor (and (string? (path/param-path (car p)))
|
||||
(string? (path/param-path (cadr p))))
|
||||
(complain "URL includes a directory indicator as an element")))
|
||||
(and
|
||||
(cor (last-non-empty p)
|
||||
(complain "URL path is empty"))
|
||||
(cor (string? (last-non-empty p))
|
||||
(complain "URL path ends with a directory indicator"))
|
||||
(cor ((num-empty p) . < . 2)
|
||||
(complain "URL path ends with two empty elements"))))
|
||||
(extract-git-name url p complain-name))
|
||||
;; github://
|
||||
(let ([p (if (equal? "" (path/param-path (last p)))
|
||||
(reverse (cdr (reverse p)))
|
||||
p)])
|
||||
(and (cor ((length p) . >= . 3)
|
||||
(complain "URL does not have at least three path elements"))
|
||||
(cor (andmap string? (map path/param-path p))
|
||||
(complain "URL includes a directory indicator"))
|
||||
(validate-name
|
||||
(if (= (length p) 3)
|
||||
(path/param-path (second (reverse p)))
|
||||
(last-non-empty p))
|
||||
complain-name
|
||||
#t))))))
|
||||
(values name (or type 'github))]
|
||||
(values name (or type
|
||||
(if github?
|
||||
'github
|
||||
'git)))]
|
||||
[(if type
|
||||
(eq? type 'file-url)
|
||||
(and (pair? p)
|
||||
(path/param? (last p))
|
||||
(regexp-match? rx:archive (path/param-path (last p)))))
|
||||
(unless (pair? p)
|
||||
(complain "URL path is empty"))
|
||||
(when (pair? p)
|
||||
(unless (path/param? (last p))
|
||||
(complain "URL's last path element is missing"))
|
||||
(unless (regexp-match? rx:archive (path/param-path (last p)))
|
||||
(complain "URL does not end with a recognized archive suffix")))
|
||||
(values (and (pair? p)
|
||||
(extract-archive-name (last-non-empty p) complain-name))
|
||||
'file-url)]
|
||||
(string-and-regexp-match? rx:archive (path/param-path (last p)))))
|
||||
(define name
|
||||
(and (cor (pair? p)
|
||||
(complain "URL path is empty"))
|
||||
(cor (string-and-regexp-match? rx:archive (path/param-path (last p)))
|
||||
(complain "URL does not end with a recognized archive suffix"))
|
||||
(extract-archive-name (last-non-empty p) complain-name)))
|
||||
(values name 'file-url)]
|
||||
[(if type
|
||||
(eq? type 'git)
|
||||
(and (last-non-empty p)
|
||||
(string-and-regexp-match? rx:git (last-non-empty p))
|
||||
((num-empty p) . < . 2)))
|
||||
(define name
|
||||
(and (cor (last-non-empty p)
|
||||
(complain "URL path is empty"))
|
||||
(cor ((num-empty p) . < . 2)
|
||||
(complain "URL path ends with two empty elements"))
|
||||
(cor (string? (last-non-empty p))
|
||||
(complain "URL path ends with a directory indicator"))
|
||||
(extract-git-name url p complain-name)))
|
||||
(values name 'git)]
|
||||
[else
|
||||
(unless (pair? p)
|
||||
(complain "URL path is empty"))
|
||||
(when (pair? p)
|
||||
(unless (path/param? (last p))
|
||||
(complain "URL's last path element is missing")))
|
||||
(values (validate-name (last-non-empty p) complain-name #t) 'dir-url)]))
|
||||
(define name
|
||||
(and (cor (pair? p)
|
||||
(complain "URL path is empty"))
|
||||
(cor (last-non-empty p)
|
||||
(complain "URL has no non-empty path"))
|
||||
(cor (string? (last-non-empty p))
|
||||
(complain "URL's last path element is a directory indicator"))
|
||||
(validate-name (last-non-empty p) complain-name #t)))
|
||||
(values name 'dir-url)]))
|
||||
(values #f #f)))
|
||||
(values (validate-name name complain-name #f) (or type (and name-type)))]
|
||||
(values (validate-name name complain-name #f)
|
||||
(or type (and name-type)))]
|
||||
[(and (not type)
|
||||
(regexp-match #rx"^file://(.*)$" s))
|
||||
=> (lambda (m) (parse-path (cadr m)))]
|
||||
[(and (not type)
|
||||
(regexp-match? #rx"^[a-zA-Z]*://" s))
|
||||
(complain "unreognized URL scheme")
|
||||
(complain "unrecognized URL scheme")
|
||||
(values #f #f)]
|
||||
[else
|
||||
(parse-path s)]))
|
||||
|
|
|
|||
|
|
@ -4,12 +4,17 @@
|
|||
racket/match
|
||||
racket/port
|
||||
racket/format
|
||||
racket/file
|
||||
file/tar
|
||||
file/untgz
|
||||
net/git-checkout
|
||||
"path.rkt"
|
||||
"print.rkt"
|
||||
"config.rkt")
|
||||
|
||||
(provide call/input-url+200
|
||||
download-file!
|
||||
download-repo!
|
||||
url-path/no-slash
|
||||
clean-cache)
|
||||
|
||||
|
|
@ -35,6 +40,25 @@
|
|||
rest]
|
||||
[_ rp])))
|
||||
|
||||
(define (do-cache-file file url checksum use-cache? download-printf download!)
|
||||
(cond
|
||||
[(and use-cache? checksum)
|
||||
(cache-file file
|
||||
#:exists-ok? #t
|
||||
(list (url->string url) checksum)
|
||||
(get-download-cache-dir)
|
||||
download!
|
||||
#:log-error-string (lambda (s) (log-pkg-error s))
|
||||
#:log-debug-string (lambda (s) (log-pkg-debug s))
|
||||
#:notify-cache-use (lambda (s)
|
||||
(when download-printf
|
||||
(download-printf "Using ~a for ~a\n"
|
||||
s
|
||||
(url->string url))))
|
||||
#:max-cache-files (get-download-cache-max-files)
|
||||
#:max-cache-size (get-download-cache-max-bytes))]
|
||||
[else (download!)]))
|
||||
|
||||
(define (download-file! url file checksum
|
||||
#:download-printf [download-printf #f]
|
||||
#:use-cache? [use-cache? #t]
|
||||
|
|
@ -48,34 +72,21 @@
|
|||
(define (download!)
|
||||
(when download-printf
|
||||
(download-printf "Downloading ~a\n" (url->string url)))
|
||||
(call-with-output-file file
|
||||
(λ (op)
|
||||
(call/input-url+200
|
||||
url
|
||||
(λ (ip) (copy-port ip op))
|
||||
#:failure
|
||||
(lambda (reply-s)
|
||||
(pkg-error (~a "error downloading package\n"
|
||||
" URL: ~a\n"
|
||||
" server response: ~a")
|
||||
(url->string url)
|
||||
(read-line (open-input-string reply-s))))))))
|
||||
(cond
|
||||
[(and checksum use-cache?)
|
||||
(cache-file file
|
||||
(list (url->string url) checksum)
|
||||
(get-download-cache-dir)
|
||||
download!
|
||||
#:log-error-string (lambda (s) (log-pkg-error s))
|
||||
#:log-debug-string (lambda (s) (log-pkg-debug s))
|
||||
#:notify-cache-use (lambda (s)
|
||||
(when download-printf
|
||||
(download-printf "Using ~a for ~a\n"
|
||||
s
|
||||
(url->string url))))
|
||||
#:max-cache-files (get-download-cache-max-files)
|
||||
#:max-cache-size (get-download-cache-max-bytes))]
|
||||
[else (download!)])))
|
||||
(call-with-output-file*
|
||||
file
|
||||
#:exists 'truncate/replace
|
||||
(λ (op)
|
||||
(call/input-url+200
|
||||
url
|
||||
(λ (ip) (copy-port ip op))
|
||||
#:failure
|
||||
(lambda (reply-s)
|
||||
(pkg-error (~a "error downloading package\n"
|
||||
" URL: ~a\n"
|
||||
" server response: ~a")
|
||||
(url->string url)
|
||||
(read-line (open-input-string reply-s))))))))
|
||||
(do-cache-file file url checksum use-cache? download-printf download!)))
|
||||
|
||||
(define (clean-cache pkg-url checksum)
|
||||
(when pkg-url
|
||||
|
|
@ -85,3 +96,32 @@
|
|||
(get-download-cache-dir)
|
||||
#:log-error-string (lambda (s) (log-pkg-error s))
|
||||
#:log-debug-string (lambda (s) (log-pkg-debug s))))))
|
||||
|
||||
|
||||
(define (download-repo! url host repo dest-dir checksum
|
||||
#:download-printf [download-printf #f]
|
||||
#:use-cache? [use-cache? #t])
|
||||
(log-pkg-debug "\t\tDownloading ~a to ~a" (url->string url) dest-dir)
|
||||
(define tmp.tgz
|
||||
(make-temporary-file "~a-repo.tgz" #f))
|
||||
(define unpacked? #f)
|
||||
|
||||
(define (download!)
|
||||
(git-checkout host repo
|
||||
#:dest-dir dest-dir
|
||||
#:ref checksum
|
||||
#:status-printf (or download-printf void)
|
||||
#:transport (string->symbol (url-scheme url)))
|
||||
(set! unpacked? #t)
|
||||
;; package directory as ".tgz" so it can be cached:
|
||||
(parameterize ([current-directory dest-dir])
|
||||
(apply tar-gzip tmp.tgz
|
||||
#:exists-ok? #t
|
||||
(directory-list))))
|
||||
|
||||
(do-cache-file tmp.tgz url checksum use-cache? download-printf download!)
|
||||
|
||||
(unless unpacked?
|
||||
(untgz tmp.tgz #:dest dest-dir))
|
||||
|
||||
(delete-file tmp.tgz))
|
||||
|
|
|
|||
|
|
@ -32,9 +32,9 @@
|
|||
|
||||
(define (checksum-for-pkg-source pkg-source type pkg-name given-checksum download-printf)
|
||||
(case type
|
||||
[(file-url dir-url github)
|
||||
[(file-url dir-url github git)
|
||||
(or given-checksum
|
||||
(remote-package-checksum `(url ,pkg-source) download-printf pkg-name))]
|
||||
(remote-package-checksum `(url ,pkg-source) download-printf pkg-name #:type type))]
|
||||
[(file)
|
||||
(define checksum-pth (format "~a.CHECKSUM" pkg-source))
|
||||
(or (and (file-exists? checksum-pth)
|
||||
|
|
|
|||
|
|
@ -13,6 +13,7 @@
|
|||
file/unzip
|
||||
openssl/sha1
|
||||
json
|
||||
net/git-checkout
|
||||
"../name.rkt"
|
||||
"../strip.rkt"
|
||||
"catalog.rkt"
|
||||
|
|
@ -33,12 +34,13 @@
|
|||
|
||||
(struct install-info (name orig-pkg directory clean? checksum module-paths additional-installs))
|
||||
|
||||
(define (remote-package-checksum pkg download-printf pkg-name)
|
||||
(define (remote-package-checksum pkg download-printf pkg-name #:type [type #f])
|
||||
(match pkg
|
||||
[`(catalog ,pkg-name)
|
||||
(hash-ref (package-catalog-lookup pkg-name #f download-printf) 'checksum)]
|
||||
[`(url ,pkg-url-str)
|
||||
(package-url->checksum pkg-url-str
|
||||
(package-url->checksum pkg-url-str
|
||||
#:type type
|
||||
#:download-printf download-printf
|
||||
#:pkg-name pkg-name)]))
|
||||
|
||||
|
|
@ -90,11 +92,15 @@
|
|||
metadata-ns
|
||||
#:strip strip-mode
|
||||
#:force-strip? force-strip?)]
|
||||
[(or (eq? type 'file-url) (eq? type 'dir-url) (eq? type 'github))
|
||||
(define pkg-url (string->url pkg))
|
||||
[(or (eq? type 'file-url)
|
||||
(eq? type 'dir-url)
|
||||
(eq? type 'github)
|
||||
(eq? type 'git))
|
||||
(define pkg-url-str (normalize-url type pkg (string->url pkg)))
|
||||
(define pkg-url (string->url pkg-url-str))
|
||||
(define scheme (url-scheme pkg-url))
|
||||
|
||||
(define orig-pkg `(url ,pkg))
|
||||
(define orig-pkg `(url ,pkg-url-str))
|
||||
(define found-checksum
|
||||
;; If a checksum is given, use that. In the case of a non-github
|
||||
;; source, we could try to get the checksum from the source, and
|
||||
|
|
@ -107,6 +113,55 @@
|
|||
(define checksum (or found-checksum given-checksum))
|
||||
(define downloaded-info
|
||||
(match type
|
||||
['git
|
||||
(when (equal? checksum "")
|
||||
(pkg-error
|
||||
(~a "cannot use empty checksum for Git repostory package source\n"
|
||||
" source: ~a")
|
||||
pkg))
|
||||
(define-values (host repo branch path) (split-git-url pkg-url))
|
||||
(define tmp-dir
|
||||
(make-temporary-file
|
||||
(string-append
|
||||
"~a-"
|
||||
(regexp-replace* #rx"[:/\\.]" (format "~a.~a" repo branch) "_"))
|
||||
'directory))
|
||||
|
||||
(define staged? #f)
|
||||
(dynamic-wind
|
||||
void
|
||||
(λ ()
|
||||
(download-repo! pkg-url host repo tmp-dir checksum
|
||||
#:use-cache? use-cache?
|
||||
#:download-printf download-printf)
|
||||
(unless (null? path)
|
||||
(unless (directory-exists? (apply build-path tmp-dir path))
|
||||
(pkg-error
|
||||
(~a "specified directory is not in Git respository\n"
|
||||
" path: ~a")
|
||||
(apply build-path path)))
|
||||
(lift-directory-content tmp-dir path))
|
||||
|
||||
(begin0
|
||||
(stage-package/info tmp-dir
|
||||
'dir
|
||||
pkg-name
|
||||
#:given-checksum checksum
|
||||
#:cached-url pkg-url
|
||||
#:use-cache? use-cache?
|
||||
check-sums?
|
||||
download-printf
|
||||
metadata-ns
|
||||
#:strip strip-mode
|
||||
#:force-strip? force-strip?
|
||||
#:in-place? #t
|
||||
#:in-place-clean? #t)
|
||||
(set! staged? #t)))
|
||||
(λ ()
|
||||
(when (and use-cache? (not staged?))
|
||||
(clean-cache pkg-url checksum))
|
||||
(unless staged?
|
||||
(delete-directory/files tmp-dir))))]
|
||||
['github
|
||||
(unless checksum
|
||||
(pkg-error
|
||||
|
|
@ -132,7 +187,6 @@
|
|||
"~a-"
|
||||
(format "~a.~a.tgz" repo branch))
|
||||
#f))
|
||||
(delete-file tmp.tgz)
|
||||
(define tmp-dir
|
||||
(make-temporary-file
|
||||
(string-append
|
||||
|
|
@ -156,8 +210,8 @@
|
|||
(unless (directory-exists? (apply build-path tmp-dir path))
|
||||
(pkg-error
|
||||
(~a "specified directory is not in GitHub respository archive\n"
|
||||
" path: ~a"
|
||||
(apply build-path path))))
|
||||
" path: ~a")
|
||||
(apply build-path path)))
|
||||
(lift-directory-content tmp-dir path))
|
||||
|
||||
(begin0
|
||||
|
|
@ -476,12 +530,26 @@
|
|||
;; ----------------------------------------
|
||||
|
||||
(define (package-url->checksum pkg-url-str [query empty]
|
||||
#:type [given-type #f]
|
||||
#:download-printf [download-printf void]
|
||||
#:pkg-name [pkg-name "package"])
|
||||
(define pkg-url
|
||||
(string->url pkg-url-str))
|
||||
(match (url-scheme pkg-url)
|
||||
[(or "github" "git")
|
||||
(define type (or given-type
|
||||
(let-values ([(name type) (package-source->name+type pkg-url-str given-type)])
|
||||
type)))
|
||||
(case type
|
||||
[(git)
|
||||
(define-values (host repo branch path)
|
||||
(split-git-url pkg-url))
|
||||
;; supplying `#:dest-dir #f` means that we just resolve `branch`
|
||||
;; to an ID:
|
||||
(git-checkout host repo
|
||||
#:dest-dir #f
|
||||
#:ref branch
|
||||
#:status-printf download-printf
|
||||
#:transport (string->symbol (url-scheme pkg-url)))]
|
||||
[(github)
|
||||
(match-define (list* user repo branch path)
|
||||
(split-github-url pkg-url))
|
||||
(or
|
||||
|
|
@ -525,7 +593,7 @@
|
|||
;; syntax of a commit id, then assume that it refers to a commit
|
||||
(and (regexp-match? #rx"[a-f0-9]+" branch)
|
||||
branch))]
|
||||
[_
|
||||
[else
|
||||
(define u (string-append pkg-url-str ".CHECKSUM"))
|
||||
(download-printf "Downloading checksum for ~a\n" pkg-name)
|
||||
(log-pkg-debug "Downloading checksum as ~a" u)
|
||||
|
|
@ -548,6 +616,33 @@
|
|||
|
||||
;; ----------------------------------------
|
||||
|
||||
;; Disambiguate `str` as needed to ensure that it will be parsed as
|
||||
;; `type` in the future.
|
||||
(define (normalize-url type str as-url)
|
||||
(case type
|
||||
[(git)
|
||||
(cond
|
||||
[(equal? "git" (url-scheme as-url))
|
||||
str]
|
||||
[else
|
||||
(define p (reverse (url-path as-url)))
|
||||
(define skip (if (equal? "" (path/param-path (car p)))
|
||||
cdr
|
||||
values))
|
||||
(define e (path/param-path (car (skip p))))
|
||||
(cond
|
||||
[(not (regexp-match? #rx"[.]git$" e))
|
||||
(url->string (struct-copy url as-url
|
||||
[path
|
||||
(reverse
|
||||
(cons (path/param (string-append e ".git")
|
||||
(path/param-param (car (skip p))))
|
||||
(cdr (skip p))))]))]
|
||||
[else str])])]
|
||||
[else str]))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define (update-install-info-orig-pkg if op)
|
||||
(struct-copy install-info if
|
||||
[orig-pkg op]))
|
||||
|
|
@ -570,9 +665,21 @@
|
|||
(list* (car paths)
|
||||
(regexp-replace* #rx"[.]git$" (cadr paths) "")
|
||||
(or (url-fragment pkg-url) "master")
|
||||
(let ([a (assoc 'path (url-query pkg-url))])
|
||||
(or (and a (cdr a) (string-split (cdr a) "/"))
|
||||
null))))))
|
||||
(extract-git-path pkg-url)))))
|
||||
|
||||
(define (extract-git-path pkg-url)
|
||||
(let ([a (assoc 'path (url-query pkg-url))])
|
||||
(or (and a (cdr a) (string-split (cdr a) "/"))
|
||||
null)))
|
||||
|
||||
;; returns: (values host repo branch path)
|
||||
(define (split-git-url pkg-url)
|
||||
(values (url-host pkg-url)
|
||||
(string-join (map (compose ~a path/param-path)
|
||||
(url-path/no-slash pkg-url))
|
||||
"/")
|
||||
(or (url-fragment pkg-url) "master")
|
||||
(extract-git-path pkg-url)))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user