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

raco pkg: support "git://..." and "http[s]://[...].git" sources

Browse Source 
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 2014-10-18 06:45:10 -05:00
parent ce464810d5
commit fbdfa36594
14 changed files with 481 additions and 179 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
pkgs/gui-pkg-manager-pkgs/gui-pkg-manager-lib/pkg/gui/private/by-source.rkt
View File

@ -22,6 +22,7 @@
(define sc-install-pkg-dir (string-constant install-pkg-dir)) (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-dir-url (string-constant install-pkg-dir-url))
(define sc-install-pkg-file-url (string-constant install-pkg-file-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-github (string-constant install-pkg-github))
(define sc-install-pkg-name (string-constant install-pkg-name)) (define sc-install-pkg-name (string-constant install-pkg-name))
(define sc-install-pkg-inferred-as (string-constant install-pkg-inferred-as)) (define sc-install-pkg-inferred-as (string-constant install-pkg-inferred-as))
@ -224,6 +225,7 @@
sc-install-pkg-dir sc-install-pkg-dir
sc-install-pkg-file-url sc-install-pkg-file-url
sc-install-pkg-dir-url sc-install-pkg-dir-url
sc-install-pkg-git
sc-install-pkg-github sc-install-pkg-github
sc-install-pkg-name)])) sc-install-pkg-name)]))
(define link-dir-checkbox (new check-box% (define link-dir-checkbox (new check-box%
@ -360,14 +362,16 @@
[(2) 'dir] [(2) 'dir]
[(3) 'file-url] [(3) 'file-url]
[(4) 'dir-url] [(4) 'dir-url]
[(5) 'github] [(5) 'git]
[(6) 'name])) [(6) 'github]
[(7) 'name]))
(define/private (type->str type) (define/private (type->str type)
(case type (case type
[(file) sc-install-pkg-file] [(file) sc-install-pkg-file]
[(name) sc-install-pkg-name] [(name) sc-install-pkg-name]
[(dir) sc-install-pkg-dir] [(dir) sc-install-pkg-dir]
[(git) sc-install-pkg-git]
[(github) sc-install-pkg-github] [(github) sc-install-pkg-github]
[(file-url) sc-install-pkg-file-url] [(file-url) sc-install-pkg-file-url]
[(dir-url) sc-install-pkg-dir-url] [(dir-url) sc-install-pkg-dir-url]

33
pkgs/racket-pkgs/racket-doc/pkg/scribblings/getting-started.scrbl
View File

@ -140,7 +140,7 @@ looking for a package.
There are other ways to distribute and reference packages. For There are other ways to distribute and reference packages. For
example, a package can be installed directly from a @filepath{.zip} example, a package can be installed directly from a @filepath{.zip}
file---available locally or served from on a web site---or from a 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 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 interest to a wide audience. So, you may find non-catalog references
in mailing-list posts, recommended by your friends, or advertised in 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 to be a package name that is recognized by a @tech{package
catalog}. In general, each argument to @command-ref{install} is a catalog}. In general, each argument to @command-ref{install} is a
@tech{package source}. A @tech{package source} can refer to 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 directory-structured web site, or a few other possibilities. In each
of those cases, a @tech{package name} is inferred from the of those cases, a @tech{package name} is inferred from the
@tech{package source}. After the package is installed, you use 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 @tech{package catalog}, it gets back a @tech{package source} for the
actual package implementation, so each package installed from a actual package implementation, so each package installed from a
@tech{package catalog} is actually installed from a @filepath{.zip} @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 catalog} is just a way of making your package easier to find and
update. 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{package catalog} is consulted again to get the current
@tech{checksum} for the package, and the package is updated if the @tech{checksum} for the package, and the package is updated if the
@tech{checksum} doesn't match the current installation. If the package @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 consulted to get the current commit of a particular branch, and the
package is updated if the commit identifier doesn't match the package is updated if the commit identifier doesn't match the
@tech{checksum} of the current installation. @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} @section[#:tag "how-to-create"]{Creating Packages}
A package normally starts life as a directory containing module files 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}. @tech{package catalog}.
So, to create a package, first make a directory and select its name, 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} repository for your package}. After that, your @tech{package source}
is: 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}, 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. 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 your changes will automatically be discovered by those who use
@exec{raco pkg update} after installing from your @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 server will periodically check the package source you designate for
updates. updates.
If you use this server, and if you use GitHub for deployment, then you If you use this server, and if you use a public Git repository for
will never need to open a web browser to update your package for end deployment, then you will never need to open a web browser to update
users. You just need to push to your GitHub repository, then within 24 your package for end users. You just need to push to your Git
hours, the PLT @tech{package catalog} will notice, and @exec{raco repository, then within 24 hours, the PLT @tech{package catalog} will
pkg update} will work on your user's machines. 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 @url{http://pkgs.racket-lang-org}, you should supply a GitHub source
using the URL format using the URL format
@tt{github://github.com/@nonterm{user}/@nonterm{repo}/@nonterm{rev}@optional{/@nonterm{path}}} (not @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} @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 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 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 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 / the package, while those using Racket 5.3.5 will use the alternative branch /
archive. archive.

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

@ -126,7 +126,7 @@ scope}.}
@defproc[(pkg-desc? [v any/c]) boolean?] @defproc[(pkg-desc? [v any/c]) boolean?]
@defproc[(pkg-desc [source string?] @defproc[(pkg-desc [source string?]
[type (or/c #f 'file 'dir 'link 'static-link [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)] [name (or/c string? #f)]
[checksum (or/c string? #f)] [checksum (or/c string? #f)]
[auto? boolean?]) [auto? boolean?])

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

@ -14,13 +14,15 @@ extracting a package name.}
@defproc[(package-source-format? [v any/c]) boolean?]{ @defproc[(package-source-format? [v any/c]) boolean?]{
Returns @racket[#t] if @racket[v] is @racket['name] , @racket['file], 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 @racket['dir-url], @racket['link], or @racket['static-link], and
returns @racket[#f] otherwise. returns @racket[#f] otherwise.
The @racket['link] and @racket['static-link] formats are the same as The @racket['link] and @racket['static-link] formats are the same as
@racket['dir] in terms of parsing, but they are treated differently @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?] @defproc[(package-source->name [source string?]

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

@ -118,6 +118,7 @@ The @tech{package source} types are:
@itemlist[ @itemlist[
@; ----------------------------------------
@item{a local file path naming an archive (as a plain path or @litchar{file://} URL) @item{a local file path naming an archive (as a plain path or @litchar{file://} URL)
--- The name of the package --- The name of the package
is the basename of the archive file. The @tech{checksum} for archive 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 @elem{Changed treatment of an archive that contains all
content within a top-level directory.}]} content within a top-level directory.}]}
@; ----------------------------------------
@item{a local directory (as a plain path or @litchar{file://} URL) @item{a local directory (as a plain path or @litchar{file://} URL)
--- The name of the package is the name of the --- The name of the package is the name of the
directory. The @tech{checksum} is not present. 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 The inferred package name is from the URL's file name in the same
way as for a file package source.} way as for a file package source.}
@; ----------------------------------------
@item{a remote URL naming a directory --- The remote directory must @item{a remote URL naming a directory --- The remote directory must
contain a file named @filepath{MANIFEST} that lists all the contingent contain a file named @filepath{MANIFEST} that lists all the contingent
files. These are downloaded into a local directory and then the rules 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 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 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 path element that has an archive file suffix or a @filepath{.git}
is the directory name.} 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: 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}@; @inset{@exec{git://github.com/}@nonterm{user}@exec{/}@nonterm{repo}@;
@optional{@exec{.git}}@optional{@exec{/}}@optional{@exec{?path=}@nonterm{path}}@; @optional{@exec{.git}}@optional{@exec{/}}@optional{@exec{?path=}@nonterm{path}}@;
@optional{@exec{#}@nonterm{rev}}} @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} For example, @filepath{git://github.com/game/tic-tac-toe#master}
is a GitHub package source. 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: For backward compatibility, an older format is also supported:
@inset{@exec{github://github.com/}@nonterm{user}@exec{/}@nonterm{repo}@; @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 is a branch or tag, otherwise @nonterm{rev} itself serves as the
@tech{checksum}. @tech{checksum}.
A package source is inferred to be a GitHub reference when it A package source is inferred to be a GitHub reference when it starts
starts with @litchar{git://} or @litchar{github://}; a package source that is otherwise with @litchar{git://github.com/} or @litchar{github://}; a package
specified as a GitHub reference is automatically prefixed with source that is otherwise specified as a GitHub reference is
@filepath{git://github.com/}. The inferred package name automatically prefixed with @litchar{git://github.com/}. The inferred
is the last element of @nonterm{path} if it is package name is the last element of @nonterm{path} if it is non-empty,
non-empty, otherwise the inferred name is @nonterm{repo}.} otherwise the inferred name is @nonterm{repo}.}
@; ----------------------------------------
@item{a @tech{package name} --- A @tech{package catalog} is @item{a @tech{package name} --- A @tech{package catalog} is
consulted to determine the source and @tech{checksum} for the package. consulted to determine the source and @tech{checksum} for the package.
@ -342,7 +392,7 @@ sub-commands.
@itemlist[ @itemlist[
@item{@DFlag{type} @nonterm{type} or @Flag{t} @nonterm{type} --- specifies an interpretation of the package source, @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}.} or @exec{name}.}
@item{@DFlag{name} @nonterm{pkg} or @Flag{n} @nonterm{pkg} --- specifies the name of the package, @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, @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 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 @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, for a directory path (including a remote directory URL without a @filepath{.CHECKSUM} file) as a source,
@nonterm{checksum} assigns a checksum.} @nonterm{checksum} assigns a checksum.}
@ -589,7 +639,7 @@ the given @nonterm{pkg}s.
@subcommand{@command/toc{create} @nonterm{option} ... @nonterm{directory-or-package} @subcommand{@command/toc{create} @nonterm{option} ... @nonterm{directory-or-package}
--- Bundles a package into an archive. Bundling --- Bundles a package into an archive. Bundling
is not needed for a package that is provided directly from a 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 sub-command can create an archive from a directory (the default) or
from an installed package. It can also adjust the archive's content from an installed package. It can also adjust the archive's content
to include only sources, only compiled bytecode and rendered documentation, 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 If you want to control the resolution of package names (including
specific @tech{checksum}s) but not necessary keep a copy of all package specific @tech{checksum}s) but not necessary keep a copy of all package
code (assuming that old @tech{checksum}s remain available, such as 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}. to @tech{package source} mapping by using @command-ref{catalog-copy}.
For example, For example,

40
pkgs/racket-pkgs/racket-test/tests/pkg/tests-name.rkt
View File

@ -45,8 +45,8 @@
(check-equal-values? (parse "ocean/fish.tar.gz" #f) (values "fish" 'file #t)) (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.plt" 'file) (values "fish" 'file #t))
(check-equal-values? (parse "fish.tar.gz" '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.other" 'file #rx"archive") (values #f 'file #f))
(check-equal-values? (parse "fish" 'file #rx"archive") (values "fish" '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 "fish!" 'file #rx"archive") (values #f 'file #f))
(check-equal-values? (parse "" 'file #rx"ill-formed") (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 "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 "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.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 "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 "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!.zip" 'file-url) (values #f 'file-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/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" '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.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/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://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)) (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/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/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/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/" #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)) (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#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/" #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/?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/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/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" 'github) (values "fish" 'github #t))
(check-equal-values? (parse "racket/fish.git" '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 "" 'static-link) (values #f 'static-link #f))
(check-equal-values? (parse "" 'file-url) (values #f 'file-url #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 "" '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)) (check-equal-values? (parse "" 'github #rx"empty") (values #f 'github #f))
(void)) (void))

91
pkgs/racket-pkgs/racket-test/tests/pkg/tests-network.rkt
View File

@ -2,8 +2,7 @@
(require rackunit (require rackunit
racket/system racket/system
racket/match racket/match
(for-syntax racket/base racket/format
syntax/parse)
racket/file racket/file
racket/runtime-path racket/runtime-path
racket/path racket/path
@ -16,43 +15,53 @@
;; todo: to move the test packages to the "plt" account on GitHub ;; todo: to move the test packages to the "plt" account on GitHub
(pkg-tests (pkg-tests
(shelly-begin (define (test-remote url)
(shelly-install (shelly-begin
"remote/github" "git://github.com/mflatt/pkg-test?path=pkg-test1" (shelly-install "remote/git"
$ "racket -l racket/base -l pkg-test1/number -e '(number)'" =stdout> "1\n") (~a url "?path=pkg-test1")
(shelly-install "remote/github with slash" $ "racket -l racket/base -l pkg-test1/number -e '(number)'" =stdout> "1\n")
"git://github.com/mflatt/pkg-test?path=pkg-test1/") (shelly-install "remote/git with slash"
(shelly-install (~a url "?path=pkg-test1/"))
"remote/github with auto prefix and with branch" (shelly-install
"--type github mflatt/pkg-test?path=pkg-test1/#alt" "remote/git with tag"
$ "racket -l racket/base -l pkg-test1/number -e '(number)'" =stdout> "10\n") (~a url "?path=pkg-test1/#hundred")
(shelly-install $ "racket -l racket/base -l pkg-test1/number -e '(number)'" =stdout> "100\n")
"remote/github with tag" (shelly-install
"git://github.com/mflatt/pkg-test?path=pkg-test1/#hundred" "remote/git with commit"
$ "racket -l racket/base -l pkg-test1/number -e '(number)'" =stdout> "100\n") (~a url "?path=pkg-test1/#f9b4eef22")
(shelly-install $ "racket -l racket/base -l pkg-test1/number -e '(number)'" =stdout> "100\n")
"remote/github with commit" (shelly-install
"git://github.com/mflatt/pkg-test?path=pkg-test1/#f9b4eef22" "remote/git with checksum"
$ "racket -l racket/base -l pkg-test1/number -e '(number)'" =stdout> "100\n") (~a "--checksum f9b4eef22cdd9ab88b254cb027fc1ebe7fb596fd " url "?path=pkg-test1")
(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"
$ "racket -l racket/base -l pkg-test1/number -e '(number)'" =stdout> "100\n" $ "racket -l racket/base -l pkg-test1/number -e '(number)'" =stdout> "100\n"
$ "raco pkg remove pkg-test1-github-different-checksum" $ "raco pkg update pkg-test1"
$ "racket -l pkg-test1/number" =exit> 1)))) $ "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"))

1
pkgs/string-constants-pkgs/string-constants-lib/string-constants/private/english-string-constants.rkt
View File

@ -1828,6 +1828,7 @@ please adhere to these guidelines:
(install-pkg-dir "Directory") (install-pkg-dir "Directory")
(install-pkg-dir-url "Remote Directory") (install-pkg-dir-url "Remote Directory")
(install-pkg-file-url "Remote File") (install-pkg-file-url "Remote File")
(install-pkg-git "Git Repository")
(install-pkg-github "Github") (install-pkg-github "Github")
(install-pkg-name "Name (consulting resolver)") (install-pkg-name "Name (consulting resolver)")
(install-pkg-inferred-as "Type inferred to be ~a") ; ~a gets install-pkg-{file,dir,...} (install-pkg-inferred-as "Type inferred to be ~a") ; ~a gets install-pkg-{file,dir,...}

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

@ -59,7 +59,7 @@
(-> string? (or/c path-string? #f))] (-> string? (or/c path-string? #f))]
[pkg-desc [pkg-desc
(-> string? (-> 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)
(or/c string? #f) (or/c string? #f)
boolean? boolean?

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

@ -520,9 +520,9 @@
#:catalog-flags #:catalog-flags
([(#:str catalog #f) catalog () "Use <catalog> instead of configured catalogs"]) ([(#:str catalog #f) catalog () "Use <catalog> instead of configured catalogs"])
#:install-type-flags #: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>;" ("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")] "if not specified, the type is inferred syntactically")]
[(#:str name #f) name ("-n") ("Name of package, instead of inferred" [(#:str name #f) name ("-n") ("Name of package, instead of inferred"
"(makes sense only when a single <pkg-source> is given)")] "(makes sense only when a single <pkg-source> is given)")]

152
racket/collects/pkg/name.rkt
View File

@ -22,9 +22,10 @@
(define rx:package-name #rx"^[-_a-zA-Z0-9]+$") (define rx:package-name #rx"^[-_a-zA-Z0-9]+$")
(define rx:archive #rx"[.](plt|zip|tar|tgz|tar[.]gz)$") (define rx:archive #rx"[.](plt|zip|tar|tgz|tar[.]gz)$")
(define rx:git #rx"[.]git$")
(define package-source-format? (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?) (define (validate-name name complain inferred?)
(and name (and name
@ -42,12 +43,11 @@
(define (extract-archive-name name+ext complain) (define (extract-archive-name name+ext complain)
(validate-name (validate-name
(path->string (and name+ext
(if (regexp-match #rx#"[.]tar[.]gz$" (if (path? name+ext) (path->string
(path->bytes name+ext) (if (regexp-match #rx#"[.]tar[.]gz$" name+ext)
name+ext)) (path-replace-suffix (path-replace-suffix name+ext #"") #"")
(path-replace-suffix (path-replace-suffix name+ext #"") #"") (path-replace-suffix name+ext #""))))
(path-replace-suffix name+ext #"")))
complain complain
#t)) #t))
@ -58,6 +58,26 @@
(and (not (equal? "" (path/param-path (car p)))) (and (not (equal? "" (path/param-path (car p))))
(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) (define-syntax-rule (cor v complain)
(or v (begin complain #f))) (or v (begin complain #f)))
@ -78,14 +98,16 @@
(eq? type 'file) (eq? type 'file)
(and (path-string? s) (and (path-string? s)
(regexp-match rx:archive s))) (regexp-match rx:archive s)))
(unless (path-string? s) (define name
(complain "ill-formed path")) (and (cor (path-string? s)
(unless (regexp-match rx:archive s) (complain "ill-formed path"))
(complain "path does not end with a recognized archive suffix")) (cor (regexp-match rx:archive s)
(define-values (base name+ext dir?) (if (path-string? s) (complain "path does not end with a recognized archive suffix"))
(split-path s) (let ()
(values #f #f #f))) (define-values (base name+ext dir?) (if (path-string? s)
(define name (and name+ext (extract-archive-name name+ext complain-name))) (split-path s)
(values #f #f #f)))
(extract-archive-name name+ext complain-name))))
(values name 'file)] (values name 'file)]
[(if type [(if type
(or (eq? type 'dir) (or (eq? type 'dir)
@ -111,8 +133,7 @@
[(if type [(if type
(eq? type 'name) (eq? type 'name)
(regexp-match? rx:package-name s)) (regexp-match? rx:package-name s))
(validate-name s complain #f) (values (validate-name s complain #f) 'name)]
(values (and (regexp-match? rx:package-name s) s) 'name)]
[(and (eq? type 'github) [(and (eq? type 'github)
(not (regexp-match? #rx"^git(?:hub)?://" s))) (not (regexp-match? #rx"^git(?:hub)?://" s)))
(package-source->name+type (package-source->name+type
@ -120,6 +141,7 @@
'github)] 'github)]
[(if type [(if type
(or (eq? type 'github) (or (eq? type 'github)
(eq? type 'git)
(eq? type 'file-url) (eq? type 'file-url)
(eq? type 'dir-url)) (eq? type 'dir-url))
(regexp-match? #rx"^(https?|github|git)://" s)) (regexp-match? #rx"^(https?|github|git)://" s))
@ -136,66 +158,98 @@
(unless (or (equal? (url-scheme url) "github") (unless (or (equal? (url-scheme url) "github")
(equal? (url-scheme url) "git")) (equal? (url-scheme url) "git"))
(complain "URL scheme is not 'git' or 'github'")) (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 (define name
(and (cor (pair? p) (and (cor (pair? p)
(complain "URL path is empty")) (complain "URL path is empty"))
(cor (equal? "github.com" (url-host url)) (or (not github?)
(complain "URL host is not 'github.com'")) (cor (equal? "github.com" (url-host url))
(complain "URL host is not 'github.com'")))
(if (equal? (url-scheme url) "git") (if (equal? (url-scheme url) "git")
;; git:// ;; git://
(and (cor (or (= (length p) 2) (and (if github?
(and (= (length p) 3) (and
(equal? "" (path/param-path (caddr p))))) (cor (or (= (length p) 2)
(complain "URL does not have two path elements (name and repo)")) (and (= (length p) 3)
(let ([a (assoc 'path (url-query url))]) (equal? "" (path/param-path (caddr p)))))
(define sub (and a (cdr a) (string-split (cdr a) "/"))) (complain "URL does not have two path elements (name and repo)"))
(if (pair? sub) (cor (and (string? (path/param-path (car p)))
(validate-name (last sub) complain-name #t) (string? (path/param-path (cadr p))))
(let ([s (path/param-path (cadr p))]) (complain "URL includes a directory indicator as an element")))
(validate-name (regexp-replace #rx"[.]git$" s "") complain-name #t))))) (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:// ;; github://
(let ([p (if (equal? "" (path/param-path (last p))) (let ([p (if (equal? "" (path/param-path (last p)))
(reverse (cdr (reverse p))) (reverse (cdr (reverse p)))
p)]) p)])
(and (cor ((length p) . >= . 3) (and (cor ((length p) . >= . 3)
(complain "URL does not have at least three path elements")) (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 (validate-name
(if (= (length p) 3) (if (= (length p) 3)
(path/param-path (second (reverse p))) (path/param-path (second (reverse p)))
(last-non-empty p)) (last-non-empty p))
complain-name complain-name
#t)))))) #t))))))
(values name (or type 'github))] (values name (or type
(if github?
'github
'git)))]
[(if type [(if type
(eq? type 'file-url) (eq? type 'file-url)
(and (pair? p) (and (pair? p)
(path/param? (last p)) (path/param? (last p))
(regexp-match? rx:archive (path/param-path (last p))))) (string-and-regexp-match? rx:archive (path/param-path (last p)))))
(unless (pair? p) (define name
(complain "URL path is empty")) (and (cor (pair? p)
(when (pair? p) (complain "URL path is empty"))
(unless (path/param? (last p)) (cor (string-and-regexp-match? rx:archive (path/param-path (last p)))
(complain "URL's last path element is missing")) (complain "URL does not end with a recognized archive suffix"))
(unless (regexp-match? rx:archive (path/param-path (last p))) (extract-archive-name (last-non-empty p) complain-name)))
(complain "URL does not end with a recognized archive suffix"))) (values name 'file-url)]
(values (and (pair? p) [(if type
(extract-archive-name (last-non-empty p) complain-name)) (eq? type 'git)
'file-url)] (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 [else
(unless (pair? p) (define name
(complain "URL path is empty")) (and (cor (pair? p)
(when (pair? p) (complain "URL path is empty"))
(unless (path/param? (last p)) (cor (last-non-empty p)
(complain "URL's last path element is missing"))) (complain "URL has no non-empty path"))
(values (validate-name (last-non-empty p) complain-name #t) 'dir-url)])) (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 #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) [(and (not type)
(regexp-match #rx"^file://(.*)$" s)) (regexp-match #rx"^file://(.*)$" s))
=> (lambda (m) (parse-path (cadr m)))] => (lambda (m) (parse-path (cadr m)))]
[(and (not type) [(and (not type)
(regexp-match? #rx"^[a-zA-Z]*://" s)) (regexp-match? #rx"^[a-zA-Z]*://" s))
(complain "unreognized URL scheme") (complain "unrecognized URL scheme")
(values #f #f)] (values #f #f)]
[else [else
(parse-path s)])) (parse-path s)]))

96
racket/collects/pkg/private/download.rkt
View File

@ -4,12 +4,17 @@
racket/match racket/match
racket/port racket/port
racket/format racket/format
racket/file
file/tar
file/untgz
net/git-checkout
"path.rkt" "path.rkt"
"print.rkt" "print.rkt"
"config.rkt") "config.rkt")
(provide call/input-url+200 (provide call/input-url+200
download-file! download-file!
download-repo!
url-path/no-slash url-path/no-slash
clean-cache) clean-cache)
@ -35,6 +40,25 @@
rest] rest]
[_ rp]))) [_ 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 (define (download-file! url file checksum
#:download-printf [download-printf #f] #:download-printf [download-printf #f]
#:use-cache? [use-cache? #t] #:use-cache? [use-cache? #t]
@ -48,34 +72,21 @@
(define (download!) (define (download!)
(when download-printf (when download-printf
(download-printf "Downloading ~a\n" (url->string url))) (download-printf "Downloading ~a\n" (url->string url)))
(call-with-output-file file (call-with-output-file*
(λ (op) file
(call/input-url+200 #:exists 'truncate/replace
url (λ (op)
(λ (ip) (copy-port ip op)) (call/input-url+200
#:failure url
(lambda (reply-s) (λ (ip) (copy-port ip op))
(pkg-error (~a "error downloading package\n" #:failure
" URL: ~a\n" (lambda (reply-s)
" server response: ~a") (pkg-error (~a "error downloading package\n"
(url->string url) " URL: ~a\n"
(read-line (open-input-string reply-s)))))))) " server response: ~a")
(cond (url->string url)
[(and checksum use-cache?) (read-line (open-input-string reply-s))))))))
(cache-file file (do-cache-file file url checksum use-cache? download-printf download!)))
(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 (clean-cache pkg-url checksum) (define (clean-cache pkg-url checksum)
(when pkg-url (when pkg-url
@ -85,3 +96,32 @@
(get-download-cache-dir) (get-download-cache-dir)
#:log-error-string (lambda (s) (log-pkg-error s)) #:log-error-string (lambda (s) (log-pkg-error s))
#:log-debug-string (lambda (s) (log-pkg-debug 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))

4
racket/collects/pkg/private/install.rkt
View File

@ -32,9 +32,9 @@
(define (checksum-for-pkg-source pkg-source type pkg-name given-checksum download-printf) (define (checksum-for-pkg-source pkg-source type pkg-name given-checksum download-printf)
(case type (case type
[(file-url dir-url github) [(file-url dir-url github git)
(or given-checksum (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) [(file)
(define checksum-pth (format "~a.CHECKSUM" pkg-source)) (define checksum-pth (format "~a.CHECKSUM" pkg-source))
(or (and (file-exists? checksum-pth) (or (and (file-exists? checksum-pth)

133
racket/collects/pkg/private/stage.rkt
View File

@ -13,6 +13,7 @@
file/unzip file/unzip
openssl/sha1 openssl/sha1
json json
net/git-checkout
"../name.rkt" "../name.rkt"
"../strip.rkt" "../strip.rkt"
"catalog.rkt" "catalog.rkt"
@ -33,12 +34,13 @@
(struct install-info (name orig-pkg directory clean? checksum module-paths additional-installs)) (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 (match pkg
[`(catalog ,pkg-name) [`(catalog ,pkg-name)
(hash-ref (package-catalog-lookup pkg-name #f download-printf) 'checksum)] (hash-ref (package-catalog-lookup pkg-name #f download-printf) 'checksum)]
[`(url ,pkg-url-str) [`(url ,pkg-url-str)
(package-url->checksum pkg-url-str (package-url->checksum pkg-url-str
#:type type
#:download-printf download-printf #:download-printf download-printf
#:pkg-name pkg-name)])) #:pkg-name pkg-name)]))
@ -90,11 +92,15 @@
metadata-ns metadata-ns
#:strip strip-mode #:strip strip-mode
#:force-strip? force-strip?)] #:force-strip? force-strip?)]
[(or (eq? type 'file-url) (eq? type 'dir-url) (eq? type 'github)) [(or (eq? type 'file-url)
(define pkg-url (string->url pkg)) (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 scheme (url-scheme pkg-url))
(define orig-pkg `(url ,pkg)) (define orig-pkg `(url ,pkg-url-str))
(define found-checksum (define found-checksum
;; If a checksum is given, use that. In the case of a non-github ;; 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 ;; source, we could try to get the checksum from the source, and
@ -107,6 +113,55 @@
(define checksum (or found-checksum given-checksum)) (define checksum (or found-checksum given-checksum))
(define downloaded-info (define downloaded-info
(match type (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 ['github
(unless checksum (unless checksum
(pkg-error (pkg-error
@ -132,7 +187,6 @@
"~a-" "~a-"
(format "~a.~a.tgz" repo branch)) (format "~a.~a.tgz" repo branch))
#f)) #f))
(delete-file tmp.tgz)
(define tmp-dir (define tmp-dir
(make-temporary-file (make-temporary-file
(string-append (string-append
@ -156,8 +210,8 @@
(unless (directory-exists? (apply build-path tmp-dir path)) (unless (directory-exists? (apply build-path tmp-dir path))
(pkg-error (pkg-error
(~a "specified directory is not in GitHub respository archive\n" (~a "specified directory is not in GitHub respository archive\n"
" path: ~a" " path: ~a")
(apply build-path path)))) (apply build-path path)))
(lift-directory-content tmp-dir path)) (lift-directory-content tmp-dir path))
(begin0 (begin0
@ -476,12 +530,26 @@
;; ---------------------------------------- ;; ----------------------------------------
(define (package-url->checksum pkg-url-str [query empty] (define (package-url->checksum pkg-url-str [query empty]
#:type [given-type #f]
#:download-printf [download-printf void] #:download-printf [download-printf void]
#:pkg-name [pkg-name "package"]) #:pkg-name [pkg-name "package"])
(define pkg-url (define pkg-url
(string->url pkg-url-str)) (string->url pkg-url-str))
(match (url-scheme pkg-url) (define type (or given-type
[(or "github" "git") (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) (match-define (list* user repo branch path)
(split-github-url pkg-url)) (split-github-url pkg-url))
(or (or
@ -525,7 +593,7 @@
;; syntax of a commit id, then assume that it refers to a commit ;; syntax of a commit id, then assume that it refers to a commit
(and (regexp-match? #rx"[a-f0-9]+" branch) (and (regexp-match? #rx"[a-f0-9]+" branch)
branch))] branch))]
[_ [else
(define u (string-append pkg-url-str ".CHECKSUM")) (define u (string-append pkg-url-str ".CHECKSUM"))
(download-printf "Downloading checksum for ~a\n" pkg-name) (download-printf "Downloading checksum for ~a\n" pkg-name)
(log-pkg-debug "Downloading checksum as ~a" u) (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) (define (update-install-info-orig-pkg if op)
(struct-copy install-info if (struct-copy install-info if
[orig-pkg op])) [orig-pkg op]))
@ -570,9 +665,21 @@
(list* (car paths) (list* (car paths)
(regexp-replace* #rx"[.]git$" (cadr paths) "") (regexp-replace* #rx"[.]git$" (cadr paths) "")
(or (url-fragment pkg-url) "master") (or (url-fragment pkg-url) "master")
(let ([a (assoc 'path (url-query pkg-url))]) (extract-git-path pkg-url)))))
(or (and a (cdr a) (string-split (cdr a) "/"))
null)))))) (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)))
;; ---------------------------------------- ;; ----------------------------------------