From fbdfa365945dc732278b112fb7260e5f9fceba81 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 18 Oct 2014 06:45:10 -0500 Subject: [PATCH] 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. --- .../pkg/gui/private/by-source.rkt | 8 +- .../pkg/scribblings/getting-started.scrbl | 33 ++-- .../racket-doc/pkg/scribblings/lib.scrbl | 2 +- .../racket-doc/pkg/scribblings/name.scrbl | 6 +- .../racket-doc/pkg/scribblings/pkg.scrbl | 86 +++++++--- .../racket-test/tests/pkg/tests-name.rkt | 40 ++++- .../racket-test/tests/pkg/tests-network.rkt | 91 ++++++----- .../private/english-string-constants.rkt | 1 + racket/collects/pkg/lib.rkt | 2 +- racket/collects/pkg/main.rkt | 4 +- racket/collects/pkg/name.rkt | 152 ++++++++++++------ racket/collects/pkg/private/download.rkt | 96 +++++++---- racket/collects/pkg/private/install.rkt | 4 +- racket/collects/pkg/private/stage.rkt | 135 ++++++++++++++-- 14 files changed, 481 insertions(+), 179 deletions(-) diff --git a/pkgs/gui-pkg-manager-pkgs/gui-pkg-manager-lib/pkg/gui/private/by-source.rkt b/pkgs/gui-pkg-manager-pkgs/gui-pkg-manager-lib/pkg/gui/private/by-source.rkt index cf8bdead02..a63faf29f8 100644 --- a/pkgs/gui-pkg-manager-pkgs/gui-pkg-manager-lib/pkg/gui/private/by-source.rkt +++ b/pkgs/gui-pkg-manager-pkgs/gui-pkg-manager-lib/pkg/gui/private/by-source.rkt @@ -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] diff --git a/pkgs/racket-pkgs/racket-doc/pkg/scribblings/getting-started.scrbl b/pkgs/racket-pkgs/racket-doc/pkg/scribblings/getting-started.scrbl index 60410411ac..1b386b7a73 100644 --- a/pkgs/racket-pkgs/racket-doc/pkg/scribblings/getting-started.scrbl +++ b/pkgs/racket-pkgs/racket-doc/pkg/scribblings/getting-started.scrbl @@ -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. diff --git a/pkgs/racket-pkgs/racket-doc/pkg/scribblings/lib.scrbl b/pkgs/racket-pkgs/racket-doc/pkg/scribblings/lib.scrbl index c5ede680a5..69ad15b895 100644 --- a/pkgs/racket-pkgs/racket-doc/pkg/scribblings/lib.scrbl +++ b/pkgs/racket-pkgs/racket-doc/pkg/scribblings/lib.scrbl @@ -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?]) diff --git a/pkgs/racket-pkgs/racket-doc/pkg/scribblings/name.scrbl b/pkgs/racket-pkgs/racket-doc/pkg/scribblings/name.scrbl index 33c8562882..4fa675e71d 100644 --- a/pkgs/racket-pkgs/racket-doc/pkg/scribblings/name.scrbl +++ b/pkgs/racket-pkgs/racket-doc/pkg/scribblings/name.scrbl @@ -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?] diff --git a/pkgs/racket-pkgs/racket-doc/pkg/scribblings/pkg.scrbl b/pkgs/racket-pkgs/racket-doc/pkg/scribblings/pkg.scrbl index 69de5231b0..e3aa65350f 100644 --- a/pkgs/racket-pkgs/racket-doc/pkg/scribblings/pkg.scrbl +++ b/pkgs/racket-pkgs/racket-doc/pkg/scribblings/pkg.scrbl @@ -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, diff --git a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-name.rkt b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-name.rkt index 97af9de369..dd6afa22b8 100644 --- a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-name.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-name.rkt @@ -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)) diff --git a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-network.rkt b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-network.rkt index abf9f649e4..b07cabc425 100644 --- a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-network.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-network.rkt @@ -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")) diff --git a/pkgs/string-constants-pkgs/string-constants-lib/string-constants/private/english-string-constants.rkt b/pkgs/string-constants-pkgs/string-constants-lib/string-constants/private/english-string-constants.rkt index aded30eba9..bf3fc651da 100644 --- a/pkgs/string-constants-pkgs/string-constants-lib/string-constants/private/english-string-constants.rkt +++ b/pkgs/string-constants-pkgs/string-constants-lib/string-constants/private/english-string-constants.rkt @@ -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,...} diff --git a/racket/collects/pkg/lib.rkt b/racket/collects/pkg/lib.rkt index 1e8304fb1c..0c5547c882 100644 --- a/racket/collects/pkg/lib.rkt +++ b/racket/collects/pkg/lib.rkt @@ -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? diff --git a/racket/collects/pkg/main.rkt b/racket/collects/pkg/main.rkt index c714382464..dde7efaa01 100644 --- a/racket/collects/pkg/main.rkt +++ b/racket/collects/pkg/main.rkt @@ -520,9 +520,9 @@ #:catalog-flags ([(#:str catalog #f) catalog () "Use 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 ;" - "valid s are: file, dir, file-url, dir-url, github, or name;" + "valid 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 is given)")] diff --git a/racket/collects/pkg/name.rkt b/racket/collects/pkg/name.rkt index 522de3ad07..a3600ad31a 100644 --- a/racket/collects/pkg/name.rkt +++ b/racket/collects/pkg/name.rkt @@ -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)])) diff --git a/racket/collects/pkg/private/download.rkt b/racket/collects/pkg/private/download.rkt index fc8ef2967e..a3de9bb9b4 100644 --- a/racket/collects/pkg/private/download.rkt +++ b/racket/collects/pkg/private/download.rkt @@ -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)) diff --git a/racket/collects/pkg/private/install.rkt b/racket/collects/pkg/private/install.rkt index 40ce06c265..58e98e6d87 100644 --- a/racket/collects/pkg/private/install.rkt +++ b/racket/collects/pkg/private/install.rkt @@ -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) diff --git a/racket/collects/pkg/private/stage.rkt b/racket/collects/pkg/private/stage.rkt index ccc9d07f5f..2386aad17f 100644 --- a/racket/collects/pkg/private/stage.rkt +++ b/racket/collects/pkg/private/stage.rkt @@ -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))) ;; ----------------------------------------