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

raco pkg {install,update}: add --clone <dir> mode

Browse Source 
Using `--clone <dir>` with a Git-based package source causes the
package installation to be linked to a clone of the repository
as a subdirectory of <dir>. The package can be developed locally
in the usual way with Git tools, but `raco pkg update` can itself
pull updates to the package/repository.

See the new chapter 6 in "Package Management in Racket" for
more information.
This commit is contained in:
Matthew Flatt 2014-11-20 21:04:55 -07:00
parent 04f5fe3815
commit 6379aaddef
41 changed files with 1080 additions and 294 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/gui-pkg-manager-pkgs/gui-pkg-manager-lib/pkg/gui.rkt
View File

@ -192,6 +192,6 @@
frame) frame)
(module+ main (module+ main
(void (make-pkg-installer))
#; #;
(void (make-pkg-installer))
(void (make-pkg-gui))) (void (make-pkg-gui)))

51
pkgs/gui-pkg-manager-pkgs/gui-pkg-manager-lib/pkg/gui/private/by-installed.rkt
View File

@ -3,6 +3,7 @@
racket/gui/base racket/gui/base
racket/format racket/format
setup/dirs setup/dirs
net/url
pkg/lib pkg/lib
pkg pkg
string-constants string-constants
@ -13,11 +14,30 @@
(struct ipkg (name scope auto? checksum source)) (struct ipkg (name scope auto? checksum source))
(define ((ipkg->source dir) ipkg) (define ((ipkg->desc dir) ipkg)
(define name (ipkg-name ipkg))
(define s (cadr (ipkg-source ipkg))) (define s (cadr (ipkg-source ipkg)))
(if (not (eq? 'catalog (car (ipkg-source ipkg)))) (define kind (car (ipkg-source ipkg)))
(path->string (path->complete-path s dir)) (case kind
s)) [(catalog) (pkg-desc s 'name name #f #f)]
[(link static-link)
(pkg-desc (path->string (path->complete-path s dir)) kind name #f #f)]
[(url) (pkg-desc s #f name #f #f)]
[(clone)
(define url-str (caddr (ipkg-source ipkg)))
(pkg-desc url-str
'clone
name
#f
#f
#:path (let loop ([p (path->complete-path s dir)]
[n (length (url-query (string->url url-str)))])
(cond
[(zero? n) p]
[else (define-values (base name dir?) (split-path p))
(if (path? base)
(loop base (sub1 n))
(error "mangled path recorded for a clone"))])))]))
(define (source->string s) (define (source->string s)
(format "~a: ~a" (format "~a: ~a"
@ -26,7 +46,8 @@
[(url) "URL"] [(url) "URL"]
[(link) "Link"] [(link) "Link"]
[(static-link) "Static link"] [(static-link) "Static link"]
[(file) "File"]) [(file) "File"]
[(clone) "Clone"])
(cadr s))) (cadr s)))
(define (status-string a default-scope) (define (status-string a default-scope)
@ -152,14 +173,9 @@
[(path? scope) scope] [(path? scope) scope]
[(eq? scope 'installation) (find-pkgs-dir)] [(eq? scope 'installation) (find-pkgs-dir)]
[else (find-user-pkgs-dir)])) [else (find-user-pkgs-dir)]))
;; Also preserve link kind: (parameterize ([current-pkg-scope scope])
(define kind (car (ipkg-source (car ipkgs)))) (with-pkg-lock (pkg-install (map (ipkg->desc dir) ipkgs))))
(apply (void))))]))
pkg-install-command
#:scope scope
#:link (eq? 'link kind)
#:static-link (eq? 'static-link kind)
(map (ipkg->source dir) ipkgs)))))]))
(define demote-button (define demote-button
(new button% (new button%
@ -215,12 +231,7 @@
(not (ipkg-auto? i))))) (not (ipkg-auto? i)))))
(send promote-button enable (and same-scope? (send promote-button enable (and same-scope?
(for/and ([i (in-list ipkgs)]) (for/and ([i (in-list ipkgs)])
(ipkg-auto? i)) (ipkg-auto? i))))
;; all 'catalog, 'link, or 'static-link
(let ([kind (car (ipkg-source (car ipkgs)))])
(and (memq kind '(catalog link static-link))
(for/and ([i (in-list (cdr ipkgs))])
(eq? kind (car (ipkg-source i))))))))
(send update-button enable (and same-scope? (send update-button enable (and same-scope?
(for/and ([i (in-list ipkgs)]) (for/and ([i (in-list ipkgs)])
(not (memq (car (ipkg-source i)) (not (memq (car (ipkg-source i))
@ -267,7 +278,7 @@
(if (eq? (car sa) (car sb)) (if (eq? (car sa) (car sb))
(string<? (cadr sa) (cadr sb)) (string<? (cadr sa) (cadr sb))
(case (car sa) (case (car sa)
[(link) #t] [(link static-link clone) #t]
[(catalog) (eq? b 'url)] [(catalog) (eq? b 'url)]
[(url) #f])))]))))) [(url) #f])))])))))
(set! sorted-installed (list->vector l)) (set! sorted-installed (list->vector l))

1
pkgs/gui-pkg-manager-pkgs/gui-pkg-manager-lib/pkg/gui/private/by-list.rkt
View File

@ -28,6 +28,7 @@
[(catalog) ""] [(catalog) ""]
[(link) "="] [(link) "="]
[(static-link) "="] [(static-link) "="]
[(clone) "="]
[(url) "@"]))) [(url) "@"])))
(define by-list-panel% (define by-list-panel%

3
pkgs/plt-services/meta/drdr/README-PORTS
View File

@ -9,6 +9,9 @@ others don't accidentally conflict.
8889 - tests/racket/benchmarks/shootout/typed/echo (optimized) 8889 - tests/racket/benchmarks/shootout/typed/echo (optimized)
9000 - DrDr Web server 9000 - DrDr Web server
9001 - tests/net 9001 - tests/net
9990 - tests/pkg
9997 - tests/pkg
9998 - tests/pkg
9999 - tests/web-server 9999 - tests/web-server
19200 - 2htdp/tests 19200 - 2htdp/tests
... ...

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

@ -268,8 +268,8 @@ and grows up to become a Git repository that is registered with a
@subsection[#:tag "automatic-creation"]{Automatic Creation} @subsection[#:tag "automatic-creation"]{Automatic Creation}
As a convenience, @command-ref{new} can automatically create single As a convenience, @command-ref{new} can automate the creation of
collection packages. a @tech{single-collection package}.
To create @nonterm{pkg-name}: To create @nonterm{pkg-name}:
@commandline{raco pkg new @nonterm{pkg-name}} @commandline{raco pkg new @nonterm{pkg-name}}
@ -307,7 +307,7 @@ it to a @tech{multi-collection package} by restructuring the package
directory, so you don't have to worry much about the choice when you directory, so you don't have to worry much about the choice when you
get started. get started.
@subsection[#:tag "working-new-pkgs"]{Working with New Packages} @subsection[#:tag "working-new-pkgs"]{Linking and Developing New Packages}
Whether creating a @tech{single-collection package} or a Whether creating a @tech{single-collection package} or a
@tech{multi-collection package}, the next step is to link your @tech{multi-collection package}, the next step is to link your
@ -392,7 +392,7 @@ Whenever you
@commandline{git push} @commandline{git push}
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 @command-ref{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 As of Racket version 6.1.1.1, other Git repository services can work
@ -400,6 +400,10 @@ just as well as GitHub---including Gitorious or BitBucket---as long as
the server supports either the ``smart'' HTTP(S) protocol or the the server supports either the ``smart'' HTTP(S) protocol or the
native Git protocol (but use a @exec{git://} path for the latter). native Git protocol (but use a @exec{git://} path for the latter).
The Racket package manager provides more support for Git-based
development than just deployment. See @secref["git-workflow"] for more
information.
@; - - - - - - - - - - - - - - - - - - - - - - - - @; - - - - - - - - - - - - - - - - - - - - - - - -
@subsection[#:tag "manual-deploy"]{Manual Deployment} @subsection[#:tag "manual-deploy"]{Manual Deployment}
@ -421,9 +425,9 @@ Your @tech{package source} is then something like
Whenever you want to provide a new release of a package, recreate and reupload the Whenever you want to provide a new release of a package, recreate and reupload the
package archive (and @tech{checksum}). Your changes will automatically be package archive (and @tech{checksum}). Your changes will automatically be
discovered by those who used your package source when they use discovered by those who used your package source when they use
@exec{raco pkg update}. @command-ref{update}.
@margin-note{By default, @exec{raco pkg create} generates a @margin-note{By default, @command-ref{create} generates a
@filepath{.zip} archive. For more options, refer to the @filepath{.zip} archive. For more options, refer to the
@command-ref{create} documentation. If you want to generate an archive @command-ref{create} documentation. If you want to generate an archive
through some other means, simply archive what you made in the first through some other means, simply archive what you made in the first
@ -453,7 +457,7 @@ 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 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 your package for end users. You just need to push to your Git
repository, then within 24 hours, the PLT @tech{package catalog} will repository, then within 24 hours, the PLT @tech{package catalog} will
notice, and @exec{raco pkg update} will work on your user's machines. notice, and @command-ref{update} will work on your user's machines.
@; - - - - - - - - - - - - - - - - - - - - - - - - @; - - - - - - - - - - - - - - - - - - - - - - - -
@ -484,8 +488,8 @@ present interfaces to external, versioned things, such as
@item{A @tech{version} declaration for a package is used only by other @item{A @tech{version} declaration for a package is used only by other
package implementors to effectively declare dependencies on provided package implementors to effectively declare dependencies on provided
features. Such declarations allow @exec{raco pkg install} and features. Such declarations allow @command-ref{install} and
@exec{raco pkg update} to help check dependencies. Declaring and @command-ref{update} to help check dependencies. Declaring and
changing a version is optional, and the @tech{package catalog} changing a version is optional, and the @tech{package catalog}
ignores version declarations; in particular, a package is a candidate ignores version declarations; in particular, a package is a candidate
for updating when its @tech{checksum} changes, independent of whether for updating when its @tech{checksum} changes, independent of whether

148
pkgs/racket-pkgs/racket-doc/pkg/scribblings/git-workflow.scrbl Normal file
View File

@ -0,0 +1,148 @@
#lang scribble/manual
@(require "common.rkt"
scribble/bnf)
@title[#:tag "git-workflow"]{Developing Packages with Git}
When a Git repository is specified as a package source, then a copy of
the repository content is installed as the package
implementation. That installation mode is designed for package
consumers, who normally use a package without modifying it. The
installed copy of the package is unsuitable for development by the
package author, however, since the installation is not a full clone of
the Git repository. The Racket package manager provides different
installation modes to support package authors who work with Git
repository clones.
@section{Linking a Git Checkout as a Directory}
Since a Git repository checkout is a directory, it can be linked as a
package as described in @secref["working-new-pkgs"]. In that case, any
modifications made locally take effect immediately for the package
installation, including any updates from a @exec{git pull}. The
developer must explicitly pull any remote updates to the repository,
however, including when the updates are needed to satisfy the
requirements of dependent packages.
In the following section, we describe an alternative that makes
@command-ref{update} aware of the checkout directory's status as a
repository clone. Furthermore, a directory-linked package can be
promoted to a clone-linked package with @command-ref{update}.
@section{Linking a Git Checkout as a Clone}
When a package is installed with
@commandline{@command{install} --clone @nonterm{dir} @nonterm{git-pkg-source}}
then instead of installing the package as a mere copy of the
repository source, the package is installed by creating a Git clone of
@nonterm{git-pkg-source} as @nonterm{dir}. The clone's checkout is
linked in the same way as a directory, but unlike a plain directory
link, the Racket package manager keeps track of the repository
connection.
When the repository at @nonterm{git-pkg-source} is changed so that the
source has a new checksum, then @command-ref{update} for the package pulls
commits from the repository to the local clone. In other words,
@command-ref{update} works as an alternative to @exec{git pull --ff-only}
to pull updates for the package. Furthermore, @command-ref{update} can
pull updates to local package repositories when checking dependencies.
For example, @exec{@command{update} --all} pulls updates for all
linked package repositories.
Suppose that a developer works with a large number of packages and
develops only a few of them. The intended workflow is as follows:
@itemlist[
@item{Install all the relevant packages with @command-ref{install}.}
@item{For each package to be developed out of a particular Git
repository named by @nonterm{git-pkg-source}, update the installation with
@commandline{@command{update} --clone @nonterm{dir} @nonterm{git-pkg-source}}
which discards the original installation of the package and replaces
it with a local clone as @nonterm{dir}.}
@item{Manage changes to each of the developed packages in the usual
way with @exec{git} tools, but @command-ref{update} is also available
for updates, including mass updates.}
]
A @tech{package source} provided with @DFlag{clone} can include a
branch and/or path into the repository. The branch specification
affects the branch used for the initial checkout, while a non-empty
path causes a subdirectory of the checkout to be linked for the
package.
The package developer will work with both @exec{git} tools and
@exec{raco pkg} tools, and the tools interact in specific ways:
@itemlist[
@item{With the link-establishing
@commandline{@command{install} --clone @nonterm{dir} @nonterm{git-pkg-source}}
or the same for @command-ref{update}, if a local repository exists
already as @nonterm{dir}, then it is left in place and any new
commits are fetched from @nonterm{git-pkg-source}. The package
manager does not attempt to check whether a pre-existing
repository is consistent with @nonterm{git-pkg-source}; it
simply starts fetching new commits to the repository, and a
later @exec{git pull --ff-only} will detect any mismatch.
Multiple @nonterm{git-pkg-source}s can be provided to
@command-ref{install}, which makes sense when multiple packages are
sourced from the same repository and can therefore share
@nonterm{dir}. Whether through a single @exec{raco pkg} use or
multiple uses with the same @exec{--clone @nonterm{dir}},
packages from the same repository should be linked from the
same local clone, assuming that they are in the same repository
because they should be modified together. The package system,
however, makes no requirement of clone sharing among the
packages.}
@item{When pulling changes to repositories that have local copies,
@command-ref{update} pulls changes with the equivalent of @exec{git
pull --ff-only}.}
@item{When @command-ref{update} is given a specific commit as the target
of the update, it uses the equivalent of @exec{git merge --ff-only
@nonterm{checksum}}. This approach is intended to preserve any
changes to the package made locally, but it implies that the
package cannot be ``downgraded'' to a older commit simply by
specifying the commit for @command-ref{update}; any newer commits
that are already in the local repository will be preserved.}
@item{The installed-package database records the most recent commit
pulled from the source repository after each installation or
update. The current commit in the repository checkout is
consulted only for the purposes of merging onto pulled
commits. Thus, after pushing repository changes with @exec{git
push}, a @command-ref{update} makes sense to synchronize the
package-installation database with the remote repository state
(which is then the same as the local repository state).}
@item{When checking a @command-ref{install} or @command-ref{update}
request for collisions, commits are first fetched with
@exec{git fetch}, and an additional local clone is created in a
temporary directory. If the overall installation or update is
deemed to be successful with respect to remote commits (not
necessarily the current commit in each local repository) in
that copy, then an update to the linked repository checkout
proceeds. Finally, after all checkouts succeed, other package
installations and updates are completed and recorded. If a
checkout fails (e.g., due to a conflict or uncommitted change),
then the repository checkout is left in a failed state, but all
package actions are otherwise canceled.}
@item{Removing a package with @command-ref{remove} leaves the
repository checkout intact while removing the package link.}
]

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

@ -125,18 +125,27 @@ scope}.}
@deftogether[( @deftogether[(
@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 'name 'file 'dir 'link 'static-link
'file-url 'dir-url 'git 'github 'name)] 'file-url 'dir-url 'git 'github 'clone)]
[name (or/c string? #f)] [name (or/c string? #f)]
[checksum (or/c string? #f)] [checksum (or/c string? #f)]
[auto? boolean?]) [auto? boolean?]
[#:path path (or/c #f path-string?) #f])
pkg-desc?] pkg-desc?]
)]{ )]{
A @racket[pkg-desc] value describes a package source plus details of its A @racket[pkg-desc] value describes a package source plus details of its
intended interpretation, where the @racket[auto?] field indicates that intended interpretation, where the @racket[auto?] field indicates that
the package is should be treated as installed automatically for a the package is should be treated as installed automatically for a
dependency.} dependency.
The optional @racket[path] argument is intended for use when
@racket[type] is @racket['clone], in which case it specifies< a
directory containing the repository clone (where the repository itself
is a directory within @racket[path]).
@history[#:changed "6.1.1.1" @elem{Added @racket['git] as a @racket[type].}
#:changed "6.1.1.5" @elem{Added @racket['clone] as a @racket[type].}]}
@defproc[(pkg-stage [desc pkg-desc?] @defproc[(pkg-stage [desc pkg-desc?]
@ -271,8 +280,12 @@ Implements @racket[pkg-update-command]. The result is the same as for
@racket[pkg-install]. @racket[pkg-install].
A string in @racket[names] refers to an installed package that should A string in @racket[names] refers to an installed package that should
be checked for updates. A @racket[pkg-desc] in @racket[names] indicates be checked for updates. A @racket[pkg-desc] in @racket[names]
a package source that should replace the current installation. indicates a package source that should replace the current
installation, except that a @racket[package-desc] can have the type
@racket['clone] and a source with the syntax of a package name, in
which case it refers to an existing package installation that should
be converted to a Git repository clone.
If @racket[from-command-line?] is true, error messages may suggest If @racket[from-command-line?] is true, error messages may suggest
specific command-line flags for @command-ref{update}. specific command-line flags for @command-ref{update}.

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

@ -14,15 +14,18 @@ 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['git], @racket['github], @racket['file-url], @racket['dir], @racket['git], @racket['github], @racket['clone], @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. The @racket['clone] format
is similarly the same as @racket['github] or @racket['git] in terms of
parsing.
@history[#:changed "6.1.1.1" @elem{Added @racket['git].}]} @history[#:changed "6.1.1.1" @elem{Added @racket['git].}
#:changed "6.1.1.5" @elem{Added @racket['clone].}]}
@defproc[(package-source->name [source string?] @defproc[(package-source->name [source string?]

3
pkgs/racket-pkgs/racket-doc/pkg/scribblings/path.scrbl
View File

@ -18,7 +18,8 @@ databases.}
@defstruct*[pkg-info ([orig-pkg (or/c (list/c 'catalog string?) @defstruct*[pkg-info ([orig-pkg (or/c (list/c 'catalog string?)
(list/c 'url string?) (list/c 'url string?)
(list/c 'link string?) (list/c 'link string?)
(list/c 'static-link string?))] (list/c 'static-link string?)
(list/c 'clone string? string?))]
[checksum (or/c #f string?)] [checksum (or/c #f string?)]
[auto? boolean?]) [auto? boolean?])
#:prefab]{ #:prefab]{

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

@ -378,7 +378,7 @@ directory @tech{package scopes}.
The @exec{raco pkg} command provides package-management tools via The @exec{raco pkg} command provides package-management tools via
sub-commands. sub-commands.
@command/toc{install} @nonterm{option} ... @nonterm{pkg-source} ... @subcommand{@command/toc{install} @nonterm{option} ... @nonterm{pkg-source} ...
--- Installs the given @tech{package sources} (eliminating exact-duplicate @nonterm{pkg-source}s). --- Installs the given @tech{package sources} (eliminating exact-duplicate @nonterm{pkg-source}s).
If a given @nonterm{pkg-source} is ``auto-installed'' (to satisfy some other package's If a given @nonterm{pkg-source} is ``auto-installed'' (to satisfy some other package's
dependency), then it is promoted to explicitly installed. dependency), then it is promoted to explicitly installed.
@ -432,7 +432,7 @@ sub-commands.
@item{@DFlag{skip-implies} --- Disables special treatment of dependencies that are listed @item{@DFlag{skip-implies} --- Disables special treatment of dependencies that are listed
in @racketidfont{implies} (see @secref["metadata"]) for an installed or updated package.} in @racketidfont{implies} (see @secref["metadata"]) for an installed or updated package.}
@item{@DFlag{link} --- Implies @exec{--type dir} (and overrides any specified type), @item{@DFlag{link} --- Implies @exec{--type dir}
and links the existing directory as an installed package, instead of copying the and links the existing directory as an installed package, instead of copying the
directory's content to install. Directory @tech{package sources} are treated as links directory's content to install. Directory @tech{package sources} are treated as links
by default, unless @DFlag{copy} is specified. by default, unless @DFlag{copy} is specified.
@ -447,12 +447,19 @@ sub-commands.
of the given directory will not change for each given directory that implements a of the given directory will not change for each given directory that implements a
@tech{multi-collection package}.} @tech{multi-collection package}.}
@item{@DFlag{pkgs} --- Disables default installation of the current directory when no @nonterm{pkg-source}s
are supplied.}
@item{@DFlag{copy} --- Disables default handling of directory @tech{package sources} as links, @item{@DFlag{copy} --- Disables default handling of directory @tech{package sources} as links,
and instead treats them like other sources: package content is copied to install.} and instead treats them like other sources: package content is copied to install.}
@item{@DFlag{clone} @nonterm{dir} --- A Git or GitHub @tech{package
source} is cloned as @nonterm{dir} and locally linked as the
package implementation. Multiple @nonterm{pkg-source}
arguments make sense only if they all specify the same Git
repository (with different paths in the repository). The
@DFlag{clone} flag implies @DFlag{type} in the sense that each
@nonterm{pkg-source} must be either a Git or GitHub
@tech{package source}. See @secref["git-workflow"] for more
information.}
@item{@DFlag{binary} --- Strips source elements of a package before installing, and implies @DFlag{copy}.} @item{@DFlag{binary} --- Strips source elements of a package before installing, and implies @DFlag{copy}.}
@item{@DFlag{source} --- Strips built elements of a package before installing, and implies @DFlag{copy}.} @item{@DFlag{source} --- Strips built elements of a package before installing, and implies @DFlag{copy}.}
@ -477,6 +484,9 @@ sub-commands.
whose name corresponds to an already-installed package, except for promoting auto-installed whose name corresponds to an already-installed package, except for promoting auto-installed
packages to explicitly installed.} packages to explicitly installed.}
@item{@DFlag{pkgs} --- Disables default installation of the current directory when no @nonterm{pkg-source}s
are supplied.}
@item{@DFlag{all-platforms} --- Considers package dependencies independent of the current platform @item{@DFlag{all-platforms} --- Considers package dependencies independent of the current platform
(instead of filtering dependencies to platforms other than the current one).} (instead of filtering dependencies to platforms other than the current one).}
@ -501,6 +511,7 @@ sub-commands.
@item{@DFlag{fail-fast} --- Breaks @exec{raco setup} as soon as any error is encountered.} @item{@DFlag{fail-fast} --- Breaks @exec{raco setup} as soon as any error is encountered.}
] ]
@history[#:changed "6.1.1.5" @elem{Added the @DFlag{clone} flag.}]}
@subcommand{@command/toc{update} @nonterm{option} ... @nonterm{pkg-source} ... @subcommand{@command/toc{update} @nonterm{option} ... @nonterm{pkg-source} ...
@ -513,13 +524,17 @@ any of the @nonterm{pkg-source}s (or their dependencies).
If a @tech{package scope} is not specified, the scope is inferred from If a @tech{package scope} is not specified, the scope is inferred from
the given @nonterm{pkg-source}s. the given @nonterm{pkg-source}s.
If no @racket{pkg-source}, @DFlag{all} or @Flag{a} flag, or
@DFlag{clone} flag is specified, and if the current directory is
within a package, then the enclosing package is updated.
The @exec{update} sub-command accepts The @exec{update} sub-command accepts
the following @nonterm{option}s: the following @nonterm{option}s:
@itemlist[ @itemlist[
@item{@DFlag{all} or @Flag{a} --- Update all packages, if no packages are given in the argument list.} @item{@DFlag{all} or @Flag{a} --- Update all packages, if no packages are given in the argument list.}
@item{@DFlag{lookup} --- Checks Causes a @tech{package name} as a @nonterm{pkg-source} to be used @item{@DFlag{lookup} --- Causes a @tech{package name} as a @nonterm{pkg-source} to be used
as a replacement, instead of the name of a installed package that may have updates. as a replacement, instead of the name of a installed package that may have updates.
(If the named package was installed through a package name, then there's effectively (If the named package was installed through a package name, then there's effectively
no difference.)} no difference.)}
@ -534,6 +549,12 @@ the given @nonterm{pkg-source}s.
@item{@DFlag{skip-implies} --- Same as for @command-ref{install}.} @item{@DFlag{skip-implies} --- Same as for @command-ref{install}.}
@item{@DFlag{link} --- Same as for @command-ref{install}.} @item{@DFlag{link} --- Same as for @command-ref{install}.}
@item{@DFlag{static-link} --- Same as for @command-ref{install}.} @item{@DFlag{static-link} --- Same as for @command-ref{install}.}
@item{@DFlag{clone} @nonterm{dir} --- Same as for
@command-ref{install}, except that a @nonterm{pkg-source} can be
the name of an installed package. In that case, the package must
be currently installed from a Git or GitHub source, and that
source is used for the clone (which replaces the existing package
installation).}
@item{@DFlag{binary} --- Same as for @command-ref{install}.} @item{@DFlag{binary} --- Same as for @command-ref{install}.}
@item{@DFlag{copy} --- Same as for @command-ref{install}.} @item{@DFlag{copy} --- Same as for @command-ref{install}.}
@item{@DFlag{source} --- Same as for @command-ref{install}.} @item{@DFlag{source} --- Same as for @command-ref{install}.}
@ -550,6 +571,11 @@ the given @nonterm{pkg-source}s.
@item{@DFlag{no-setup} --- Same as for @command-ref{install}.} @item{@DFlag{no-setup} --- Same as for @command-ref{install}.}
@item{@DFlag{jobs} @nonterm{n} or @Flag{j} @nonterm{n} --- Same as for @command-ref{install}.} @item{@DFlag{jobs} @nonterm{n} or @Flag{j} @nonterm{n} --- Same as for @command-ref{install}.}
] ]
@history[#:changed "6.1.1.5" @elem{Added the @DFlag{clone} flag, and added
update of enclosing package when no
arguments are provided.}]
} }
@subcommand{@command/toc{remove} @nonterm{option} ... @nonterm{pkg} ... @subcommand{@command/toc{remove} @nonterm{option} ... @nonterm{pkg} ...
@ -581,12 +607,15 @@ the given @nonterm{pkg}s.
] ]
} }
@subcommand{@command/toc{new} @nonterm{package} ---
Populates a directory with the stubs for a new racket package, where @subcommand{@command/toc{new} @nonterm{pkg} ---
@nonterm{package} is the name of the new package. Populates a directory with the stubs for a new package, where
If @nonterm{package} already exists as a folder in the current directory, no new @nonterm{pkg} is the name of the new package.
If @nonterm{pkg} already exists as a directory in the current directory, no new
package is created. package is created.
}
@history[#:added "6.1.1.5"]}
@subcommand{@command/toc{show} @nonterm{option} ... --- Print information about currently installed packages. @subcommand{@command/toc{show} @nonterm{option} ... --- Print information about currently installed packages.
By default, packages are shown for all @tech{package scopes}, but only for packages By default, packages are shown for all @tech{package scopes}, but only for packages
@ -612,8 +641,7 @@ package is created.
@item{@DFlag{scope-dir} @nonterm{dir} --- Shows only packages installed in @nonterm{dir}.} @item{@DFlag{scope-dir} @nonterm{dir} --- Shows only packages installed in @nonterm{dir}.}
@item{@DFlag{version} @nonterm{vers} or @Flag{v} @nonterm{vers} --- Show only user-specific packages for @item{@DFlag{version} @nonterm{vers} or @Flag{v} @nonterm{vers} --- Show only user-specific packages for
the installation name/version @nonterm{vers}.} the installation name/version @nonterm{vers}.}
] ]}
}
@subcommand{@command/toc{migrate} @nonterm{option} ... @nonterm{from-version} @subcommand{@command/toc{migrate} @nonterm{option} ... @nonterm{from-version}
--- Installs packages that were previously installed in @exec{user} --- Installs packages that were previously installed in @exec{user}
@ -980,6 +1008,10 @@ The following @filepath{info.rkt} fields are used by the package manager:
@; ---------------------------------------- @; ----------------------------------------
@include-section["git-workflow.scrbl"]
@; ----------------------------------------
@include-section["apis.scrbl"] @include-section["apis.scrbl"]
@include-section["catalog-protocol.scrbl"] @include-section["catalog-protocol.scrbl"]

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

@ -18,10 +18,10 @@
(check-equal? (hash-ref (hash-ref details "pkg-test1") (check-equal? (hash-ref (hash-ref details "pkg-test1")
'source) 'source)
"http://localhost:9999/pkg-test1.zip") "http://localhost:9997/pkg-test1.zip")
(check-equal? (hash-ref (hash-ref details "pkg-test2") (check-equal? (hash-ref (hash-ref details "pkg-test2")
'source) 'source)
"http://localhost:9999/pkg-test2.zip") "http://localhost:9997/pkg-test2.zip")
(define test1-details (get-pkg-details-from-catalogs "pkg-test1")) (define test1-details (get-pkg-details-from-catalogs "pkg-test1"))
(check-equal? test1-details (check-equal? test1-details
@ -30,7 +30,7 @@
(define-values (cksum mods deps) (define-values (cksum mods deps)
(get-pkg-content (pkg-desc "pkg-test1" #f #f #f #f))) (get-pkg-content (pkg-desc "pkg-test1" #f #f #f #f)))
(define-values (cksum1 mods1 deps1) (define-values (cksum1 mods1 deps1)
(get-pkg-content (pkg-desc "http://localhost:9999/pkg-test1.zip" #f #f #f #f))) (get-pkg-content (pkg-desc "http://localhost:9997/pkg-test1.zip" #f #f #f #f)))
(check-equal? cksum cksum1) (check-equal? cksum cksum1)
(check-equal? (sort mods string<? #:key cadr) (check-equal? (sort mods string<? #:key cadr)

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

@ -29,13 +29,13 @@
$ (~a "raco pkg config --set catalogs file://" (path->string db)) $ (~a "raco pkg config --set catalogs file://" (path->string db))
$ "raco pkg catalog-show pkg-test1" $ "raco pkg catalog-show pkg-test1"
=stdout> #rx"Source: http://localhost:9999/pkg-test1.zip" =stdout> #rx"Source: http://localhost:9997/pkg-test1.zip"
(parameterize ([db:current-pkg-catalog-file db]) (parameterize ([db:current-pkg-catalog-file db])
(db:set-pkgs! "local" (db:set-pkgs! "local"
(append (db:get-pkgs) (append (db:get-pkgs)
(list (list
(db:pkg "fish" "local" "nemo@sub" "http://localhost:9999/fish.zip" "123" (db:pkg "fish" "local" "nemo@sub" "http://localhost:9997/fish.zip" "123"
"Not a whale")))) "Not a whale"))))
(db:set-pkg-modules! "fish" "local" "123" '((lib "fish/main.rkt") (lib "fish/food.rkt"))) (db:set-pkg-modules! "fish" "local" "123" '((lib "fish/main.rkt") (lib "fish/food.rkt")))
(db:set-pkg-dependencies! "fish" "local" "123" (db:set-pkg-dependencies! "fish" "local" "123"
@ -78,7 +78,7 @@
(lambda (o) (lambda (o)
(write (hash 'name "whale" (write (hash 'name "whale"
'checksum cksum 'checksum cksum
'source "http://localhost:9999/whale.plt" 'source "http://localhost:9997/whale.plt"
'versions (hash "5.3.6" 'versions (hash "5.3.6"
(hash 'checksum (hash 'checksum
123))) 123)))

10
pkgs/racket-pkgs/racket-test/tests/pkg/tests-checksums.rkt
View File

@ -43,7 +43,7 @@
(hasheq 'checksum (hasheq 'checksum
(file->string "test-pkgs/pkg-test1-bad-checksum.zip.CHECKSUM") (file->string "test-pkgs/pkg-test1-bad-checksum.zip.CHECKSUM")
'source 'source
"http://localhost:9999/pkg-test1-bad-checksum.zip")) "http://localhost:9997/pkg-test1-bad-checksum.zip"))
$ "raco pkg config --set catalogs http://localhost:9990 http://localhost:9991" $ "raco pkg config --set catalogs http://localhost:9990 http://localhost:9991"
$ "racket -e '(require pkg-test1)'" =exit> 1 $ "racket -e '(require pkg-test1)'" =exit> 1
$ "raco pkg install pkg-test1" =exit> 1 $ "raco pkg install pkg-test1" =exit> 1
@ -53,20 +53,20 @@
(shelly-case (shelly-case
"checksums are checked (remote)" "checksums are checked (remote)"
$ "racket -e '(require pkg-test1)'" =exit> 1 $ "racket -e '(require pkg-test1)'" =exit> 1
$ "raco pkg install http://localhost:9999/pkg-test1-bad-checksum.zip" =exit> 1 $ "raco pkg install http://localhost:9997/pkg-test1-bad-checksum.zip" =exit> 1
$ "racket -e '(require pkg-test1)'" =exit> 1)) $ "racket -e '(require pkg-test1)'" =exit> 1))
(with-fake-root (with-fake-root
(shelly-case (shelly-case
"checksums are required by default remotely (remote)" "checksums are required by default remotely (remote)"
$ "racket -e '(require pkg-test1)'" =exit> 1 $ "racket -e '(require pkg-test1)'" =exit> 1
$ "raco pkg install http://localhost:9999/pkg-test1-no-checksum.zip" =exit> 1 $ "raco pkg install http://localhost:9997/pkg-test1-no-checksum.zip" =exit> 1
$ "racket -e '(require pkg-test1)'" =exit> 1)) $ "racket -e '(require pkg-test1)'" =exit> 1))
(shelly-install* "but, bad checksums can be ignored (local)" (shelly-install* "but, bad checksums can be ignored (local)"
"--ignore-checksums test-pkgs/pkg-test1-bad-checksum.zip" "--ignore-checksums test-pkgs/pkg-test1-bad-checksum.zip"
"pkg-test1-bad-checksum") "pkg-test1-bad-checksum")
(shelly-install* "but, bad checksums can be ignored (remote)" (shelly-install* "but, bad checksums can be ignored (remote)"
"--ignore-checksums http://localhost:9999/pkg-test1-bad-checksum.zip" "--ignore-checksums http://localhost:9997/pkg-test1-bad-checksum.zip"
"pkg-test1-bad-checksum") "pkg-test1-bad-checksum")
(shelly-install* "but, checksums can be missing if ignored (remote)" (shelly-install* "but, checksums can be missing if ignored (remote)"
"--ignore-checksums http://localhost:9999/pkg-test1-no-checksum.zip" "--ignore-checksums http://localhost:9997/pkg-test1-no-checksum.zip"
"pkg-test1-no-checksum")))) "pkg-test1-no-checksum"))))

163
pkgs/racket-pkgs/racket-test/tests/pkg/tests-clone.rkt Normal file
View File

@ -0,0 +1,163 @@
#lang racket/base
(require rackunit
racket/file
racket/format
web-server/servlet-env
"util.rkt"
"shelly.rkt")
(this-test-is-run-by-the-main-test)
(define (set-file path content)
(call-with-output-file*
path
#:exists 'truncate/replace
(lambda (o) (displayln content o))))
(pkg-tests
(define git-exe (find-executable-path
(if (eq? 'windows (system-type)) "git.exe" "git")))
(when git-exe
(define tmp-dir (path->directory-path (make-temporary-file "pkg~a" 'directory)))
(define http-custodian (make-custodian))
(parameterize ([current-custodian http-custodian])
(thread
(lambda ()
(serve/servlet
void
#:command-line? #t
#:extra-files-paths
(list tmp-dir)
#:servlet-regexp #rx"$." ; no servlets
#:port 9998))))
(shelly-wind
(sync (system-idle-evt)) ; let web server get going
(define clone-dir (build-path tmp-dir "clones"))
(make-directory clone-dir)
(define a-dir (build-path tmp-dir "a"))
;; ----------------------------------------
;; Single-package repository
(make-directory a-dir)
$ (~a "cd " a-dir "; git init")
(set-file (build-path a-dir "main.rkt") "#lang racket/base 1")
(define (commit-changes-cmd [a-dir a-dir])
(~a "cd " a-dir "; git add .; git commit -m change; git update-server-info"))
$ (commit-changes-cmd)
(shelly-case
"basic --clone installation"
$ (~a "raco pkg install --clone " (build-path clone-dir "a") " --name a http://localhost:9998/a/.git")
$ "racket -l a" =stdout> "1\n")
(shelly-case
"update of --clone installation"
(set-file (build-path a-dir "main.rkt") "#lang racket/base 2")
$ (commit-changes-cmd)
$ (~a "raco pkg update a")
$ "racket -l a" =stdout> "2\n")
(shelly-case
"update of --clone installation doesn't overwrite local changes"
(set-file (build-path a-dir "main.rkt") "#lang racket/base 3")
$ (commit-changes-cmd)
(set-file (build-path clone-dir "a" "alt.rkt") "#lang racket/base 'one")
$ (~a "cd " (build-path clone-dir "a") "; git add .; git commit -m local")
$ "racket -l a" =stdout> "2\n"
$ "racket -l a/alt" =stdout> "'one\n"
$ (~a "raco pkg update a") =exit> 1 =stderr> #rx"fast-forward"
$ (~a "cd " (build-path clone-dir "a") "; git pull --rebase")
$ (~a "raco pkg update a")
$ "racket -l a" =stdout> "3\n"
$ "racket -l a/alt" =stdout> "'one\n")
(shelly-case
"update of --clone installation doesn't proceed past conflicts"
(set-file (build-path a-dir "main.rkt") "#lang racket/base 4")
$ (commit-changes-cmd)
(set-file (build-path clone-dir "a" "main.rkt") "#lang racket/base 3.5")
$ (~a "raco pkg update a") =exit> 1
$ "racket -l a" =stdout> "3.5\n")
(shelly-case
"removal of --clone installation leaves local clone intact"
$ "raco pkg remove a"
$ "racket -l a" =exit> 1
$ (~a "ls " (build-path clone-dir "a")))
(delete-directory/files (build-path clone-dir "a"))
(delete-directory/files a-dir)
;; ----------------------------------------
;; Multi-package repository
(make-directory a-dir)
$ (~a "cd " a-dir "; git init")
(make-directory* (build-path a-dir "one"))
(set-file (build-path a-dir "one" "main.rkt") "#lang racket/base 1")
(make-directory* (build-path a-dir "two"))
(set-file (build-path a-dir "two" "main.rkt") "#lang racket/base 2")
$ (commit-changes-cmd)
(shelly-case
"--clone installation with path into repository"
$ (~a "raco pkg install --clone " (build-path clone-dir "a") " --name one http://localhost:9998/a/.git?path=one")
$ "racket -l one" =stdout> "1\n"
$ (~a "ls " (build-path clone-dir "a")))
(shelly-case
"update of --clone installation"
(set-file (build-path a-dir "one" "main.rkt") "#lang racket/base 1.0")
$ (commit-changes-cmd)
$ (~a "raco pkg update one")
$ "racket -l one" =stdout> "1.0\n")
(shelly-case
"--clone second installation with path into same repository"
(set-file (build-path a-dir "one" "main.rkt") "#lang racket/base 'one")
$ (commit-changes-cmd)
$ (~a "raco pkg install --clone " (build-path clone-dir "a") " http://localhost:9998/a/.git?path=two")
$ "racket -l one" =stdout> "'one\n"
$ "racket -l two" =stdout> "2\n")
(shelly-case
"no changes => still an update, since previous update was implicit via shared repo"
$ "raco pkg update one" =stdout> #rx"Re-installing one\n")
(shelly-case
"no further changes => no update"
$ "raco pkg update one two" =stdout> #rx"No updates available\n")
$ "raco pkg remove one two"
(shelly-case
"conflicting repositories with the same name"
(define another-a-dir (build-path tmp-dir "another" "a"))
(make-directory* another-a-dir)
$ (~a "cd " another-a-dir "; git init")
(make-directory* (build-path another-a-dir "two"))
(set-file (build-path another-a-dir "two" "main.rkt") "#lang racket/base 'two")
$ (commit-changes-cmd another-a-dir)
;; A wacky merge of repsitories will happen here, but the checkout should not
;; get mangled. The package manager should bail out at the point that it would
;; try to rebase the single "a" clone on different commits.
$ (~a "raco pkg install --clone " (build-path clone-dir "a")
" http://localhost:9998/a/.git?path=one"
" http://localhost:9998/another/a/.git?path=two")
=exit> 1
=stderr> #rx"different target commits"
;; Check that the old repo checkout is not mangled:
$ (~a "racket " (build-path clone-dir "a" "two" "main.rkt")) =stdout> "2\n")
;; ----------------------------------------
(finally
(custodian-shutdown-all http-custodian)
(delete-directory/files tmp-dir)))))

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

@ -108,7 +108,7 @@
$ "racket -e '(require pkg-test2)'" =exit> 1 $ "racket -e '(require pkg-test2)'" =exit> 1
$ "raco pkg install --deps search-auto test-pkgs/pkg-test2.zip" $ "raco pkg install --deps search-auto test-pkgs/pkg-test2.zip"
=exit> 0 =exit> 0
=stdout> "Resolving \"pkg-test1\" via http://localhost:9990\nDownloading http://localhost:9999/pkg-test1.zip\nThe following uninstalled packages were listed as dependencies\nand they were automatically installed:\n dependencies of pkg-test2:\n pkg-test1\n" =stdout> "Resolving \"pkg-test1\" via http://localhost:9990\nDownloading http://localhost:9997/pkg-test1.zip\nThe following uninstalled packages were listed as dependencies\nand they were automatically installed:\n dependencies of pkg-test2:\n pkg-test1\n"
=stderr> "" =stderr> ""
$ "racket -e '(require pkg-test2)'" =exit> 0 $ "racket -e '(require pkg-test2)'" =exit> 0
$ "racket -e '(require pkg-test2/contains-dep)'" =exit> 0 $ "racket -e '(require pkg-test2/contains-dep)'" =exit> 0

4
pkgs/racket-pkgs/racket-test/tests/pkg/tests-implies.rkt
View File

@ -20,13 +20,13 @@
(hasheq 'checksum (hasheq 'checksum
(file->string (format "test-pkgs/pkg-implied-~a.zip.CHECKSUM" s)) (file->string (format "test-pkgs/pkg-implied-~a.zip.CHECKSUM" s))
'source 'source
(format "http://localhost:9999/pkg-implied-~a.zip" s)))) (format "http://localhost:9997/pkg-implied-~a.zip" s))))
(implied-version! "one") (implied-version! "one")
(hash-set! *index-ht-1* "pkg-implies" (hash-set! *index-ht-1* "pkg-implies"
(hasheq 'checksum (hasheq 'checksum
(file->string "test-pkgs/pkg-implies.zip.CHECKSUM") (file->string "test-pkgs/pkg-implies.zip.CHECKSUM")
'source 'source
"http://localhost:9999/pkg-implies.zip")) "http://localhost:9997/pkg-implies.zip"))
(with-fake-root (with-fake-root
(shelly-begin (shelly-begin

12
pkgs/racket-pkgs/racket-test/tests/pkg/tests-install.rkt
View File

@ -59,9 +59,9 @@
$ "raco pkg install test-pkgs/pkg-test1.zip.CHECKSUM" =exit> 1) $ "raco pkg install test-pkgs/pkg-test1.zip.CHECKSUM" =exit> 1)
(shelly-install "remote/URL/http package (file, tgz)" (shelly-install "remote/URL/http package (file, tgz)"
"http://localhost:9999/pkg-test1.tgz") "http://localhost:9997/pkg-test1.tgz")
(shelly-install "remote/URL/http package (directory)" (shelly-install "remote/URL/http package (directory)"
"http://localhost:9999/pkg-test1/") "http://localhost:9997/pkg-test1/")
(with-fake-root (with-fake-root
(shelly-begin (shelly-begin
@ -96,19 +96,19 @@
(shelly-case (shelly-case
"remote/URL/http directory, non-existant file" "remote/URL/http directory, non-existant file"
$ "raco pkg install http://localhost:9999/pkg-test1.rar" =exit> 1) $ "raco pkg install http://localhost:9997/pkg-test1.rar" =exit> 1)
(shelly-case (shelly-case
"remote/URL/http directory, no manifest fail" "remote/URL/http directory, no manifest fail"
$ "raco pkg install http://localhost:9999/pkg-test1/pkg-test1/" $ "raco pkg install http://localhost:9997/pkg-test1/pkg-test1/"
=exit> 1 =exit> 1
=stderr> #rx"could not find MANIFEST") =stderr> #rx"could not find MANIFEST")
(shelly-case (shelly-case
"remote/URL/http directory, bad manifest" "remote/URL/http directory, bad manifest"
;; XXX why does this error now? ;; XXX why does this error now?
$ "raco pkg install http://localhost:9999/pkg-test1-manifest-error/" =exit> 1) $ "raco pkg install http://localhost:9997/pkg-test1-manifest-error/" =exit> 1)
(shelly-case (shelly-case
"remote/URL/file, bad checksum" "remote/URL/file, bad checksum"
$ "raco pkg install --checksum zzz http://localhost:9999/pkg-test1.tgz" $ "raco pkg install --checksum zzz http://localhost:9997/pkg-test1.tgz"
=exit> 1 =exit> 1
=stderr> #rx"mismatched checksum") =stderr> #rx"mismatched checksum")

4
pkgs/racket-pkgs/racket-test/tests/pkg/tests-migrate.rkt
View File

@ -15,12 +15,12 @@
(hasheq 'checksum (hasheq 'checksum
(file->string "test-pkgs/pkg-b-second.plt.CHECKSUM") (file->string "test-pkgs/pkg-b-second.plt.CHECKSUM")
'source 'source
"http://localhost:9999/pkg-b-second.plt")) "http://localhost:9997/pkg-b-second.plt"))
(hash-set! *index-ht-1* "pkg-a" (hash-set! *index-ht-1* "pkg-a"
(hasheq 'checksum (hasheq 'checksum
(file->string "test-pkgs/pkg-a-first.plt.CHECKSUM") (file->string "test-pkgs/pkg-a-first.plt.CHECKSUM")
'source 'source
"http://localhost:9999/pkg-a-first.plt")) "http://localhost:9997/pkg-a-first.plt"))
$ "raco pkg install -u --deps search-auto pkg-b" =exit> 0 $ "raco pkg install -u --deps search-auto pkg-b" =exit> 0
$ "raco pkg show -u -a" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source\npkg-a\\* +[a-f0-9]+ \\(catalog pkg-a\\)\npkg-b +[a-f0-9]+ +\\(catalog pkg-b\\)\n" $ "raco pkg show -u -a" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source\npkg-a\\* +[a-f0-9]+ \\(catalog pkg-a\\)\npkg-b +[a-f0-9]+ +\\(catalog pkg-b\\)\n"
$ (~a "racket" $ (~a "racket"

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

@ -96,6 +96,8 @@
(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/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 "github://github.com/../fish/release" #f #rx"indicator") (values #f 'github #f))
(check-equal-values? (parse "github://github.com/racket/fish/master" 'clone) (values "fish" 'clone #t))
(check-equal-values? (parse "github://github.com/fish/master" 'clone #rx"three") (values #f 'clone #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))
@ -111,6 +113,8 @@
(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/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://github.com/../fish" #f #rx"indicator") (values #f 'github #f))
(check-equal-values? (parse "git://github.com/racket/fish" 'clone) (values "fish" 'clone #t))
(check-equal-values? (parse "racket/fish" 'github) (values "fish" 'github #t))
(check-equal-values? (parse "git://not-github.com/racket/fish" #f #f) (values "fish" 'git #t)) (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" #f #f) (values "fish" 'git #t))
@ -123,6 +127,8 @@
(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/../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 "git://not-github.com/.././" #f #rx"indicator") (values #f 'git #f))
(check-equal-values? (parse "git://not-github.com/racket/fish" 'clone #f) (values "fish" 'clone #t))
(check-equal-values? (parse "git://not-github.com/.././" 'clone #rx"indicator") (values #f 'clone #f))
(check-equal-values? (parse "http://racket-lang.org/racket/fish" 'git #f) (values "fish" 'git #t)) (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" 'git #f) (values "fish" 'git #t))
@ -155,7 +161,7 @@
(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 "" 'git) (values #f 'git #f))
(check-equal-values? (parse "" 'github #rx"empty") (values #f 'github #f)) (check-equal-values? (parse "" 'github #rx"two path elements") (values #f 'github #f))
(void)) (void))

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

@ -48,7 +48,7 @@
$ "cp -f test-pkgs/pkg-test1.zip test-pkgs/update-test/pkg-test1.zip" $ "cp -f test-pkgs/pkg-test1.zip test-pkgs/update-test/pkg-test1.zip"
$ "cp -f test-pkgs/pkg-test1.zip.CHECKSUM test-pkgs/update-test/pkg-test1.zip.CHECKSUM" $ "cp -f test-pkgs/pkg-test1.zip.CHECKSUM test-pkgs/update-test/pkg-test1.zip.CHECKSUM"
(shelly-install* "remote packages can be updated" (shelly-install* "remote packages can be updated"
"http://localhost:9999/update-test/pkg-test1.zip" "http://localhost:9997/update-test/pkg-test1.zip"
"pkg-test1 pkg-test3" "pkg-test1 pkg-test3"
$ "raco pkg install --copy test-pkgs/pkg-test3" $ "raco pkg install --copy test-pkgs/pkg-test3"
$ "racket -l pkg-test3/number" =exit> 1 $ "racket -l pkg-test3/number" =exit> 1

12
pkgs/racket-pkgs/racket-test/tests/pkg/tests-update-auto.rkt
View File

@ -11,7 +11,7 @@
(hasheq 'checksum (hasheq 'checksum
(file->string "test-pkgs/pkg-b-first.plt.CHECKSUM") (file->string "test-pkgs/pkg-b-first.plt.CHECKSUM")
'source 'source
"http://localhost:9999/pkg-b-first.plt")) "http://localhost:9997/pkg-b-first.plt"))
$ "raco pkg config --set catalogs http://localhost:9990" $ "raco pkg config --set catalogs http://localhost:9990"
$ "raco pkg install pkg-b" $ "raco pkg install pkg-b"
$ "racket -e '(require pkg-b)'" =exit> 42 $ "racket -e '(require pkg-b)'" =exit> 42
@ -19,12 +19,12 @@
(hasheq 'checksum (hasheq 'checksum
(file->string "test-pkgs/pkg-b-second.plt.CHECKSUM") (file->string "test-pkgs/pkg-b-second.plt.CHECKSUM")
'source 'source
"http://localhost:9999/pkg-b-second.plt")) "http://localhost:9997/pkg-b-second.plt"))
(hash-set! *index-ht-1* "pkg-a" (hash-set! *index-ht-1* "pkg-a"
(hasheq 'checksum (hasheq 'checksum
(file->string "test-pkgs/pkg-a-first.plt.CHECKSUM") (file->string "test-pkgs/pkg-a-first.plt.CHECKSUM")
'source 'source
"http://localhost:9999/pkg-a-first.plt")))) "http://localhost:9997/pkg-a-first.plt"))))
(pkg-tests (pkg-tests
(shelly-case (shelly-case
@ -41,12 +41,12 @@
(hasheq 'checksum (hasheq 'checksum
(file->string "test-pkgs/pkg-b-second.plt.CHECKSUM") (file->string "test-pkgs/pkg-b-second.plt.CHECKSUM")
'source 'source
"http://localhost:9999/pkg-b-second.plt")) "http://localhost:9997/pkg-b-second.plt"))
(hash-set! *index-ht-1* "pkg-a" (hash-set! *index-ht-1* "pkg-a"
(hasheq 'checksum (hasheq 'checksum
(file->string "test-pkgs/pkg-a-first.plt.CHECKSUM") (file->string "test-pkgs/pkg-a-first.plt.CHECKSUM")
'source 'source
"http://localhost:9999/pkg-a-first.plt")) "http://localhost:9997/pkg-a-first.plt"))
$ "raco pkg install --deps search-auto pkg-b" =exit> 0 <input= "y\n" $ "raco pkg install --deps search-auto pkg-b" =exit> 0 <input= "y\n"
$ "raco pkg show -u -a" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source\npkg-a\\* +[a-f0-9]+ \\(catalog pkg-a\\)\npkg-b +[a-f0-9]+ +\\(catalog pkg-b\\)\n" $ "raco pkg show -u -a" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source\npkg-a\\* +[a-f0-9]+ \\(catalog pkg-a\\)\npkg-b +[a-f0-9]+ +\\(catalog pkg-b\\)\n"
$ "racket -e '(require pkg-b)'" =exit> 43 $ "racket -e '(require pkg-b)'" =exit> 43
@ -61,7 +61,7 @@
(hasheq 'checksum (hasheq 'checksum
(file->string "test-pkgs/pkg-a-second.plt.CHECKSUM") (file->string "test-pkgs/pkg-a-second.plt.CHECKSUM")
'source 'source
"http://localhost:9999/pkg-a-second.plt")) "http://localhost:9997/pkg-a-second.plt"))
$ "raco pkg update -a" =exit> 0 $ "raco pkg update -a" =exit> 0
$ "racket -e '(require pkg-a)'" =exit> 43 $ "racket -e '(require pkg-a)'" =exit> 43
$ "raco pkg remove pkg-b" $ "raco pkg remove pkg-b"

10
pkgs/racket-pkgs/racket-test/tests/pkg/tests-update-deps.rkt
View File

@ -11,7 +11,7 @@
(hasheq 'checksum (hasheq 'checksum
(file->string "test-pkgs/pkg-b-first.plt.CHECKSUM") (file->string "test-pkgs/pkg-b-first.plt.CHECKSUM")
'source 'source
"http://localhost:9999/pkg-b-first.plt")) "http://localhost:9997/pkg-b-first.plt"))
$ "raco pkg config --set catalogs http://localhost:9990" $ "raco pkg config --set catalogs http://localhost:9990"
$ "raco pkg install pkg-b" $ "raco pkg install pkg-b"
$ "racket -e '(require pkg-b)'" =exit> 42 $ "racket -e '(require pkg-b)'" =exit> 42
@ -19,12 +19,12 @@
(hasheq 'checksum (hasheq 'checksum
(file->string "test-pkgs/pkg-b-second.plt.CHECKSUM") (file->string "test-pkgs/pkg-b-second.plt.CHECKSUM")
'source 'source
"http://localhost:9999/pkg-b-second.plt")) "http://localhost:9997/pkg-b-second.plt"))
(hash-set! *index-ht-1* "pkg-a" (hash-set! *index-ht-1* "pkg-a"
(hasheq 'checksum (hasheq 'checksum
(file->string "test-pkgs/pkg-a-first.plt.CHECKSUM") (file->string "test-pkgs/pkg-a-first.plt.CHECKSUM")
'source 'source
"http://localhost:9999/pkg-a-first.plt")))) "http://localhost:9997/pkg-a-first.plt"))))
(pkg-tests (pkg-tests
(shelly-case (shelly-case
@ -86,7 +86,7 @@
(hasheq 'checksum (hasheq 'checksum
(file->string "test-pkgs/pkg-a-second.plt.CHECKSUM") (file->string "test-pkgs/pkg-a-second.plt.CHECKSUM")
'source 'source
"http://localhost:9999/pkg-a-second.plt")) "http://localhost:9997/pkg-a-second.plt"))
$ "racket -e '(require pkg-a)'" =exit> 0 $ "racket -e '(require pkg-a)'" =exit> 0
$ "raco pkg update pkg-a" =exit> 0 $ "raco pkg update pkg-a" =exit> 0
$ "racket -e '(require pkg-a)'" =exit> 43 $ "racket -e '(require pkg-a)'" =exit> 43
@ -104,7 +104,7 @@
(hasheq 'checksum (hasheq 'checksum
(file->string "test-pkgs/pkg-a-third.plt.CHECKSUM") (file->string "test-pkgs/pkg-a-third.plt.CHECKSUM")
'source 'source
"http://localhost:9999/pkg-a-third.plt")) "http://localhost:9997/pkg-a-third.plt"))
$ "racket -e '(require pkg-a)'" =exit> 0 $ "racket -e '(require pkg-a)'" =exit> 0
$ "raco pkg update pkg-a" =exit> 1 $ "raco pkg update pkg-a" =exit> 1
$ "racket -e '(require pkg-a)'" =exit> 0 $ "racket -e '(require pkg-a)'" =exit> 0

24
pkgs/racket-pkgs/racket-test/tests/pkg/tests-update.rkt
View File

@ -78,7 +78,7 @@
$ "cp -f test-pkgs/pkg-test1.zip test-pkgs/update-test/pkg-test1.zip" $ "cp -f test-pkgs/pkg-test1.zip test-pkgs/update-test/pkg-test1.zip"
$ "cp -f test-pkgs/pkg-test1.zip.CHECKSUM test-pkgs/update-test/pkg-test1.zip.CHECKSUM" $ "cp -f test-pkgs/pkg-test1.zip.CHECKSUM test-pkgs/update-test/pkg-test1.zip.CHECKSUM"
(shelly-install* "remote packages can be updated" (shelly-install* "remote packages can be updated"
"http://localhost:9999/update-test/pkg-test1.zip" "http://localhost:9997/update-test/pkg-test1.zip"
"pkg-test1" "pkg-test1"
$ "raco pkg update pkg-test1" =exit> 0 =stdout> "Downloading checksum for pkg-test1\nNo updates available\n" $ "raco pkg update pkg-test1" =exit> 0 =stdout> "Downloading checksum for pkg-test1\nNo updates available\n"
$ "racket -e '(require pkg-test1/update)'" =exit> 42 $ "racket -e '(require pkg-test1/update)'" =exit> 42
@ -95,7 +95,7 @@
$ "cp -f test-pkgs/pkg-test3.zip test-pkgs/update-test/pkg-test3.zip" $ "cp -f test-pkgs/pkg-test3.zip test-pkgs/update-test/pkg-test3.zip"
$ "cp -f test-pkgs/pkg-test3.zip.CHECKSUM test-pkgs/update-test/pkg-test3.zip.CHECKSUM" $ "cp -f test-pkgs/pkg-test3.zip.CHECKSUM test-pkgs/update-test/pkg-test3.zip.CHECKSUM"
(shelly-install* "remote packages can be updated, single-collection to multi-collection" (shelly-install* "remote packages can be updated, single-collection to multi-collection"
"test-pkgs/pkg-test1.zip http://localhost:9999/update-test/pkg-test3.zip" "test-pkgs/pkg-test1.zip http://localhost:9997/update-test/pkg-test3.zip"
"pkg-test1 pkg-test3" "pkg-test1 pkg-test3"
$ "raco pkg update pkg-test3" =exit> 0 =stdout> "Downloading checksum for pkg-test3\nNo updates available\n" $ "raco pkg update pkg-test3" =exit> 0 =stdout> "Downloading checksum for pkg-test3\nNo updates available\n"
$ "cp -f test-pkgs/pkg-test3-v2.zip test-pkgs/update-test/pkg-test3.zip" $ "cp -f test-pkgs/pkg-test3-v2.zip test-pkgs/update-test/pkg-test3.zip"
@ -111,7 +111,7 @@
$ "cp -f test-pkgs/pkg-test3-v2.zip test-pkgs/update-test/pkg-test3.zip" $ "cp -f test-pkgs/pkg-test3-v2.zip test-pkgs/update-test/pkg-test3.zip"
$ "cp -f test-pkgs/pkg-test3-v2.zip.CHECKSUM test-pkgs/update-test/pkg-test3.zip.CHECKSUM" $ "cp -f test-pkgs/pkg-test3-v2.zip.CHECKSUM test-pkgs/update-test/pkg-test3.zip.CHECKSUM"
(shelly-install* "remote packages can be updated, multi-colelction to single-collection" (shelly-install* "remote packages can be updated, multi-colelction to single-collection"
"test-pkgs/pkg-test1.zip http://localhost:9999/update-test/pkg-test3.zip" "test-pkgs/pkg-test1.zip http://localhost:9997/update-test/pkg-test3.zip"
"pkg-test1 pkg-test3" "pkg-test1 pkg-test3"
$ "raco pkg update pkg-test3" =exit> 0 =stdout> "Downloading checksum for pkg-test3\nNo updates available\n" $ "raco pkg update pkg-test3" =exit> 0 =stdout> "Downloading checksum for pkg-test3\nNo updates available\n"
$ "cp -f test-pkgs/pkg-test3.zip test-pkgs/update-test/pkg-test3.zip" $ "cp -f test-pkgs/pkg-test3.zip test-pkgs/update-test/pkg-test3.zip"
@ -129,9 +129,9 @@
$ "cp -f test-pkgs/pkg-test2.zip test-pkgs/update-test/pkg-test2.zip" $ "cp -f test-pkgs/pkg-test2.zip test-pkgs/update-test/pkg-test2.zip"
$ "cp -f test-pkgs/pkg-test2.zip.CHECKSUM test-pkgs/update-test/pkg-test2.zip.CHECKSUM" $ "cp -f test-pkgs/pkg-test2.zip.CHECKSUM test-pkgs/update-test/pkg-test2.zip.CHECKSUM"
(shelly-install* "update deps" (shelly-install* "update deps"
"http://localhost:9999/update-test/pkg-test1.zip" "http://localhost:9997/update-test/pkg-test1.zip"
"pkg-test1" "pkg-test1"
$ "raco pkg install http://localhost:9999/update-test/pkg-test2.zip" $ "raco pkg install http://localhost:9997/update-test/pkg-test2.zip"
$ "raco pkg update --update-deps pkg-test2" =exit> 0 $ "raco pkg update --update-deps pkg-test2" =exit> 0
=stdout> "Downloading checksum for pkg-test2\nDownloading checksum for pkg-test1\nNo updates available\n" =stdout> "Downloading checksum for pkg-test2\nDownloading checksum for pkg-test1\nNo updates available\n"
$ "racket -e '(require pkg-test1/update)'" =exit> 42 $ "racket -e '(require pkg-test1/update)'" =exit> 42
@ -151,9 +151,9 @@
$ "cp -f test-pkgs/pkg-test3.zip test-pkgs/update-test/pkg-test3.zip" $ "cp -f test-pkgs/pkg-test3.zip test-pkgs/update-test/pkg-test3.zip"
$ "cp -f test-pkgs/pkg-test3.zip.CHECKSUM test-pkgs/update-test/pkg-test3.zip.CHECKSUM" $ "cp -f test-pkgs/pkg-test3.zip.CHECKSUM test-pkgs/update-test/pkg-test3.zip.CHECKSUM"
(shelly-install* "update original and deps" (shelly-install* "update original and deps"
"http://localhost:9999/update-test/pkg-test1.zip" "http://localhost:9997/update-test/pkg-test1.zip"
"pkg-test1" "pkg-test1"
$ "raco pkg install http://localhost:9999/update-test/pkg-test3.zip" $ "raco pkg install http://localhost:9997/update-test/pkg-test3.zip"
$ "raco pkg update --update-deps pkg-test3" =exit> 0 $ "raco pkg update --update-deps pkg-test3" =exit> 0
=stdout> "Downloading checksum for pkg-test3\nDownloading checksum for pkg-test1\nNo updates available\n" =stdout> "Downloading checksum for pkg-test3\nDownloading checksum for pkg-test1\nNo updates available\n"
$ "racket -e '(require pkg-test1/update)'" =exit> 42 $ "racket -e '(require pkg-test1/update)'" =exit> 42
@ -176,9 +176,9 @@
$ "cp -f test-pkgs/pkg-test3.zip test-pkgs/update-test/pkg-test3.zip" $ "cp -f test-pkgs/pkg-test3.zip test-pkgs/update-test/pkg-test3.zip"
$ "cp -f test-pkgs/pkg-test3.zip.CHECKSUM test-pkgs/update-test/pkg-test3.zip.CHECKSUM" $ "cp -f test-pkgs/pkg-test3.zip.CHECKSUM test-pkgs/update-test/pkg-test3.zip.CHECKSUM"
(shelly-install* "update original, where update has no deps" (shelly-install* "update original, where update has no deps"
"http://localhost:9999/update-test/pkg-test1.zip" "http://localhost:9997/update-test/pkg-test1.zip"
"pkg-test1" "pkg-test1"
$ "raco pkg install http://localhost:9999/update-test/pkg-test3.zip" $ "raco pkg install http://localhost:9997/update-test/pkg-test3.zip"
$ "raco pkg update --update-deps pkg-test3" =exit> 0 $ "raco pkg update --update-deps pkg-test3" =exit> 0
=stdout> "Downloading checksum for pkg-test3\nDownloading checksum for pkg-test1\nNo updates available\n" =stdout> "Downloading checksum for pkg-test3\nDownloading checksum for pkg-test1\nNo updates available\n"
$ "racket -e '(require pkg-test1/update)'" =exit> 42 $ "racket -e '(require pkg-test1/update)'" =exit> 42
@ -201,9 +201,9 @@
$ "cp -f test-pkgs/pkg-test3-v3.zip test-pkgs/update-test/pkg-test3.zip" $ "cp -f test-pkgs/pkg-test3-v3.zip test-pkgs/update-test/pkg-test3.zip"
$ "cp -f test-pkgs/pkg-test3-v3.zip.CHECKSUM test-pkgs/update-test/pkg-test3.zip.CHECKSUM" $ "cp -f test-pkgs/pkg-test3-v3.zip.CHECKSUM test-pkgs/update-test/pkg-test3.zip.CHECKSUM"
(shelly-install* "update and get updates for newly introduced deps" (shelly-install* "update and get updates for newly introduced deps"
"http://localhost:9999/update-test/pkg-test1.zip" "http://localhost:9997/update-test/pkg-test1.zip"
"pkg-test1" "pkg-test1"
$ "raco pkg install http://localhost:9999/update-test/pkg-test3.zip" $ "raco pkg install http://localhost:9997/update-test/pkg-test3.zip"
$ "racket -e '(require pkg-test3)'" =stdout> #rx"version 3 loaded" $ "racket -e '(require pkg-test3)'" =stdout> #rx"version 3 loaded"
$ "raco pkg update --update-deps pkg-test3" =exit> 0 $ "raco pkg update --update-deps pkg-test3" =exit> 0
=stdout> "Downloading checksum for pkg-test3\nNo updates available\n" =stdout> "Downloading checksum for pkg-test3\nNo updates available\n"
@ -225,7 +225,7 @@
$ "cp -f test-pkgs/pkg-test1.zip test-pkgs/update-test/pkg-test1.zip" $ "cp -f test-pkgs/pkg-test1.zip test-pkgs/update-test/pkg-test1.zip"
$ "cp -f test-pkgs/pkg-test1.zip.CHECKSUM test-pkgs/update-test/pkg-test1.zip.CHECKSUM" $ "cp -f test-pkgs/pkg-test1.zip.CHECKSUM test-pkgs/update-test/pkg-test1.zip.CHECKSUM"
(shelly-install* "update all" (shelly-install* "update all"
"http://localhost:9999/update-test/pkg-test1.zip" "http://localhost:9997/update-test/pkg-test1.zip"
"pkg-test1" "pkg-test1"
$ "raco pkg install test-pkgs/pkg-test2.zip" $ "raco pkg install test-pkgs/pkg-test2.zip"
$ "raco pkg update -a" =exit> 0 =stdout> "Downloading checksum for pkg-test1\nNo updates available\n" $ "raco pkg update -a" =exit> 0 =stdout> "Downloading checksum for pkg-test1\nNo updates available\n"

12
pkgs/racket-pkgs/racket-test/tests/pkg/tests-versions.rkt
View File

@ -30,13 +30,13 @@
(hasheq 'checksum (hasheq 'checksum
(file->string "test-pkgs/pkg-v-one.zip.CHECKSUM") (file->string "test-pkgs/pkg-v-one.zip.CHECKSUM")
'source 'source
"http://localhost:9999/pkg-v-one.zip")) "http://localhost:9997/pkg-v-one.zip"))
(hash-set! *index-ht-1* "pkg-w" (hash-set! *index-ht-1* "pkg-w"
(hasheq 'checksum (hasheq 'checksum
(file->string "test-pkgs/pkg-w-one.zip.CHECKSUM") (file->string "test-pkgs/pkg-w-one.zip.CHECKSUM")
'source 'source
"http://localhost:9999/pkg-w-one.zip")) "http://localhost:9997/pkg-w-one.zip"))
$ "raco pkg config --set catalogs http://localhost:9990" $ "raco pkg config --set catalogs http://localhost:9990"
@ -57,7 +57,7 @@
(hasheq 'checksum (hasheq 'checksum
(file->string "test-pkgs/pkg-v-two.zip.CHECKSUM") (file->string "test-pkgs/pkg-v-two.zip.CHECKSUM")
'source 'source
"http://localhost:9999/pkg-v-two.zip")) "http://localhost:9997/pkg-v-two.zip"))
(shelly-case (shelly-case
"update" "update"
@ -68,12 +68,12 @@
(hasheq 'checksum (hasheq 'checksum
(file->string "test-pkgs/pkg-v-three.zip.CHECKSUM") (file->string "test-pkgs/pkg-v-three.zip.CHECKSUM")
'source 'source
"http://localhost:9999/pkg-v-three.zip")) "http://localhost:9997/pkg-v-three.zip"))
(hash-set! *index-ht-1* "pkg-w" (hash-set! *index-ht-1* "pkg-w"
(hasheq 'checksum (hasheq 'checksum
(file->string "test-pkgs/pkg-w-two.zip.CHECKSUM") (file->string "test-pkgs/pkg-w-two.zip.CHECKSUM")
'source 'source
"http://localhost:9999/pkg-w-two.zip")) "http://localhost:9997/pkg-w-two.zip"))
(shelly-case (shelly-case
"update again" "update again"
@ -85,7 +85,7 @@
(hasheq 'checksum (hasheq 'checksum
(file->string "test-pkgs/pkg-w-three.zip.CHECKSUM") (file->string "test-pkgs/pkg-w-three.zip.CHECKSUM")
'source 'source
"http://localhost:9999/pkg-w-three.zip")) "http://localhost:9997/pkg-w-three.zip"))
(shelly-case (shelly-case
"update again" "update again"

8
pkgs/racket-pkgs/racket-test/tests/pkg/util.rkt
View File

@ -108,7 +108,7 @@
(define (start-file-server) (define (start-file-server)
(serve/servlet (λ (req) (response/xexpr "None")) (serve/servlet (λ (req) (response/xexpr "None"))
#:command-line? #t #:command-line? #t
#:port 9999 #:port 9997
#:extra-files-paths (list (build-path test-directory "test-pkgs")))) #:extra-files-paths (list (build-path test-directory "test-pkgs"))))
(require "basic-index.rkt") (require "basic-index.rkt")
@ -192,7 +192,7 @@
(hasheq 'checksum (hasheq 'checksum
(file->string "test-pkgs/pkg-test1.zip.CHECKSUM") (file->string "test-pkgs/pkg-test1.zip.CHECKSUM")
'source 'source
"http://localhost:9999/pkg-test1.zip" "http://localhost:9997/pkg-test1.zip"
'tags 'tags
'("first"))) '("first")))
@ -200,7 +200,7 @@
(hasheq 'checksum (hasheq 'checksum
(file->string "test-pkgs/pkg-test2.zip.CHECKSUM") (file->string "test-pkgs/pkg-test2.zip.CHECKSUM")
'source 'source
"http://localhost:9999/pkg-test2.zip" "http://localhost:9997/pkg-test2.zip"
'dependencies 'dependencies
'("pkg-test1"))) '("pkg-test1")))
@ -208,7 +208,7 @@
(hasheq 'checksum (hasheq 'checksum
(file->string "test-pkgs/pkg-test2.zip.CHECKSUM") (file->string "test-pkgs/pkg-test2.zip.CHECKSUM")
'source 'source
"http://localhost:9999/pkg-test2.zip" "http://localhost:9997/pkg-test2.zip"
'dependencies 'dependencies
'("pkg-test1")))) '("pkg-test1"))))

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

@ -34,6 +34,12 @@
(or/c 'installation 'user (or/c 'installation 'user
(and/c path? complete-path?))) (and/c path? complete-path?)))
(define pkg-desc/opt
(let ([pkg-desc (lambda (source type name checksum auto?
#:path [path #f])
(pkg-desc source type name checksum auto? path))])
pkg-desc))
(provide (provide
(all-from-out "path.rkt") (all-from-out "path.rkt")
with-pkg-lock with-pkg-lock
@ -58,13 +64,15 @@
(parameter/c (or/c #f real?))] (parameter/c (or/c #f real?))]
[pkg-directory [pkg-directory
(-> string? (or/c path-string? #f))] (-> string? (or/c path-string? #f))]
[pkg-desc [rename
(-> string? pkg-desc/opt pkg-desc
(or/c #f 'file 'dir 'link 'static-link 'file-url 'dir-url 'git 'github 'name) (->* (string?
(or/c string? #f) (or/c #f 'file 'dir 'link 'static-link 'file-url 'dir-url 'git 'github 'clone 'name)
(or/c string? #f) (or/c string? #f)
boolean? (or/c string? #f)
pkg-desc?)] boolean?)
(#:path (or/c #f path-string?))
pkg-desc?)]
[pkg-config [pkg-config
(->* (boolean? (listof string?)) (->* (boolean? (listof string?))
(#:from-command-line? boolean?) (#:from-command-line? boolean?)

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

@ -114,7 +114,8 @@
#:install-force-flags (install-force-flags ...) #:install-force-flags (install-force-flags ...)
#:update-deps-flags (update-deps-flags ...) #:update-deps-flags (update-deps-flags ...)
#:install-copy-flags (install-copy-flags ...) #:install-copy-flags (install-copy-flags ...)
#:install-copy-defns (install-copy-defns ...)) #:install-copy-defns (install-copy-defns ...)
#:install-copy-checks (install-copy-checks ...))
(with-syntax ([([scope-flags ...] (with-syntax ([([scope-flags ...]
[job-flags ...] [job-flags ...]
[catalog-flags ...] [catalog-flags ...]
@ -123,7 +124,8 @@
[install-force-flags ...] [install-force-flags ...]
[update-deps-flags ...] [update-deps-flags ...]
[install-copy-flags ...] [install-copy-flags ...]
[install-copy-defns ...]) [install-copy-defns ...]
[install-copy-checks ...])
(syntax-local-introduce #'([scope-flags ...] (syntax-local-introduce #'([scope-flags ...]
[job-flags ...] [job-flags ...]
[catalog-flags ...] [catalog-flags ...]
@ -132,7 +134,8 @@
[install-force-flags ...] [install-force-flags ...]
[update-deps-flags ...] [update-deps-flags ...]
[install-copy-flags ...] [install-copy-flags ...]
[install-copy-defns ...]))]) [install-copy-defns ...]
[install-copy-checks ...]))])
#`(commands #`(commands
"This tool is used for managing installed packages." "This tool is used for managing installed packages."
"pkg-~a-command" "pkg-~a-command"
@ -167,6 +170,7 @@
'install 'install
scope scope-dir installation user #f a-type scope scope-dir installation user #f a-type
(lambda () (lambda ()
install-copy-checks ...
(when (and name (> (length pkg-source) 1)) (when (and name (> (length pkg-source) 1))
((current-pkg-error) (format "the --name flag only makes sense with a single package source"))) ((current-pkg-error) (format "the --name flag only makes sense with a single package source")))
(unless (or (not name) (package-source->name name)) (unless (or (not name) (package-source->name name))
@ -199,7 +203,9 @@
#:force-strip? force #:force-strip? force
#:link-dirs? link-dirs? #:link-dirs? link-dirs?
(for/list ([p (in-list sources)]) (for/list ([p (in-list sources)])
(pkg-desc p a-type* name checksum #f)))))) (pkg-desc p a-type* name checksum #f
#:path (and (eq? a-type* 'clone)
(path->complete-path clone))))))))
(setup "installed" no-setup fail-fast setup-collects jobs)))] (setup "installed" no-setup fail-fast setup-collects jobs)))]
;; ---------------------------------------- ;; ----------------------------------------
[update [update
@ -226,40 +232,53 @@
job-flags ... job-flags ...
#:args pkg-source #:args pkg-source
install-copy-defns ... install-copy-defns ...
(call-with-package-scope (let ([pkg-source (cond
'update [(and (null? pkg-source)
scope scope-dir installation user pkg-source #f (not all)
(lambda () (not clone))
(define setup-collects ;; In a package directory?
(with-pkg-lock (define pkg (path->pkg (current-directory)))
(parameterize ([current-pkg-catalogs (and catalog (if pkg
(list (catalog->url catalog)))]) (list pkg)
(pkg-update (for/list ([pkg-source (in-list pkg-source)]) null)]
(cond [else pkg-source])])
[lookup (call-with-package-scope
(pkg-desc pkg-source a-type name checksum #f)] 'update
[else scope scope-dir installation user pkg-source #f
(define-values (pkg-name pkg-type) (lambda ()
(package-source->name+type pkg-source a-type)) install-copy-checks ...
(if (eq? pkg-type 'name) (define setup-collects
pkg-name (with-pkg-lock
(pkg-desc pkg-source a-type name checksum #f))])) (parameterize ([current-pkg-catalogs (and catalog
#:from-command-line? #t (list (catalog->url catalog)))])
#:all? all (pkg-update (for/list ([pkg-source (in-list pkg-source)])
#:dep-behavior (if auto 'search-auto deps) (cond
#:all-platforms? all-platforms [lookup
#:force? force (pkg-desc pkg-source a-type name checksum #f)]
#:ignore-checksums? ignore-checksums [else
#:strict-doc-conflicts? strict-doc-conflicts (define-values (pkg-name pkg-type)
#:use-cache? (not no-cache) (package-source->name+type pkg-source a-type))
#:update-deps? (or update-deps auto) (if (eq? pkg-type 'name)
#:update-implies? (not ignore-implies) pkg-name
#:strip (or (and source 'source) (pkg-desc pkg-source a-type name checksum #f
(and binary 'binary) #:path (and (eq? a-type 'clone)
(and binary-lib 'binary-lib)) (path->complete-path clone))))]))
#:force-strip? force #:from-command-line? #t
#:link-dirs? link-dirs?)))) #:all? all
(setup "updated" no-setup #f setup-collects jobs)))] #:dep-behavior (if auto 'search-auto deps)
#:all-platforms? all-platforms
#:force? force
#:ignore-checksums? ignore-checksums
#:strict-doc-conflicts? strict-doc-conflicts
#:use-cache? (not no-cache)
#:update-deps? (or update-deps auto)
#:update-implies? (not ignore-implies)
#:strip (or (and source 'source)
(and binary 'binary)
(and binary-lib 'binary-lib))
#:force-strip? force
#:link-dirs? link-dirs?))))
(setup "updated" no-setup #f setup-collects jobs))))]
;; ---------------------------------------- ;; ----------------------------------------
[remove [remove
"Remove packages" "Remove packages"
@ -559,12 +578,29 @@
([#:bool link () ("Link a directory package source in place (default for a directory)")] ([#:bool link () ("Link a directory package source in place (default for a directory)")]
[#:bool static-link () ("Link in place, promising collections do not change")] [#:bool static-link () ("Link in place, promising collections do not change")]
[#:bool copy () ("Treat directory sources the same as other sources")] [#:bool copy () ("Treat directory sources the same as other sources")]
[(#:str dir #f) clone () ("Clone Git and GitHub package sources to <dir> and link")]
[#:bool source () ("Strip packages' built elements before installing; implies --copy")] [#:bool source () ("Strip packages' built elements before installing; implies --copy")]
[#:bool binary () ("Strip packages' source elements before installing; implies --copy")] [#:bool binary () ("Strip packages' source elements before installing; implies --copy")]
[#:bool binary-lib () ("Strip source & documentation before installing; implies --copy")]) [#:bool binary-lib () ("Strip source & documentation before installing; implies --copy")])
#:install-copy-defns #:install-copy-defns
[(define link-dirs? (not (or copy source binary binary-lib))) [(define link-dirs? (not (or copy source binary binary-lib)))
(define a-type (or (and link 'link) (define link-type (or (and link 'link)
(and static-link 'static-link) (and static-link 'static-link)
(and (eq? type 'dir) link-dirs? 'link) (and (eq? type 'dir) link-dirs? 'link)
type))])) (and clone 'clone)))
(define a-type (or link-type type))]
#:install-copy-checks
[(when (and type
link-type
(not (memq type
(case link-type
[(clone) '(git github)]
[else '(dir)]))))
((current-pkg-error) (format "-t/--type value must be ~a with --~a"
(cond
[clone "`git' or `github'"]
[else "`dir'"])
(cond
[link "link"]
[static-link "static-link"]
[clone "clone"]))))]))

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

@ -25,7 +25,7 @@
(define rx:git #rx"[.]git$") (define rx:git #rx"[.]git$")
(define package-source-format? (define package-source-format?
(or/c 'name 'file 'dir 'git 'github 'file-url 'dir-url 'link 'static-link)) (or/c 'name 'file 'dir 'git 'github 'clone 'file-url 'dir-url 'link 'static-link))
(define (validate-name name complain inferred?) (define (validate-name name complain inferred?)
(and name (and name
@ -134,14 +134,22 @@
(eq? type 'name) (eq? type 'name)
(regexp-match? rx:package-name s)) (regexp-match? rx:package-name s))
(values (validate-name s complain #f) 'name)] (values (validate-name s complain #f) 'name)]
[(and (eq? type 'clone)
(not (regexp-match? #rx"^(?:https?|git(?:hub)?)://" s)))
(complain "repository URL must start 'http', 'https', 'git', or 'github'")
(values #f 'clone)]
[(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
(string-append "git://github.com/" s) (string-append "git://github.com/" s)
'github)] 'github
#:link-dirs? link-dirs?
#:complain complain-proc
#:must-infer-name? must-infer-name?)]
[(if type [(if type
(or (eq? type 'github) (or (eq? type 'github)
(eq? type 'git) (eq? type 'git)
(eq? type 'clone)
(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))
@ -152,7 +160,9 @@
(let ([p (url-path url)]) (let ([p (url-path url)])
(cond (cond
[(if type [(if type
(eq? type 'github) (or (eq? type 'github)
(and (eq? type 'clone)
(equal? (url-scheme url) "github")))
(or (equal? (url-scheme url) "github") (or (equal? (url-scheme url) "github")
(equal? (url-scheme url) "git"))) (equal? (url-scheme url) "git")))
(unless (or (equal? (url-scheme url) "github") (unless (or (equal? (url-scheme url) "github")
@ -218,7 +228,8 @@
(extract-archive-name (last-non-empty p) complain-name))) (extract-archive-name (last-non-empty p) complain-name)))
(values name 'file-url)] (values name 'file-url)]
[(if type [(if type
(eq? type 'git) (or (eq? type 'git)
(eq? type 'clone))
(and (last-non-empty p) (and (last-non-empty p)
(string-and-regexp-match? rx:git (last-non-empty p)) (string-and-regexp-match? rx:git (last-non-empty p))
((num-empty p) . < . 2))) ((num-empty p) . < . 2)))

3
racket/collects/pkg/path.rkt
View File

@ -129,7 +129,8 @@
(define orig (pkg-info-orig-pkg v)) (define orig (pkg-info-orig-pkg v))
(if (and (pair? orig) (if (and (pair? orig)
(or (eq? 'link (car orig)) (or (eq? 'link (car orig))
(eq? 'static-link (car orig)))) (eq? 'static-link (car orig))
(eq? 'clone (car orig))))
(let ([e (or (and cache (let ([e (or (and cache
(hash-ref cache `(pkg-dir ,(cadr orig)) #f)) (hash-ref cache `(pkg-dir ,(cadr orig)) #f))
(let ([e (explode (simplify-path (let ([e (explode (simplify-path

2
racket/collects/pkg/private/archive.rkt
View File

@ -134,7 +134,7 @@
;; Download/unpack existing package: ;; Download/unpack existing package:
(define-values (staged-name staged-dir staged-checksum clean? staged-mods) (define-values (staged-name staged-dir staged-checksum clean? staged-mods)
(pkg-stage (pkg-stage
(pkg-desc (path->string pkg-dir) 'dir name checksum #f) (pkg-desc (path->string pkg-dir) 'dir name checksum #f #f)
#:in-place? #f #:in-place? #f
#:use-cache? #t #:use-cache? #t
#:quiet? quiet?)) #:quiet? quiet?))

2
racket/collects/pkg/private/catalog-archive.rkt
View File

@ -78,7 +78,7 @@
;; Download/unpack existing package: ;; Download/unpack existing package:
(define-values (staged-name staged-dir staged-checksum clean? staged-mods) (define-values (staged-name staged-dir staged-checksum clean? staged-mods)
(pkg-stage (pkg-stage
(pkg-desc (db:pkg-source pkg) #f (db:pkg-name pkg) (db:pkg-checksum pkg) #f) (pkg-desc (db:pkg-source pkg) #f (db:pkg-name pkg) (db:pkg-checksum pkg) #f #f)
#:in-place? #t #:in-place? #t
#:use-cache? #t #:use-cache? #t
#:quiet? quiet?)) #:quiet? quiet?))

5
racket/collects/pkg/private/desc.rkt
View File

@ -3,7 +3,7 @@
(provide (struct-out pkg-desc) (provide (struct-out pkg-desc)
pkg-desc=?) pkg-desc=?)
(struct pkg-desc (source type name checksum auto?)) (struct pkg-desc (source type name checksum auto? extra-path))
(define (pkg-desc=? a b) (define (pkg-desc=? a b)
(define (->list a) (define (->list a)
@ -11,5 +11,6 @@
(pkg-desc-type a) (pkg-desc-type a)
(pkg-desc-name a) (pkg-desc-name a)
(pkg-desc-checksum a) (pkg-desc-checksum a)
(pkg-desc-auto? a))) (pkg-desc-auto? a)
(pkg-desc-extra-path a)))
(equal? (->list a) (->list b))) (equal? (->list a) (->list b)))

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

@ -98,7 +98,7 @@
#: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 (define (download-repo! url host port repo dest-dir checksum
#:download-printf [download-printf #f] #:download-printf [download-printf #f]
#:use-cache? [use-cache? #t]) #:use-cache? [use-cache? #t])
(log-pkg-debug "\t\tDownloading ~a to ~a" (url->string url) dest-dir) (log-pkg-debug "\t\tDownloading ~a to ~a" (url->string url) dest-dir)
@ -107,7 +107,7 @@
(define unpacked? #f) (define unpacked? #f)
(define (download!) (define (download!)
(git-checkout host repo (git-checkout host #:port port repo
#:dest-dir dest-dir #:dest-dir dest-dir
#:ref checksum #:ref checksum
#:status-printf (or download-printf void) #:status-printf (or download-printf void)

35
racket/collects/pkg/private/git.rkt Normal file
View File

@ -0,0 +1,35 @@
#lang racket/base
(require racket/system
racket/format
racket/promise
"print.rkt")
(provide git)
(define git-exe (delay (find-executable-path
(if (eq? (system-type) 'windows)
"git.exe"
"git"))))
(define (git #:status [status void]
#:quiet-stderr? [quiet-stderr? #t] ; suppress stderr unless error
. args)
(define exe (force git-exe))
(unless exe
(pkg-error (~a "could not find `git' executable\n"
" intended command: git ~a")
(apply ~a #:separator " " args)))
(status (apply ~a #:separator " " "git" args))
(define stderr (if quiet-stderr?
(open-output-bytes)
(current-error-port)))
(define r ((parameterize ([current-error-port stderr])
(with-handlers ([values (lambda (exn)
;; re-raise after restoring stderr:
(lambda () (raise exn)))])
(define r (apply system* exe args))
(lambda () r)))))
(unless r
(when quiet-stderr?
(write-bytes (get-output-bytes stderr) (current-error-port)))
(pkg-error "Git command failed")))

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

@ -23,16 +23,20 @@
"metadata.rkt" "metadata.rkt"
"dep.rkt" "dep.rkt"
"get-info.rkt" "get-info.rkt"
"catalog.rkt"
"dirs.rkt" "dirs.rkt"
"collects.rkt" "collects.rkt"
"addl-installs.rkt") "addl-installs.rkt"
"repo-path.rkt"
"orig-pkg.rkt"
"git.rkt")
(provide pkg-install (provide pkg-install
pkg-update) pkg-update)
(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 git) [(file-url dir-url github git clone)
(or given-checksum (or given-checksum
(remote-package-checksum `(url ,pkg-source) download-printf pkg-name #:type type))] (remote-package-checksum `(url ,pkg-source) download-printf pkg-name #:type type))]
[(file) [(file)
@ -41,6 +45,9 @@
(file->string checksum-pth)) (file->string checksum-pth))
(and (file-exists? pkg-source) (and (file-exists? pkg-source)
(call-with-input-file* pkg-source sha1)))] (call-with-input-file* pkg-source sha1)))]
[(name)
(or given-checksum
(remote-package-checksum `(catalog ,pkg-source) download-printf pkg-name #:type type))]
[else given-checksum])) [else given-checksum]))
(define (disallow-package-path-overlaps pkg-name (define (disallow-package-path-overlaps pkg-name
@ -154,9 +161,9 @@
(define all-db (merge-pkg-dbs)) (define all-db (merge-pkg-dbs))
(define path-pkg-cache (make-hash)) (define path-pkg-cache (make-hash))
(define (install-package/outer infos desc info) (define (install-package/outer infos desc info)
(match-define (pkg-desc pkg type orig-name given-checksum auto?) desc) (match-define (pkg-desc pkg type orig-name given-checksum auto? pkg-extra-path) desc)
(match-define (match-define
(install-info pkg-name orig-pkg pkg-dir clean? checksum module-paths additional-installs) (install-info pkg-name orig-pkg pkg-dir git-dir clean? checksum module-paths additional-installs)
info) info)
(define name? (eq? 'catalog (first orig-pkg))) (define name? (eq? 'catalog (first orig-pkg)))
(define this-dep-behavior (or dep-behavior (define this-dep-behavior (or dep-behavior
@ -209,10 +216,13 @@
;; Also, make sure it's installed in the scope that we're changing: ;; Also, make sure it's installed in the scope that we're changing:
(hash-ref current-scope-db pkg-name #f)) (hash-ref current-scope-db pkg-name #f))
;; promote an auto-installed package to a normally installed one ;; promote an auto-installed package to a normally installed one
(lambda () (cons
(unless quiet? #f ; no repo change
(download-printf "Promoting ~a from auto-installed to explicitly installed\n" pkg-name)) ;; The `do-it` thunk:
(update-pkg-db! pkg-name (update-auto existing-pkg-info #f)))] (lambda ()
(unless quiet?
(download-printf "Promoting ~a from auto-installed to explicitly installed\n" pkg-name))
(update-pkg-db! pkg-name (update-auto existing-pkg-info #f))))]
[else [else
;; Fail --- already installed ;; Fail --- already installed
(clean!) (clean!)
@ -405,7 +415,8 @@
#:all-platforms? all-platforms? #:all-platforms? all-platforms?
#:ignore-checksums? ignore-checksums? #:ignore-checksums? ignore-checksums?
#:use-cache? use-cache? #:use-cache? use-cache?
#:from-command-line? from-command-line?) #:from-command-line? from-command-line?
#:link-dirs? link-dirs?)
name)) name))
null)) null))
deps)) deps))
@ -508,7 +519,8 @@
#:all-platforms? all-platforms? #:all-platforms? all-platforms?
#:ignore-checksums? ignore-checksums? #:ignore-checksums? ignore-checksums?
#:use-cache? use-cache? #:use-cache? use-cache?
#:from-command-line? from-command-line?) #:from-command-line? from-command-line?
#:link-dirs? link-dirs?)
update-pkgs)]) update-pkgs)])
(λ () (for-each (compose (remove-package quiet?) pkg-desc-name) to-update)))) (λ () (for-each (compose (remove-package quiet?) pkg-desc-name) to-update))))
(match this-dep-behavior (match this-dep-behavior
@ -531,48 +543,57 @@
(clean!) (clean!)
(report-mismatch update-deps)])]))] (report-mismatch update-deps)])]))]
[else [else
(λ () (cons
(when updating? ;; The repo to get new commits, if any:
(download-printf "Re-installing ~a\n" pkg-name)) (and git-dir
(define final-pkg-dir (list (enclosing-path-for-repo (caddr orig-pkg) git-dir)
(cond checksum))
;; The "do-it" function (see `repos+do-its` below):
(λ ()
(when updating?
(download-printf "Re-installing ~a\n" pkg-name))
(define final-pkg-dir
(cond
[clean? [clean?
(define final-pkg-dir (select-package-directory (define final-pkg-dir (or git-dir
(build-path (pkg-installed-dir) pkg-name))) (select-package-directory
(make-parent-directory* final-pkg-dir) (build-path (pkg-installed-dir) pkg-name))))
(copy-directory/files pkg-dir final-pkg-dir #:keep-modify-seconds? #t) (unless git-dir
(make-parent-directory* final-pkg-dir)
(copy-directory/files pkg-dir final-pkg-dir #:keep-modify-seconds? #t))
(clean!) (clean!)
final-pkg-dir] final-pkg-dir]
[else [else
pkg-dir])) pkg-dir]))
(define single-collect (pkg-single-collection final-pkg-dir (define single-collect (pkg-single-collection final-pkg-dir
#:name pkg-name #:name pkg-name
#:namespace post-metadata-ns)) #:namespace post-metadata-ns))
(log-pkg-debug "creating ~alink to ~e" (log-pkg-debug "creating ~alink to ~e"
(if single-collect "single-collection " "") (if single-collect "single-collection " "")
final-pkg-dir) final-pkg-dir)
(define scope (current-pkg-scope)) (define scope (current-pkg-scope))
(links final-pkg-dir (links final-pkg-dir
#:name single-collect #:name single-collect
#:user? (not (or (eq? 'installation scope) #:user? (not (or (eq? 'installation scope)
(path? scope))) (path? scope)))
#:file (scope->links-file scope) #:file (scope->links-file scope)
#:root? (not single-collect) #:root? (not single-collect)
#:static-root? (and (pair? orig-pkg) #:static-root? (and (pair? orig-pkg)
(eq? 'static-link (car orig-pkg)))) (eq? 'static-link (car orig-pkg))))
(define alt-dir-name (define alt-dir-name
;; If we had to pick an alternate dir name, then record it: ;; If we had to pick an alternate dir name, then record it:
(let-values ([(base name dir?) (split-path final-pkg-dir)]) (let-values ([(base name dir?) (split-path final-pkg-dir)])
(and (regexp-match? #rx"[+]" name) (and (regexp-match? #rx"[+]" name)
(path->string name)))) (path->string name))))
(define this-pkg-info (define this-pkg-info
(make-pkg-info orig-pkg checksum auto? single-collect alt-dir-name)) (make-pkg-info orig-pkg checksum auto? single-collect alt-dir-name))
(log-pkg-debug "updating db with ~e to ~e" pkg-name this-pkg-info) (log-pkg-debug "updating db with ~e to ~e" pkg-name this-pkg-info)
(update-pkg-db! pkg-name this-pkg-info))])) (update-pkg-db! pkg-name this-pkg-info)))]))
(define metadata-ns (make-metadata-namespace)) (define metadata-ns (make-metadata-namespace))
(define infos (define infos
(for/list ([v (in-list descs)]) (for/list ([v (in-list descs)])
(stage-package/info (pkg-desc-source v) (pkg-desc-type v) (pkg-desc-name v) (stage-package/info (pkg-desc-source v) (pkg-desc-type v) (pkg-desc-name v)
#:at-dir (pkg-desc-extra-path v)
#:given-checksum (pkg-desc-checksum v) #:given-checksum (pkg-desc-checksum v)
#:use-cache? use-cache? #:use-cache? use-cache?
check-sums? download-printf check-sums? download-printf
@ -598,14 +619,49 @@
(define all-descs (append old-descs descs)) (define all-descs (append old-descs descs))
(define all-infos (append old-infos infos)) (define all-infos (append old-infos infos))
(define do-its (define repo+do-its ; list of (cons #f-or-(list git-dir checksum) do-it-thunk)
(map (curry install-package/outer all-infos) (map (curry install-package/outer all-infos)
all-descs all-descs
all-infos)) all-infos))
;; collapse planned repo actions, and make sure they don't conflict:
(define repos
(for/fold ([ht (hash)]) ([repo+do-it (in-list repo+do-its)])
(define repo (car repo+do-it))
(cond
[repo
(define git-dir (car repo))
(define checksum (cadr repo))
(define prev-checksum (hash-ref ht git-dir #f))
(when (and prev-checksum
(not (equal? prev-checksum checksum)))
(pkg-error (~a "multiple packages in the same clone have different target commits\n"
" clone: ~a\n"
" commit: ~a\n"
" other commit: ~a")
git-dir
prev-checksum
checksum))
(hash-set ht git-dir checksum)]
[else ht])))
;; relevant commits have been fecthed to the repos, and now we need
;; to check them out; If a checkout fails, then we've left the
;; package installation in no worse shape than if a manual `git
;; pull` failed
(for ([(git-dir checksum) (in-hash repos)])
(parameterize ([current-directory git-dir])
(download-printf "Merging commits at ~a\n"
git-dir)
(git #:status (lambda (s) (download-printf "~a\n" s))
"merge" "--ff-only" checksum)))
;; pre-succeed removes packages that are being updated
(pre-succeed) (pre-succeed)
(define post-metadata-ns (make-metadata-namespace)) (define post-metadata-ns (make-metadata-namespace))
(for-each (λ (t) (t)) do-its) ;; moves packages into place and installs links:
(for-each (λ (t) ((cdr t))) repo+do-its)
(define (is-promote? info) (define (is-promote? info)
;; if the package name is in `current-scope-db', we must ;; if the package name is in `current-scope-db', we must
@ -628,7 +684,7 @@
post-metadata-ns))) post-metadata-ns)))
(cond (cond
[(or (null? do-its) [(or (null? repo+do-its)
(and (not updating?) (andmap is-promote? all-infos))) (and (not updating?) (andmap is-promote? all-infos)))
;; No actions, so no setup: ;; No actions, so no setup:
'skip] 'skip]
@ -751,7 +807,7 @@
(for/list ([dep (in-list deps)]) (for/list ([dep (in-list deps)])
(if (pkg-desc? dep) (if (pkg-desc? dep)
dep dep
(pkg-desc dep #f #f #f #t))))])]) (pkg-desc dep #f #f #f #t #f))))])])
(begin0 (begin0
(install-packages (install-packages
#:old-infos old-infos #:old-infos old-infos
@ -813,7 +869,8 @@
#:all-platforms? all-platforms? #:all-platforms? all-platforms?
#:ignore-checksums? ignore-checksums? #:ignore-checksums? ignore-checksums?
#:use-cache? use-cache? #:use-cache? use-cache?
#:from-command-line? from-command-line?) #:from-command-line? from-command-line?
#:link-dirs? link-dirs?)
pkg-name) pkg-name)
(cond (cond
[(pkg-desc? pkg-name) [(pkg-desc? pkg-name)
@ -821,6 +878,7 @@
(define-values (inferred-name type) (package-source->name+type (define-values (inferred-name type) (package-source->name+type
(pkg-desc-source pkg-name) (pkg-desc-source pkg-name)
(pkg-desc-type pkg-name) (pkg-desc-type pkg-name)
#:link-dirs? link-dirs?
#:must-infer-name? (not (pkg-desc-name pkg-name)) #:must-infer-name? (not (pkg-desc-name pkg-name))
#:complain complain-about-source)) #:complain complain-about-source))
(define name (or (pkg-desc-name pkg-name) (define name (or (pkg-desc-name pkg-name)
@ -832,6 +890,7 @@
name name
(pkg-desc-checksum pkg-name) (pkg-desc-checksum pkg-name)
download-printf)) download-printf))
(hash-set! update-cache name new-checksum) ; record downloaded checksum
(unless (or ignore-checksums? (not (pkg-desc-checksum pkg-name))) (unless (or ignore-checksums? (not (pkg-desc-checksum pkg-name)))
(unless (equal? (pkg-desc-checksum pkg-name) new-checksum) (unless (equal? (pkg-desc-checksum pkg-name) new-checksum)
(pkg-error (~a "incorrect checksum on package\n" (pkg-error (~a "incorrect checksum on package\n"
@ -841,10 +900,16 @@
(pkg-desc-source pkg-name) (pkg-desc-source pkg-name)
(pkg-desc-checksum pkg-name) (pkg-desc-checksum pkg-name)
new-checksum))) new-checksum)))
(if (or (not (equal? (pkg-info-checksum info) (if (or (not (equal? (pkg-info-checksum info)
new-checksum)) new-checksum))
;; No checksum available => always update ;; No checksum available => always update
(not new-checksum)) (not new-checksum)
;; Different source => always update
(not (equal? (pkg-info-orig-pkg info)
(desc->orig-pkg type
(pkg-desc-source pkg-name)
(pkg-desc-extra-path pkg-name)))))
;; Update: ;; Update:
(begin (begin
(hash-set! update-cache (pkg-desc-source pkg-name) #t) (hash-set! update-cache (pkg-desc-source pkg-name) #t)
@ -852,7 +917,10 @@
(pkg-desc-type pkg-name) (pkg-desc-type pkg-name)
name name
(pkg-desc-checksum pkg-name) (pkg-desc-checksum pkg-name)
(pkg-desc-auto? pkg-name)))) (pkg-desc-auto? pkg-name)
(or (pkg-desc-extra-path pkg-name)
(and (eq? type 'clone)
(current-directory))))))
;; No update needed, but maybe check dependencies: ;; No update needed, but maybe check dependencies:
(if (or deps? (if (or deps?
implies?) implies?)
@ -865,7 +933,8 @@
#:all-platforms? all-platforms? #:all-platforms? all-platforms?
#:ignore-checksums? ignore-checksums? #:ignore-checksums? ignore-checksums?
#:use-cache? use-cache? #:use-cache? use-cache?
#:from-command-line? from-command-line?) #:from-command-line? from-command-line?
#:link-dirs? link-dirs?)
name) name)
null))] null))]
[(eq? #t (hash-ref update-cache pkg-name #f)) [(eq? #t (hash-ref update-cache pkg-name #f))
@ -881,12 +950,10 @@
(match orig-pkg (match orig-pkg
[`(,(or 'link 'static-link) ,orig-pkg-dir) [`(,(or 'link 'static-link) ,orig-pkg-dir)
(if must-update? (if must-update?
(pkg-error (~a "cannot update linked packages~a\n" (pkg-error (~a "cannot update linked packages;\n"
" except with a replacement package source\n"
" package name: ~a\n" " package name: ~a\n"
" package source: ~a") " package source: ~a")
(if from-command-line?
" without `--link'"
" without new link")
pkg-name pkg-name
(normalize-path (normalize-path
(path->complete-path orig-pkg-dir (pkg-installed-dir)))) (path->complete-path orig-pkg-dir (pkg-installed-dir))))
@ -894,6 +961,7 @@
[`(dir ,_) [`(dir ,_)
(if must-update? (if must-update?
(pkg-error (~a "cannot update packages installed locally;\n" (pkg-error (~a "cannot update packages installed locally;\n"
" except with a replacement package source;\n"
" package was installed via a local directory\n" " package was installed via a local directory\n"
" package name: ~a") " package name: ~a")
pkg-name) pkg-name)
@ -901,11 +969,21 @@
[`(file ,_) [`(file ,_)
(if must-update? (if must-update?
(pkg-error (~a "cannot update packages installed locally;\n" (pkg-error (~a "cannot update packages installed locally;\n"
" except with a replacement package source;\n"
" package was installed via a local file\n" " package was installed via a local file\n"
" package name: ~a") " package name: ~a")
pkg-name) pkg-name)
null)] null)]
[`(,_ ,orig-pkg-source) [_
(define-values (orig-pkg-source orig-pkg-type orig-pkg-dir)
(if (eq? 'clone (car orig-pkg))
(values (caddr orig-pkg)
'clone
(enclosing-path-for-repo (caddr orig-pkg) (cadr orig-pkg)))
;; It would be better if the type were preseved
;; from install time, but we always make the
;; URL unambigious:
(values (cadr orig-pkg) #f #f)))
(define new-checksum (define new-checksum
(or (hash-ref update-cache pkg-name #f) (or (hash-ref update-cache pkg-name #f)
(remote-package-checksum orig-pkg download-printf pkg-name))) (remote-package-checksum orig-pkg download-printf pkg-name)))
@ -920,9 +998,8 @@
;; there was a race between our checkig and updates on ;; there was a race between our checkig and updates on
;; the catalog server: ;; the catalog server:
(clear-checksums-in-cache! update-cache) (clear-checksums-in-cache! update-cache)
;; FIXME: the type shouldn't be #f here; it should be (list (pkg-desc orig-pkg-source orig-pkg-type pkg-name #f auto?
;; preseved from install time: orig-pkg-dir))))
(list (pkg-desc orig-pkg-source #f pkg-name #f auto?))))
(if (or deps? implies?) (if (or deps? implies?)
;; Check dependencies ;; Check dependencies
(append-map (append-map
@ -935,7 +1012,8 @@
#:all-platforms? all-platforms? #:all-platforms? all-platforms?
#:ignore-checksums? ignore-checksums? #:ignore-checksums? ignore-checksums?
#:use-cache? use-cache? #:use-cache? use-cache?
#:from-command-line? from-command-line?) #:from-command-line? from-command-line?
#:link-dirs? link-dirs?)
((package-dependencies metadata-ns db all-platforms? ((package-dependencies metadata-ns db all-platforms?
#:only-implies? (not deps?)) #:only-implies? (not deps?))
pkg-name)) pkg-name))
@ -975,14 +1053,18 @@
#:all-platforms? all-platforms? #:all-platforms? all-platforms?
#:ignore-checksums? ignore-checksums? #:ignore-checksums? ignore-checksums?
#:use-cache? use-cache? #:use-cache? use-cache?
#:from-command-line? from-command-line?) #:from-command-line? from-command-line?
pkgs)) #:link-dirs? link-dirs?)
(map (convert-clone-name-to-clone-repo db)
pkgs)))
(cond (cond
[(empty? pkgs) [(empty? pkgs)
(unless quiet? (unless quiet?
(printf/flush (~a "No packages given to update" (printf/flush (~a "No packages given to update"
(if from-command-line? (if from-command-line?
";\n use `--all' to update all packages" (~a
";\n use `--all' to update all packages, or run from a package's directory"
"\n to update that package")
"") "")
"\n"))) "\n")))
'skip] 'skip]
@ -1015,6 +1097,49 @@
#:link-dirs? link-dirs? #:link-dirs? link-dirs?
to-update)])) to-update)]))
;; If `pkg` is a description with the type 'clone, but its syntax
;; matches a ackage name, then infer a repo from the current package
;; installation and return an alternate description.
(define ((convert-clone-name-to-clone-repo db) pkg-name)
(cond
[(and (pkg-desc? pkg-name)
(eq? 'clone (pkg-desc-type pkg-name))
(let-values ([(name type) (package-source->name+type (pkg-desc-source pkg-name) 'name)])
name))
=> (lambda (name)
;; Infer or complain
(define info (package-info name #:db db))
(unless info
(pkg-error (~a "package is not currently installed\n"
" package: ~a")
name))
(define new-pkg-name
(match (pkg-info-orig-pkg info)
[`(clone ,path ,url-str)
(pkg-error (~a "package is already a linked repository clone\n"
" package: ~a")
name)]
[`(url ,url-str)
(define-values (current-name current-type)
(package-source->name+type url-str #f))
(case current-type
[(git github)
;; found a repo URL
(pkg-desc url-str 'clone name
(pkg-desc-checksum pkg-name)
(pkg-desc-auto? pkg-name)
(pkg-desc-extra-path pkg-name))]
[else #f])]
[else #f]))
(unless new-pkg-name
(pkg-error (~a "package is not currently installed from a repository\n"
" package: ~a\n"
" current installation: ~a")
name
(pkg-info-orig-pkg info)))
new-pkg-name)]
[else pkg-name]))
;; ---------------------------------------- ;; ----------------------------------------
(define (clear-checksums-in-cache! update-cache) (define (clear-checksums-in-cache! update-cache)
@ -1022,3 +1147,4 @@
#:when (string? v)) #:when (string? v))
k)) k))
(for ([k (in-list l)]) (hash-remove! update-cache k))) (for ([k (in-list l)]) (hash-remove! update-cache k)))

25
racket/collects/pkg/private/migrate.rkt
View File

@ -1,12 +1,15 @@
#lang racket/base #lang racket/base
(require racket/match (require racket/match
net/url
"../path.rkt" "../path.rkt"
"config.rkt" "config.rkt"
"lock.rkt" "lock.rkt"
"pkg-db.rkt" "pkg-db.rkt"
"desc.rkt" "desc.rkt"
"params.rkt" "params.rkt"
"install.rkt") "install.rkt"
"repo-path.rkt"
"dirs.rkt")
(provide pkg-migrate) (provide pkg-migrate)
@ -24,17 +27,25 @@
(define from-db (define from-db
(parameterize ([current-pkg-scope-version from-version]) (parameterize ([current-pkg-scope-version from-version])
(installed-pkg-table #:scope 'user))) (installed-pkg-table #:scope 'user)))
(define installed-dir
(parameterize ([current-pkg-scope 'user])
(pkg-installed-dir)))
(define (path->complete-string p)
(path->string (path->complete-path p installed-dir)))
(define to-install (define to-install
(sort (sort
(for/list ([(name info) (in-hash from-db)] (for/list ([(name info) (in-hash from-db)]
#:unless (pkg-info-auto? info)) #:unless (pkg-info-auto? info))
(define-values (source type) (define-values (source type dir)
(match (pkg-info-orig-pkg info) (match (pkg-info-orig-pkg info)
[(list 'catalog name) (values name 'name)] [(list 'catalog name) (values name 'name #f)]
[(list 'url url) (values url #f)] [(list 'url url) (values url #f #f)]
[(list 'link path) (values path 'link)] [(list 'link path) (values (path->complete-string path) 'link #f)]
[(list 'static-link path) (values path 'static-link)])) [(list 'static-link path) (values (path->complete-string path) 'static-link #f)]
(pkg-desc source type name #f #f)) [(list 'clone path url) (values url 'clone (enclosing-path-for-repo
url
(path->complete-path path)))]))
(pkg-desc source type name #f #f dir))
string<? string<?
#:key pkg-desc-name)) #:key pkg-desc-name))
(unless quiet? (unless quiet?

33
racket/collects/pkg/private/orig-pkg.rkt Normal file
View File

@ -0,0 +1,33 @@
#lang racket/base
(require racket/path
net/url
"dirs.rkt"
"repo-path.rkt"
"path.rkt")
;; An "orig-pkg" is the way that that a pacage source is recorded
;; in the installed-package database.
(provide desc->orig-pkg)
(define (desc->orig-pkg type src extra-path)
(case type
[(name) `(catalog ,src)]
[(link static-link) `(,type
,(path->string
(find-relative-path (pkg-installed-dir)
(simple-form-path src)
#:more-than-root? #t)))]
[(clone)
(define-values (host port repo branch path)
(split-git-or-hub-url (string->url src)))
`(clone ,(path->string
(find-relative-path (pkg-installed-dir)
(simple-form-path
(apply build-path
extra-path
path))
#:more-than-root? #t))
,src)]
[(file dir) `(,type ,(simple-form-path* src))]
[else `(url ,src)]))

2
racket/collects/pkg/private/pkg-db.rkt
View File

@ -175,7 +175,7 @@
(let () (let ()
(match-define (pkg-info orig-pkg checksum _) info) (match-define (pkg-info orig-pkg checksum _) info)
(match orig-pkg (match orig-pkg
[`(,(or 'link 'static-link) ,orig-pkg-dir) [`(,(or 'link 'static-link 'clone) ,orig-pkg-dir . ,_)
(path->complete-path orig-pkg-dir (pkg-installed-dir))] (path->complete-path orig-pkg-dir (pkg-installed-dir))]
[_ [_
(build-path (pkg-installed-dir) (build-path (pkg-installed-dir)

2
racket/collects/pkg/private/remove.rkt
View File

@ -36,7 +36,7 @@
(define user? (not (or (eq? scope 'installation) (define user? (not (or (eq? scope 'installation)
(path? scope)))) (path? scope))))
(match orig-pkg (match orig-pkg
[`(,(or 'link 'static-link) ,_) [`(,(or 'link 'static-link 'clone) ,_ . ,_)
(links pkg-dir (links pkg-dir
#:remove? #t #:remove? #t
#:user? user? #:user? user?

58
racket/collects/pkg/private/repo-path.rkt Normal file
View File

@ -0,0 +1,58 @@
#lang racket/base
(require net/url
racket/string
racket/format
racket/match
racket/list
"download.rkt")
(provide split-github-url
split-git-url
split-git-or-hub-url
enclosing-path-for-repo)
(define (split-github-url pkg-url)
(if (equal? (url-scheme pkg-url) "github")
;; github://
(map path/param-path (url-path/no-slash pkg-url))
;; git://
(let* ([paths (map path/param-path (url-path/no-slash pkg-url))])
(list* (car paths)
(regexp-replace* #rx"[.]git$" (cadr paths) "")
(or (url-fragment pkg-url) "master")
(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)
(url-port 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)))
(define (split-git-or-hub-url pkg-url)
(if (equal? "github" (url-scheme pkg-url))
(match (split-github-url pkg-url)
[(list* user repo branch path)
(values "github.com" #f (~a "/" user "/" repo) branch path)])
(split-git-url pkg-url)))
(define (enclosing-path-for-repo url-str in-repo-dir)
(define-values (host port repo branch path)
(split-git-or-hub-url (string->url url-str)))
(let loop ([path path]
[in-repo-dir in-repo-dir])
(cond
[(null? path) in-repo-dir]
[else
(define-values (base name dir?) (split-path in-repo-dir))
(if (not (path? base))
(error "path for git repo link is too short for path in package source")
(loop (cdr path) base))])))

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

@ -25,14 +25,17 @@
"params.rkt" "params.rkt"
"get-info.rkt" "get-info.rkt"
"mod-paths.rkt" "mod-paths.rkt"
"addl-installs.rkt") "addl-installs.rkt"
"repo-path.rkt"
"orig-pkg.rkt"
"git.rkt")
(provide (struct-out install-info) (provide (struct-out install-info)
remote-package-checksum remote-package-checksum
stage-package/info stage-package/info
pkg-stage) pkg-stage)
(struct install-info (name orig-pkg directory clean? checksum module-paths additional-installs)) (struct install-info (name orig-pkg directory git-directory clean? checksum module-paths additional-installs))
(define (remote-package-checksum pkg download-printf pkg-name #:type [type #f]) (define (remote-package-checksum pkg download-printf pkg-name #:type [type #f])
(match pkg (match pkg
@ -42,6 +45,11 @@
(package-url->checksum pkg-url-str (package-url->checksum pkg-url-str
#:type type #:type type
#:download-printf download-printf #:download-printf download-printf
#:pkg-name pkg-name)]
[`(clone ,_ ,pkg-url-str)
(package-url->checksum pkg-url-str
#:type 'clone
#:download-printf download-printf
#:pkg-name pkg-name)])) #:pkg-name pkg-name)]))
;; Downloads a package (if needed) and unpacks it (if needed) into a ;; Downloads a package (if needed) and unpacks it (if needed) into a
@ -49,6 +57,7 @@
(define (stage-package/info pkg (define (stage-package/info pkg
given-type given-type
given-pkg-name given-pkg-name
#:at-dir given-at-dir
#:given-checksum [given-checksum #f] #:given-checksum [given-checksum #f]
#:cached-url [cached-url #f] #:cached-url [cached-url #f]
#:use-cache? use-cache? #:use-cache? use-cache?
@ -86,12 +95,89 @@
;; Add "git://github.com/" ;; Add "git://github.com/"
(stage-package/info (string-append "git://github.com/" pkg) type (stage-package/info (string-append "git://github.com/" pkg) type
pkg-name pkg-name
#:at-dir given-at-dir
#:given-checksum given-checksum #:given-checksum given-checksum
#:use-cache? use-cache? #:use-cache? use-cache?
check-sums? download-printf check-sums? download-printf
metadata-ns metadata-ns
#:strip strip-mode #:strip strip-mode
#:force-strip? force-strip?)] #:force-strip? force-strip?)]
[(eq? type 'clone)
(define pkg-url (string->url pkg))
(define pkg-no-query (url->string
(struct-copy url pkg-url
[query null])))
(define-values (host port repo branch path)
(split-git-or-hub-url pkg-url))
(define clone-dir (or given-at-dir
(current-directory)))
(define tmp-dir (make-temporary-file
(string-append "~a-" pkg-name)
'directory))
(define (status s) (download-printf "~a\n" s))
(define staged? #f)
(dynamic-wind
void
(λ ()
(unless (and (directory-exists? clone-dir)
(directory-exists? (build-path clone-dir ".git")))
(download-printf "Cloning remote repository ~a\n to ~a\n"
pkg-no-query
clone-dir)
(make-directory* clone-dir)
(parameterize ([current-directory clone-dir])
(git #:status status "clone" "-b" branch pkg-no-query ".")))
(define orig-pkg (desc->orig-pkg 'clone pkg given-at-dir))
(define checksum
(or given-checksum
(remote-package-checksum orig-pkg download-printf pkg-name)))
(parameterize ([current-directory clone-dir])
(download-printf "Fetching from remote repository ~a\n"
pkg-no-query)
(git #:status status "fetch" pkg-no-query))
;; Make a clone of the [to-be-]linked checkout so that
;; we can check dependencies, etc., before changing
;; the checkout.
(download-printf "Cloning repository locally for staging\n")
(git #:status status "clone" clone-dir tmp-dir)
(parameterize ([current-directory tmp-dir])
(git #:status status "fetch" clone-dir (or checksum branch))
(git #:status status "checkout" (or checksum branch)))
(lift-git-directory-content tmp-dir path)
(begin0
(update-install-info-checksum
(update-install-info-orig-pkg
(update-install-info-git-dir
(stage-package/info tmp-dir
'dir
pkg-name
#:at-dir given-at-dir
#: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)
(apply build-path clone-dir path))
orig-pkg)
checksum)
(set! staged? #t)))
(λ ()
(unless staged?
(delete-directory/files tmp-dir))))]
[(or (eq? type 'file-url) [(or (eq? type 'file-url)
(eq? type 'dir-url) (eq? type 'dir-url)
(eq? type 'github) (eq? type 'github)
@ -100,7 +186,7 @@
(define pkg-url (string->url pkg-url-str)) (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-url-str)) (define orig-pkg (desc->orig-pkg type pkg-url-str #f))
(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
@ -119,7 +205,7 @@
(~a "cannot use empty checksum for Git repostory package source\n" (~a "cannot use empty checksum for Git repostory package source\n"
" source: ~a") " source: ~a")
pkg)) pkg))
(define-values (host repo branch path) (split-git-url pkg-url)) (define-values (host port repo branch path) (split-git-url pkg-url))
(define tmp-dir (define tmp-dir
(make-temporary-file (make-temporary-file
(string-append (string-append
@ -131,21 +217,16 @@
(dynamic-wind (dynamic-wind
void void
(λ () (λ ()
(download-repo! pkg-url host repo tmp-dir checksum (download-repo! pkg-url host port repo tmp-dir checksum
#:use-cache? use-cache? #:use-cache? use-cache?
#:download-printf download-printf) #:download-printf download-printf)
(unless (null? path) (lift-git-directory-content tmp-dir 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 (begin0
(stage-package/info tmp-dir (stage-package/info tmp-dir
'dir 'dir
pkg-name pkg-name
#:at-dir given-at-dir
#:given-checksum checksum #:given-checksum checksum
#:cached-url pkg-url #:cached-url pkg-url
#:use-cache? use-cache? #:use-cache? use-cache?
@ -218,6 +299,7 @@
(stage-package/info tmp-dir (stage-package/info tmp-dir
'dir 'dir
pkg-name pkg-name
#:at-dir given-at-dir
#:given-checksum checksum #:given-checksum checksum
#:cached-url new-url #:cached-url new-url
#:use-cache? use-cache? #:use-cache? use-cache?
@ -308,6 +390,7 @@
(stage-package/info package-path (stage-package/info package-path
download-type download-type
pkg-name pkg-name
#:at-dir given-at-dir
#:given-checksum checksum #:given-checksum checksum
#:cached-url pkg-url #:cached-url pkg-url
#:use-cache? use-cache? #:use-cache? use-cache?
@ -410,6 +493,7 @@
(stage-package/info pkg-dir (stage-package/info pkg-dir
'dir 'dir
pkg-name pkg-name
#:at-dir given-at-dir
#:given-checksum checksum #:given-checksum checksum
#:cached-url cached-url #:cached-url cached-url
#:use-cache? use-cache? #:use-cache? use-cache?
@ -440,12 +524,10 @@
[(or (eq? type 'link) [(or (eq? type 'link)
(eq? type 'static-link)) (eq? type 'static-link))
(install-info pkg-name (install-info pkg-name
`(,type ,(path->string (desc->orig-pkg type pkg-path #f)
(find-relative-path (pkg-installed-dir)
(simple-form-path pkg-path)
#:more-than-root? #t)))
pkg-path pkg-path
#f #f ; no git-dir
#f ; no clean?
given-checksum ; if a checksum is provided, just use it given-checksum ; if a checksum is provided, just use it
(directory->module-paths pkg pkg-name metadata-ns) (directory->module-paths pkg pkg-name metadata-ns)
(directory->additional-installs pkg pkg-name metadata-ns))] (directory->additional-installs pkg pkg-name metadata-ns))]
@ -473,6 +555,7 @@
(install-info pkg-name (install-info pkg-name
`(dir ,(simple-form-path* pkg-path)) `(dir ,(simple-form-path* pkg-path))
pkg-dir pkg-dir
#f ; no git-dir
(or (not in-place?) in-place-clean?) (or (not in-place?) in-place-clean?)
given-checksum ; if a checksum is provided, just use it given-checksum ; if a checksum is provided, just use it
(directory->module-paths pkg-dir pkg-name metadata-ns) (directory->module-paths pkg-dir pkg-name metadata-ns)
@ -485,6 +568,7 @@
(define info (stage-package/info source (define info (stage-package/info source
#f #f
pkg-name pkg-name
#:at-dir given-at-dir
#:given-checksum checksum #:given-checksum checksum
#:use-cache? use-cache? #:use-cache? use-cache?
check-sums? check-sums?
@ -499,7 +583,7 @@
(update-install-info-checksum (update-install-info-checksum
info info
checksum) checksum)
`(catalog ,pkg))] (desc->orig-pkg 'name pkg #f))]
[else [else
(pkg-error "cannot infer package source type\n source: ~a" pkg)])) (pkg-error "cannot infer package source type\n source: ~a" pkg)]))
@ -513,6 +597,7 @@
(define i (stage-package/info (pkg-desc-source desc) (define i (stage-package/info (pkg-desc-source desc)
(pkg-desc-type desc) (pkg-desc-type desc)
(pkg-desc-name desc) (pkg-desc-name desc)
#:at-dir (pkg-desc-extra-path desc)
#:given-checksum (pkg-desc-checksum desc) #:given-checksum (pkg-desc-checksum desc)
#:use-cache? use-cache? #:use-cache? use-cache?
#t #t
@ -535,19 +620,25 @@
#: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))
(define type (or given-type (define type (if (eq? given-type 'clone)
(let-values ([(name type) (package-source->name+type pkg-url-str given-type)]) (if (equal? "github" (url-scheme (string->url pkg-url-str)))
type))) 'github
'git)
(or given-type
(let-values ([(name type) (package-source->name+type pkg-url-str given-type)])
type))))
(case type (case type
[(git) [(git)
(define-values (host repo branch path) (define-values (host port repo branch path)
(split-git-url pkg-url)) (split-git-url pkg-url))
;; supplying `#:dest-dir #f` means that we just resolve `branch` (download-printf "Querying Git references for ~a at ~a\n" pkg-name pkg-url-str)
;; Supplying `#:dest-dir #f` means that we just resolve `branch`
;; to an ID: ;; to an ID:
(git-checkout host repo (git-checkout host #:port port repo
#:dest-dir #f #:dest-dir #f
#:ref branch #:ref branch
#:status-printf download-printf #:status-printf (lambda (fmt . args)
(log-pkg-debug (apply format fmt args)))
#:transport (string->symbol (url-scheme pkg-url)))] #:transport (string->symbol (url-scheme pkg-url)))]
[(github) [(github)
(match-define (list* user repo branch path) (match-define (list* user repo branch path)
@ -565,7 +656,7 @@
(cons 'client_secret (github-client_secret))) (cons 'client_secret (github-client_secret)))
empty)) empty))
#f)) #f))
(download-printf "Querying GitHub ~a\n" kind) (download-printf "Querying GitHub ~a for ~a\n" kind pkg-name)
(log-pkg-debug "Querying GitHub at ~a" (url->string api-u)) (log-pkg-debug "Querying GitHub at ~a" (url->string api-u))
(define api-bs (define api-bs
(call/input-url+200 (call/input-url+200
@ -624,6 +715,8 @@
(cond (cond
[(equal? "git" (url-scheme as-url)) [(equal? "git" (url-scheme as-url))
str] str]
[(equal? "github" (url-scheme as-url))
str]
[else [else
(define p (reverse (url-path as-url))) (define p (reverse (url-path as-url)))
(define skip (if (equal? "" (path/param-path (car p))) (define skip (if (equal? "" (path/param-path (car p)))
@ -651,35 +744,23 @@
(struct-copy install-info if (struct-copy install-info if
[checksum op])) [checksum op]))
(define (update-install-info-git-dir if dir)
(struct-copy install-info if
[git-directory dir]))
;; ---------------------------------------- ;; ----------------------------------------
(define github-client_id (make-parameter #f)) (define github-client_id (make-parameter #f))
(define github-client_secret (make-parameter #f)) (define github-client_secret (make-parameter #f))
(define (split-github-url pkg-url) (define (lift-git-directory-content tmp-dir path)
(if (equal? (url-scheme pkg-url) "github") (unless (null? path)
;; github:// (unless (directory-exists? (apply build-path tmp-dir path))
(map path/param-path (url-path/no-slash pkg-url)) (pkg-error
;; git:// (~a "specified directory is not in Git respository\n"
(let* ([paths (map path/param-path (url-path/no-slash pkg-url))]) " path: ~a")
(list* (car paths) (apply build-path path)))
(regexp-replace* #rx"[.]git$" (cadr paths) "") (lift-directory-content tmp-dir path)))
(or (url-fragment pkg-url) "master")
(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)))
;; ---------------------------------------- ;; ----------------------------------------