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)
(module+ main
(void (make-pkg-installer))
#;
(void (make-pkg-installer))
(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/format
setup/dirs
net/url
pkg/lib
pkg
string-constants
@ -13,11 +14,30 @@
(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)))
(if (not (eq? 'catalog (car (ipkg-source ipkg))))
(path->string (path->complete-path s dir))
s))
(define kind (car (ipkg-source ipkg)))
(case kind
[(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)
(format "~a: ~a"
@ -26,7 +46,8 @@
[(url) "URL"]
[(link) "Link"]
[(static-link) "Static link"]
[(file) "File"])
[(file) "File"]
[(clone) "Clone"])
(cadr s)))
(define (status-string a default-scope)
@ -152,14 +173,9 @@
[(path? scope) scope]
[(eq? scope 'installation) (find-pkgs-dir)]
[else (find-user-pkgs-dir)]))
;; Also preserve link kind:
(define kind (car (ipkg-source (car ipkgs))))
(apply
pkg-install-command
#:scope scope
#:link (eq? 'link kind)
#:static-link (eq? 'static-link kind)
(map (ipkg->source dir) ipkgs)))))]))
(parameterize ([current-pkg-scope scope])
(with-pkg-lock (pkg-install (map (ipkg->desc dir) ipkgs))))
(void))))]))
(define demote-button
(new button%
@ -215,12 +231,7 @@
(not (ipkg-auto? i)))))
(send promote-button enable (and same-scope?
(for/and ([i (in-list ipkgs)])
(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))))))))
(ipkg-auto? i))))
(send update-button enable (and same-scope?
(for/and ([i (in-list ipkgs)])
(not (memq (car (ipkg-source i))
@ -267,7 +278,7 @@
(if (eq? (car sa) (car sb))
(string<? (cadr sa) (cadr sb))
(case (car sa)
[(link) #t]
[(link static-link clone) #t]
[(catalog) (eq? b 'url)]
[(url) #f])))])))))
(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) ""]
[(link) "="]
[(static-link) "="]
[(clone) "="]
[(url) "@"])))
(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)
9000 - DrDr Web server
9001 - tests/net
9990 - tests/pkg
9997 - tests/pkg
9998 - tests/pkg
9999 - tests/web-server
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}
As a convenience, @command-ref{new} can automatically create single
collection packages.
As a convenience, @command-ref{new} can automate the creation of
a @tech{single-collection package}.
To create @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
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
@tech{multi-collection package}, the next step is to link your
@ -392,7 +392,7 @@ Whenever you
@commandline{git push}
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}.
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
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}
@ -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
package archive (and @tech{checksum}). Your changes will automatically be
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
@command-ref{create} documentation. If you want to generate an archive
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
your package for end users. You just need to push to your Git
repository, then within 24 hours, the PLT @tech{package catalog} will
notice, and @exec{raco pkg update} will work on your user's machines.
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
package implementors to effectively declare dependencies on provided
features. Such declarations allow @exec{raco pkg install} and
@exec{raco pkg update} to help check dependencies. Declaring and
features. Such declarations allow @command-ref{install} and
@command-ref{update} to help check dependencies. Declaring and
changing a version is optional, and the @tech{package catalog}
ignores version declarations; in particular, a package is a candidate
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[(
@defproc[(pkg-desc? [v any/c]) boolean?]
@defproc[(pkg-desc [source string?]
[type (or/c #f 'file 'dir 'link 'static-link
'file-url 'dir-url 'git 'github 'name)]
[type (or/c #f 'name 'file 'dir 'link 'static-link
'file-url 'dir-url 'git 'github 'clone)]
[name (or/c string? #f)]
[checksum (or/c string? #f)]
[auto? boolean?])
[auto? boolean?]
[#:path path (or/c #f path-string?) #f])
pkg-desc?]
)]{
A @racket[pkg-desc] value describes a package source plus details of its
intended interpretation, where the @racket[auto?] field indicates that
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?]
@ -271,8 +280,12 @@ Implements @racket[pkg-update-command]. The result is the same as for
@racket[pkg-install].
A string in @racket[names] refers to an installed package that should
be checked for updates. A @racket[pkg-desc] in @racket[names] indicates
a package source that should replace the current installation.
be checked for updates. A @racket[pkg-desc] in @racket[names]
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
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?]{
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
returns @racket[#f] otherwise.
The @racket['link] and @racket['static-link] formats are the same as
@racket['dir] in terms of parsing, but they are treated differently
for tasks such as package installation.
for tasks such as package installation. 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?]

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?)
(list/c 'url 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?)]
[auto? boolean?])
#: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
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).
If a given @nonterm{pkg-source} is ``auto-installed'' (to satisfy some other package's
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
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
directory's content to install. Directory @tech{package sources} are treated as links
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
@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,
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{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
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
(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.}
]
@history[#:changed "6.1.1.5" @elem{Added the @DFlag{clone} flag.}]}
@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
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 following @nonterm{option}s:
@itemlist[
@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.
(If the named package was installed through a package name, then there's effectively
no difference.)}
@ -534,6 +549,12 @@ the given @nonterm{pkg-source}s.
@item{@DFlag{skip-implies} --- 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{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{copy} --- 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{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} ...
@ -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
@nonterm{package} is the name of the new package.
If @nonterm{package} already exists as a folder in the current directory, no new
@subcommand{@command/toc{new} @nonterm{pkg} ---
Populates a directory with the stubs for a new package, where
@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.
}
@history[#:added "6.1.1.5"]}
@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
@ -612,8 +641,7 @@ package is created.
@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
the installation name/version @nonterm{vers}.}
]
}
]}
@subcommand{@command/toc{migrate} @nonterm{option} ... @nonterm{from-version}
--- 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["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")
'source)
"http://localhost:9999/pkg-test1.zip")
"http://localhost:9997/pkg-test1.zip")
(check-equal? (hash-ref (hash-ref details "pkg-test2")
'source)
"http://localhost:9999/pkg-test2.zip")
"http://localhost:9997/pkg-test2.zip")
(define test1-details (get-pkg-details-from-catalogs "pkg-test1"))
(check-equal? test1-details
@ -30,7 +30,7 @@
(define-values (cksum mods deps)
(get-pkg-content (pkg-desc "pkg-test1" #f #f #f #f)))
(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? (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))
$ "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])
(db:set-pkgs! "local"
(append (db:get-pkgs)
(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"))))
(db:set-pkg-modules! "fish" "local" "123" '((lib "fish/main.rkt") (lib "fish/food.rkt")))
(db:set-pkg-dependencies! "fish" "local" "123"
@ -78,7 +78,7 @@
(lambda (o)
(write (hash 'name "whale"
'checksum cksum
'source "http://localhost:9999/whale.plt"
'source "http://localhost:9997/whale.plt"
'versions (hash "5.3.6"
(hash 'checksum
123)))

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

@ -43,7 +43,7 @@
(hasheq 'checksum
(file->string "test-pkgs/pkg-test1-bad-checksum.zip.CHECKSUM")
'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"
$ "racket -e '(require pkg-test1)'" =exit> 1
$ "raco pkg install pkg-test1" =exit> 1
@ -53,20 +53,20 @@
(shelly-case
"checksums are checked (remote)"
$ "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))
(with-fake-root
(shelly-case
"checksums are required by default remotely (remote)"
$ "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))
(shelly-install* "but, bad checksums can be ignored (local)"
"--ignore-checksums test-pkgs/pkg-test1-bad-checksum.zip"
"pkg-test1-bad-checksum")
(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")
(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"))))

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
$ "raco pkg install --deps search-auto test-pkgs/pkg-test2.zip"
=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> ""
$ "racket -e '(require pkg-test2)'" =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
(file->string (format "test-pkgs/pkg-implied-~a.zip.CHECKSUM" s))
'source
(format "http://localhost:9999/pkg-implied-~a.zip" s))))
(format "http://localhost:9997/pkg-implied-~a.zip" s))))
(implied-version! "one")
(hash-set! *index-ht-1* "pkg-implies"
(hasheq 'checksum
(file->string "test-pkgs/pkg-implies.zip.CHECKSUM")
'source
"http://localhost:9999/pkg-implies.zip"))
"http://localhost:9997/pkg-implies.zip"))
(with-fake-root
(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)
(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)"
"http://localhost:9999/pkg-test1/")
"http://localhost:9997/pkg-test1/")
(with-fake-root
(shelly-begin
@ -96,19 +96,19 @@
(shelly-case
"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
"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
=stderr> #rx"could not find MANIFEST")
(shelly-case
"remote/URL/http directory, bad manifest"
;; 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
"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
=stderr> #rx"mismatched checksum")

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

@ -15,12 +15,12 @@
(hasheq 'checksum
(file->string "test-pkgs/pkg-b-second.plt.CHECKSUM")
'source
"http://localhost:9999/pkg-b-second.plt"))
"http://localhost:9997/pkg-b-second.plt"))
(hash-set! *index-ht-1* "pkg-a"
(hasheq 'checksum
(file->string "test-pkgs/pkg-a-first.plt.CHECKSUM")
'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 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"

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/./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))
@ -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/." #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/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.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/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 "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 "" 'dir-url) (values #f 'dir-url #f))
(check-equal-values? (parse "" 'git) (values #f 'git #f))
(check-equal-values? (parse "" 'github #rx"empty") (values #f 'github #f))
(check-equal-values? (parse "" 'github #rx"two path elements") (values #f 'github #f))
(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.CHECKSUM test-pkgs/update-test/pkg-test1.zip.CHECKSUM"
(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"
$ "raco pkg install --copy test-pkgs/pkg-test3"
$ "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
(file->string "test-pkgs/pkg-b-first.plt.CHECKSUM")
'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 install pkg-b"
$ "racket -e '(require pkg-b)'" =exit> 42
@ -19,12 +19,12 @@
(hasheq 'checksum
(file->string "test-pkgs/pkg-b-second.plt.CHECKSUM")
'source
"http://localhost:9999/pkg-b-second.plt"))
"http://localhost:9997/pkg-b-second.plt"))
(hash-set! *index-ht-1* "pkg-a"
(hasheq 'checksum
(file->string "test-pkgs/pkg-a-first.plt.CHECKSUM")
'source
"http://localhost:9999/pkg-a-first.plt"))))
"http://localhost:9997/pkg-a-first.plt"))))
(pkg-tests
(shelly-case
@ -41,12 +41,12 @@
(hasheq 'checksum
(file->string "test-pkgs/pkg-b-second.plt.CHECKSUM")
'source
"http://localhost:9999/pkg-b-second.plt"))
"http://localhost:9997/pkg-b-second.plt"))
(hash-set! *index-ht-1* "pkg-a"
(hasheq 'checksum
(file->string "test-pkgs/pkg-a-first.plt.CHECKSUM")
'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 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
@ -61,7 +61,7 @@
(hasheq 'checksum
(file->string "test-pkgs/pkg-a-second.plt.CHECKSUM")
'source
"http://localhost:9999/pkg-a-second.plt"))
"http://localhost:9997/pkg-a-second.plt"))
$ "raco pkg update -a" =exit> 0
$ "racket -e '(require pkg-a)'" =exit> 43
$ "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
(file->string "test-pkgs/pkg-b-first.plt.CHECKSUM")
'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 install pkg-b"
$ "racket -e '(require pkg-b)'" =exit> 42
@ -19,12 +19,12 @@
(hasheq 'checksum
(file->string "test-pkgs/pkg-b-second.plt.CHECKSUM")
'source
"http://localhost:9999/pkg-b-second.plt"))
"http://localhost:9997/pkg-b-second.plt"))
(hash-set! *index-ht-1* "pkg-a"
(hasheq 'checksum
(file->string "test-pkgs/pkg-a-first.plt.CHECKSUM")
'source
"http://localhost:9999/pkg-a-first.plt"))))
"http://localhost:9997/pkg-a-first.plt"))))
(pkg-tests
(shelly-case
@ -86,7 +86,7 @@
(hasheq 'checksum
(file->string "test-pkgs/pkg-a-second.plt.CHECKSUM")
'source
"http://localhost:9999/pkg-a-second.plt"))
"http://localhost:9997/pkg-a-second.plt"))
$ "racket -e '(require pkg-a)'" =exit> 0
$ "raco pkg update pkg-a" =exit> 0
$ "racket -e '(require pkg-a)'" =exit> 43
@ -104,7 +104,7 @@
(hasheq 'checksum
(file->string "test-pkgs/pkg-a-third.plt.CHECKSUM")
'source
"http://localhost:9999/pkg-a-third.plt"))
"http://localhost:9997/pkg-a-third.plt"))
$ "racket -e '(require pkg-a)'" =exit> 0
$ "raco pkg update pkg-a" =exit> 1
$ "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.CHECKSUM test-pkgs/update-test/pkg-test1.zip.CHECKSUM"
(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"
$ "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
@ -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.CHECKSUM test-pkgs/update-test/pkg-test3.zip.CHECKSUM"
(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"
$ "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"
@ -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.CHECKSUM test-pkgs/update-test/pkg-test3.zip.CHECKSUM"
(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"
$ "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"
@ -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.CHECKSUM test-pkgs/update-test/pkg-test2.zip.CHECKSUM"
(shelly-install* "update deps"
"http://localhost:9999/update-test/pkg-test1.zip"
"http://localhost:9997/update-test/pkg-test1.zip"
"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
=stdout> "Downloading checksum for pkg-test2\nDownloading checksum for pkg-test1\nNo updates available\n"
$ "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.CHECKSUM test-pkgs/update-test/pkg-test3.zip.CHECKSUM"
(shelly-install* "update original and deps"
"http://localhost:9999/update-test/pkg-test1.zip"
"http://localhost:9997/update-test/pkg-test1.zip"
"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
=stdout> "Downloading checksum for pkg-test3\nDownloading checksum for pkg-test1\nNo updates available\n"
$ "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.CHECKSUM test-pkgs/update-test/pkg-test3.zip.CHECKSUM"
(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"
$ "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
=stdout> "Downloading checksum for pkg-test3\nDownloading checksum for pkg-test1\nNo updates available\n"
$ "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.CHECKSUM test-pkgs/update-test/pkg-test3.zip.CHECKSUM"
(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"
$ "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"
$ "raco pkg update --update-deps pkg-test3" =exit> 0
=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.CHECKSUM test-pkgs/update-test/pkg-test1.zip.CHECKSUM"
(shelly-install* "update all"
"http://localhost:9999/update-test/pkg-test1.zip"
"http://localhost:9997/update-test/pkg-test1.zip"
"pkg-test1"
$ "raco pkg install test-pkgs/pkg-test2.zip"
$ "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
(file->string "test-pkgs/pkg-v-one.zip.CHECKSUM")
'source
"http://localhost:9999/pkg-v-one.zip"))
"http://localhost:9997/pkg-v-one.zip"))
(hash-set! *index-ht-1* "pkg-w"
(hasheq 'checksum
(file->string "test-pkgs/pkg-w-one.zip.CHECKSUM")
'source
"http://localhost:9999/pkg-w-one.zip"))
"http://localhost:9997/pkg-w-one.zip"))
$ "raco pkg config --set catalogs http://localhost:9990"
@ -57,7 +57,7 @@
(hasheq 'checksum
(file->string "test-pkgs/pkg-v-two.zip.CHECKSUM")
'source
"http://localhost:9999/pkg-v-two.zip"))
"http://localhost:9997/pkg-v-two.zip"))
(shelly-case
"update"
@ -68,12 +68,12 @@
(hasheq 'checksum
(file->string "test-pkgs/pkg-v-three.zip.CHECKSUM")
'source
"http://localhost:9999/pkg-v-three.zip"))
"http://localhost:9997/pkg-v-three.zip"))
(hash-set! *index-ht-1* "pkg-w"
(hasheq 'checksum
(file->string "test-pkgs/pkg-w-two.zip.CHECKSUM")
'source
"http://localhost:9999/pkg-w-two.zip"))
"http://localhost:9997/pkg-w-two.zip"))
(shelly-case
"update again"
@ -85,7 +85,7 @@
(hasheq 'checksum
(file->string "test-pkgs/pkg-w-three.zip.CHECKSUM")
'source
"http://localhost:9999/pkg-w-three.zip"))
"http://localhost:9997/pkg-w-three.zip"))
(shelly-case
"update again"

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

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

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

@ -34,6 +34,12 @@
(or/c 'installation 'user
(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
(all-from-out "path.rkt")
with-pkg-lock
@ -58,13 +64,15 @@
(parameter/c (or/c #f real?))]
[pkg-directory
(-> string? (or/c path-string? #f))]
[pkg-desc
(-> string?
(or/c #f 'file 'dir 'link 'static-link 'file-url 'dir-url 'git 'github 'name)
(or/c string? #f)
(or/c string? #f)
boolean?
pkg-desc?)]
[rename
pkg-desc/opt pkg-desc
(->* (string?
(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?)
(#:path (or/c #f path-string?))
pkg-desc?)]
[pkg-config
(->* (boolean? (listof string?))
(#:from-command-line? boolean?)

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

@ -114,7 +114,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-defns (install-copy-defns ...)
#:install-copy-checks (install-copy-checks ...))
(with-syntax ([([scope-flags ...]
[job-flags ...]
[catalog-flags ...]
@ -123,7 +124,8 @@
[install-force-flags ...]
[update-deps-flags ...]
[install-copy-flags ...]
[install-copy-defns ...])
[install-copy-defns ...]
[install-copy-checks ...])
(syntax-local-introduce #'([scope-flags ...]
[job-flags ...]
[catalog-flags ...]
@ -132,7 +134,8 @@
[install-force-flags ...]
[update-deps-flags ...]
[install-copy-flags ...]
[install-copy-defns ...]))])
[install-copy-defns ...]
[install-copy-checks ...]))])
#`(commands
"This tool is used for managing installed packages."
"pkg-~a-command"
@ -167,6 +170,7 @@
'install
scope scope-dir installation user #f a-type
(lambda ()
install-copy-checks ...
(when (and name (> (length pkg-source) 1))
((current-pkg-error) (format "the --name flag only makes sense with a single package source")))
(unless (or (not name) (package-source->name name))
@ -199,7 +203,9 @@
#:force-strip? force
#:link-dirs? link-dirs?
(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)))]
;; ----------------------------------------
[update
@ -226,40 +232,53 @@
job-flags ...
#:args pkg-source
install-copy-defns ...
(call-with-package-scope
'update
scope scope-dir installation user pkg-source #f
(lambda ()
(define setup-collects
(with-pkg-lock
(parameterize ([current-pkg-catalogs (and catalog
(list (catalog->url catalog)))])
(pkg-update (for/list ([pkg-source (in-list pkg-source)])
(cond
[lookup
(pkg-desc pkg-source a-type name checksum #f)]
[else
(define-values (pkg-name pkg-type)
(package-source->name+type pkg-source a-type))
(if (eq? pkg-type 'name)
pkg-name
(pkg-desc pkg-source a-type name checksum #f))]))
#:from-command-line? #t
#:all? all
#: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)))]
(let ([pkg-source (cond
[(and (null? pkg-source)
(not all)
(not clone))
;; In a package directory?
(define pkg (path->pkg (current-directory)))
(if pkg
(list pkg)
null)]
[else pkg-source])])
(call-with-package-scope
'update
scope scope-dir installation user pkg-source #f
(lambda ()
install-copy-checks ...
(define setup-collects
(with-pkg-lock
(parameterize ([current-pkg-catalogs (and catalog
(list (catalog->url catalog)))])
(pkg-update (for/list ([pkg-source (in-list pkg-source)])
(cond
[lookup
(pkg-desc pkg-source a-type name checksum #f)]
[else
(define-values (pkg-name pkg-type)
(package-source->name+type pkg-source a-type))
(if (eq? pkg-type 'name)
pkg-name
(pkg-desc pkg-source a-type name checksum #f
#:path (and (eq? a-type 'clone)
(path->complete-path clone))))]))
#:from-command-line? #t
#:all? all
#: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 packages"
@ -559,12 +578,29 @@
([#: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 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 binary () ("Strip packages' source elements before installing; implies --copy")]
[#:bool binary-lib () ("Strip source & documentation before installing; implies --copy")])
#:install-copy-defns
[(define link-dirs? (not (or copy source binary binary-lib)))
(define a-type (or (and link 'link)
(and static-link 'static-link)
(and (eq? type 'dir) link-dirs? 'link)
type))]))
(define link-type (or (and link 'link)
(and static-link 'static-link)
(and (eq? type 'dir) link-dirs? 'link)
(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 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?)
(and name
@ -134,14 +134,22 @@
(eq? type 'name)
(regexp-match? rx:package-name s))
(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)
(not (regexp-match? #rx"^git(?:hub)?://" s)))
(package-source->name+type
(string-append "git://github.com/" s)
'github)]
'github
#:link-dirs? link-dirs?
#:complain complain-proc
#:must-infer-name? must-infer-name?)]
[(if type
(or (eq? type 'github)
(eq? type 'git)
(eq? type 'clone)
(eq? type 'file-url)
(eq? type 'dir-url))
(regexp-match? #rx"^(https?|github|git)://" s))
@ -152,7 +160,9 @@
(let ([p (url-path url)])
(cond
[(if type
(eq? type 'github)
(or (eq? type 'github)
(and (eq? type 'clone)
(equal? (url-scheme url) "github")))
(or (equal? (url-scheme url) "github")
(equal? (url-scheme url) "git")))
(unless (or (equal? (url-scheme url) "github")
@ -218,7 +228,8 @@
(extract-archive-name (last-non-empty p) complain-name)))
(values name 'file-url)]
[(if type
(eq? type 'git)
(or (eq? type 'git)
(eq? type 'clone))
(and (last-non-empty p)
(string-and-regexp-match? rx:git (last-non-empty p))
((num-empty p) . < . 2)))

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

@ -129,7 +129,8 @@
(define orig (pkg-info-orig-pkg v))
(if (and (pair? 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
(hash-ref cache `(pkg-dir ,(cadr orig)) #f))
(let ([e (explode (simplify-path

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

@ -134,7 +134,7 @@
;; Download/unpack existing package:
(define-values (staged-name staged-dir staged-checksum clean? staged-mods)
(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
#:use-cache? #t
#:quiet? quiet?))

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

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

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

@ -3,7 +3,7 @@
(provide (struct-out 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 (->list a)
@ -11,5 +11,6 @@
(pkg-desc-type a)
(pkg-desc-name a)
(pkg-desc-checksum a)
(pkg-desc-auto? a)))
(pkg-desc-auto? a)
(pkg-desc-extra-path a)))
(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))))))
(define (download-repo! url host repo dest-dir checksum
(define (download-repo! url host port repo dest-dir checksum
#:download-printf [download-printf #f]
#:use-cache? [use-cache? #t])
(log-pkg-debug "\t\tDownloading ~a to ~a" (url->string url) dest-dir)
@ -107,7 +107,7 @@
(define unpacked? #f)
(define (download!)
(git-checkout host repo
(git-checkout host #:port port repo
#:dest-dir dest-dir
#:ref checksum
#: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"
"dep.rkt"
"get-info.rkt"
"catalog.rkt"
"dirs.rkt"
"collects.rkt"
"addl-installs.rkt")
"addl-installs.rkt"
"repo-path.rkt"
"orig-pkg.rkt"
"git.rkt")
(provide pkg-install
pkg-update)
(define (checksum-for-pkg-source pkg-source type pkg-name given-checksum download-printf)
(case type
[(file-url dir-url github git)
[(file-url dir-url github git clone)
(or given-checksum
(remote-package-checksum `(url ,pkg-source) download-printf pkg-name #:type type))]
[(file)
@ -41,6 +45,9 @@
(file->string checksum-pth))
(and (file-exists? pkg-source)
(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]))
(define (disallow-package-path-overlaps pkg-name
@ -154,9 +161,9 @@
(define all-db (merge-pkg-dbs))
(define path-pkg-cache (make-hash))
(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
(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)
(define name? (eq? 'catalog (first orig-pkg)))
(define this-dep-behavior (or dep-behavior
@ -209,10 +216,13 @@
;; Also, make sure it's installed in the scope that we're changing:
(hash-ref current-scope-db pkg-name #f))
;; promote an auto-installed package to a normally installed one
(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)))]
(cons
#f ; no repo change
;; The `do-it` thunk:
(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
;; Fail --- already installed
(clean!)
@ -405,7 +415,8 @@
#:all-platforms? all-platforms?
#:ignore-checksums? ignore-checksums?
#:use-cache? use-cache?
#:from-command-line? from-command-line?)
#:from-command-line? from-command-line?
#:link-dirs? link-dirs?)
name))
null))
deps))
@ -508,7 +519,8 @@
#:all-platforms? all-platforms?
#:ignore-checksums? ignore-checksums?
#:use-cache? use-cache?
#:from-command-line? from-command-line?)
#:from-command-line? from-command-line?
#:link-dirs? link-dirs?)
update-pkgs)])
(λ () (for-each (compose (remove-package quiet?) pkg-desc-name) to-update))))
(match this-dep-behavior
@ -531,48 +543,57 @@
(clean!)
(report-mismatch update-deps)])]))]
[else
(λ ()
(when updating?
(download-printf "Re-installing ~a\n" pkg-name))
(define final-pkg-dir
(cond
(cons
;; The repo to get new commits, if any:
(and git-dir
(list (enclosing-path-for-repo (caddr orig-pkg) git-dir)
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?
(define final-pkg-dir (select-package-directory
(build-path (pkg-installed-dir) pkg-name)))
(make-parent-directory* final-pkg-dir)
(copy-directory/files pkg-dir final-pkg-dir #:keep-modify-seconds? #t)
(define final-pkg-dir (or git-dir
(select-package-directory
(build-path (pkg-installed-dir) pkg-name))))
(unless git-dir
(make-parent-directory* final-pkg-dir)
(copy-directory/files pkg-dir final-pkg-dir #:keep-modify-seconds? #t))
(clean!)
final-pkg-dir]
[else
pkg-dir]))
(define single-collect (pkg-single-collection final-pkg-dir
#:name pkg-name
#:namespace post-metadata-ns))
(log-pkg-debug "creating ~alink to ~e"
(if single-collect "single-collection " "")
final-pkg-dir)
(define scope (current-pkg-scope))
(links final-pkg-dir
#:name single-collect
#:user? (not (or (eq? 'installation scope)
(path? scope)))
#:file (scope->links-file scope)
#:root? (not single-collect)
#:static-root? (and (pair? orig-pkg)
(eq? 'static-link (car orig-pkg))))
(define alt-dir-name
;; If we had to pick an alternate dir name, then record it:
(let-values ([(base name dir?) (split-path final-pkg-dir)])
(and (regexp-match? #rx"[+]" name)
(path->string name))))
(define this-pkg-info
(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)
(update-pkg-db! pkg-name this-pkg-info))]))
(define single-collect (pkg-single-collection final-pkg-dir
#:name pkg-name
#:namespace post-metadata-ns))
(log-pkg-debug "creating ~alink to ~e"
(if single-collect "single-collection " "")
final-pkg-dir)
(define scope (current-pkg-scope))
(links final-pkg-dir
#:name single-collect
#:user? (not (or (eq? 'installation scope)
(path? scope)))
#:file (scope->links-file scope)
#:root? (not single-collect)
#:static-root? (and (pair? orig-pkg)
(eq? 'static-link (car orig-pkg))))
(define alt-dir-name
;; If we had to pick an alternate dir name, then record it:
(let-values ([(base name dir?) (split-path final-pkg-dir)])
(and (regexp-match? #rx"[+]" name)
(path->string name))))
(define this-pkg-info
(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)
(update-pkg-db! pkg-name this-pkg-info)))]))
(define metadata-ns (make-metadata-namespace))
(define infos
(for/list ([v (in-list descs)])
(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)
#:use-cache? use-cache?
check-sums? download-printf
@ -598,14 +619,49 @@
(define all-descs (append old-descs descs))
(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)
all-descs
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)
(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)
;; if the package name is in `current-scope-db', we must
@ -628,7 +684,7 @@
post-metadata-ns)))
(cond
[(or (null? do-its)
[(or (null? repo+do-its)
(and (not updating?) (andmap is-promote? all-infos)))
;; No actions, so no setup:
'skip]
@ -751,7 +807,7 @@
(for/list ([dep (in-list deps)])
(if (pkg-desc? dep)
dep
(pkg-desc dep #f #f #f #t))))])])
(pkg-desc dep #f #f #f #t #f))))])])
(begin0
(install-packages
#:old-infos old-infos
@ -813,7 +869,8 @@
#:all-platforms? all-platforms?
#:ignore-checksums? ignore-checksums?
#:use-cache? use-cache?
#:from-command-line? from-command-line?)
#:from-command-line? from-command-line?
#:link-dirs? link-dirs?)
pkg-name)
(cond
[(pkg-desc? pkg-name)
@ -821,6 +878,7 @@
(define-values (inferred-name type) (package-source->name+type
(pkg-desc-source pkg-name)
(pkg-desc-type pkg-name)
#:link-dirs? link-dirs?
#:must-infer-name? (not (pkg-desc-name pkg-name))
#:complain complain-about-source))
(define name (or (pkg-desc-name pkg-name)
@ -832,6 +890,7 @@
name
(pkg-desc-checksum pkg-name)
download-printf))
(hash-set! update-cache name new-checksum) ; record downloaded checksum
(unless (or ignore-checksums? (not (pkg-desc-checksum pkg-name)))
(unless (equal? (pkg-desc-checksum pkg-name) new-checksum)
(pkg-error (~a "incorrect checksum on package\n"
@ -841,10 +900,16 @@
(pkg-desc-source pkg-name)
(pkg-desc-checksum pkg-name)
new-checksum)))
(if (or (not (equal? (pkg-info-checksum info)
new-checksum))
;; 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:
(begin
(hash-set! update-cache (pkg-desc-source pkg-name) #t)
@ -852,7 +917,10 @@
(pkg-desc-type pkg-name)
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:
(if (or deps?
implies?)
@ -865,7 +933,8 @@
#:all-platforms? all-platforms?
#:ignore-checksums? ignore-checksums?
#:use-cache? use-cache?
#:from-command-line? from-command-line?)
#:from-command-line? from-command-line?
#:link-dirs? link-dirs?)
name)
null))]
[(eq? #t (hash-ref update-cache pkg-name #f))
@ -881,12 +950,10 @@
(match orig-pkg
[`(,(or 'link 'static-link) ,orig-pkg-dir)
(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 source: ~a")
(if from-command-line?
" without `--link'"
" without new link")
pkg-name
(normalize-path
(path->complete-path orig-pkg-dir (pkg-installed-dir))))
@ -894,6 +961,7 @@
[`(dir ,_)
(if must-update?
(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 name: ~a")
pkg-name)
@ -901,11 +969,21 @@
[`(file ,_)
(if must-update?
(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 name: ~a")
pkg-name)
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
(or (hash-ref update-cache pkg-name #f)
(remote-package-checksum orig-pkg download-printf pkg-name)))
@ -920,9 +998,8 @@
;; there was a race between our checkig and updates on
;; the catalog server:
(clear-checksums-in-cache! update-cache)
;; FIXME: the type shouldn't be #f here; it should be
;; preseved from install time:
(list (pkg-desc orig-pkg-source #f pkg-name #f auto?))))
(list (pkg-desc orig-pkg-source orig-pkg-type pkg-name #f auto?
orig-pkg-dir))))
(if (or deps? implies?)
;; Check dependencies
(append-map
@ -935,7 +1012,8 @@
#:all-platforms? all-platforms?
#:ignore-checksums? ignore-checksums?
#: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?
#:only-implies? (not deps?))
pkg-name))
@ -975,14 +1053,18 @@
#:all-platforms? all-platforms?
#:ignore-checksums? ignore-checksums?
#:use-cache? use-cache?
#:from-command-line? from-command-line?)
pkgs))
#:from-command-line? from-command-line?
#:link-dirs? link-dirs?)
(map (convert-clone-name-to-clone-repo db)
pkgs)))
(cond
[(empty? pkgs)
(unless quiet?
(printf/flush (~a "No packages given to update"
(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")))
'skip]
@ -1015,6 +1097,49 @@
#:link-dirs? link-dirs?
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)
@ -1022,3 +1147,4 @@
#:when (string? v))
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
(require racket/match
net/url
"../path.rkt"
"config.rkt"
"lock.rkt"
"pkg-db.rkt"
"desc.rkt"
"params.rkt"
"install.rkt")
"install.rkt"
"repo-path.rkt"
"dirs.rkt")
(provide pkg-migrate)
@ -24,17 +27,25 @@
(define from-db
(parameterize ([current-pkg-scope-version from-version])
(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
(sort
(for/list ([(name info) (in-hash from-db)]
#:unless (pkg-info-auto? info))
(define-values (source type)
(define-values (source type dir)
(match (pkg-info-orig-pkg info)
[(list 'catalog name) (values name 'name)]
[(list 'url url) (values url #f)]
[(list 'link path) (values path 'link)]
[(list 'static-link path) (values path 'static-link)]))
(pkg-desc source type name #f #f))
[(list 'catalog name) (values name 'name #f)]
[(list 'url url) (values url #f #f)]
[(list 'link path) (values (path->complete-string path) 'link #f)]
[(list 'static-link path) (values (path->complete-string path) 'static-link #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<?
#:key pkg-desc-name))
(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 ()
(match-define (pkg-info orig-pkg checksum _) info)
(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))]
[_
(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)
(path? scope))))
(match orig-pkg
[`(,(or 'link 'static-link) ,_)
[`(,(or 'link 'static-link 'clone) ,_ . ,_)
(links pkg-dir
#:remove? #t
#: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"
"get-info.rkt"
"mod-paths.rkt"
"addl-installs.rkt")
"addl-installs.rkt"
"repo-path.rkt"
"orig-pkg.rkt"
"git.rkt")
(provide (struct-out install-info)
remote-package-checksum
stage-package/info
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])
(match pkg
@ -42,6 +45,11 @@
(package-url->checksum pkg-url-str
#:type type
#: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)]))
;; Downloads a package (if needed) and unpacks it (if needed) into a
@ -49,6 +57,7 @@
(define (stage-package/info pkg
given-type
given-pkg-name
#:at-dir given-at-dir
#:given-checksum [given-checksum #f]
#:cached-url [cached-url #f]
#:use-cache? use-cache?
@ -86,12 +95,89 @@
;; Add "git://github.com/"
(stage-package/info (string-append "git://github.com/" pkg) type
pkg-name
#:at-dir given-at-dir
#:given-checksum given-checksum
#:use-cache? use-cache?
check-sums? download-printf
metadata-ns
#:strip strip-mode
#: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)
(eq? type 'dir-url)
(eq? type 'github)
@ -100,7 +186,7 @@
(define pkg-url (string->url pkg-url-str))
(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
;; 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
@ -119,7 +205,7 @@
(~a "cannot use empty checksum for Git repostory package source\n"
" source: ~a")
pkg))
(define-values (host repo branch path) (split-git-url pkg-url))
(define-values (host port repo branch path) (split-git-url pkg-url))
(define tmp-dir
(make-temporary-file
(string-append
@ -131,21 +217,16 @@
(dynamic-wind
void
(λ ()
(download-repo! pkg-url host repo tmp-dir checksum
(download-repo! pkg-url host port repo tmp-dir checksum
#:use-cache? use-cache?
#:download-printf download-printf)
(unless (null? path)
(unless (directory-exists? (apply build-path tmp-dir path))
(pkg-error
(~a "specified directory is not in Git respository\n"
" path: ~a")
(apply build-path path)))
(lift-directory-content tmp-dir path))
(lift-git-directory-content tmp-dir path)
(begin0
(stage-package/info tmp-dir
'dir
pkg-name
#:at-dir given-at-dir
#:given-checksum checksum
#:cached-url pkg-url
#:use-cache? use-cache?
@ -218,6 +299,7 @@
(stage-package/info tmp-dir
'dir
pkg-name
#:at-dir given-at-dir
#:given-checksum checksum
#:cached-url new-url
#:use-cache? use-cache?
@ -308,6 +390,7 @@
(stage-package/info package-path
download-type
pkg-name
#:at-dir given-at-dir
#:given-checksum checksum
#:cached-url pkg-url
#:use-cache? use-cache?
@ -410,6 +493,7 @@
(stage-package/info pkg-dir
'dir
pkg-name
#:at-dir given-at-dir
#:given-checksum checksum
#:cached-url cached-url
#:use-cache? use-cache?
@ -440,12 +524,10 @@
[(or (eq? type 'link)
(eq? type 'static-link))
(install-info pkg-name
`(,type ,(path->string
(find-relative-path (pkg-installed-dir)
(simple-form-path pkg-path)
#:more-than-root? #t)))
(desc->orig-pkg type pkg-path #f)
pkg-path
#f
#f ; no git-dir
#f ; no clean?
given-checksum ; if a checksum is provided, just use it
(directory->module-paths pkg pkg-name metadata-ns)
(directory->additional-installs pkg pkg-name metadata-ns))]
@ -473,6 +555,7 @@
(install-info pkg-name
`(dir ,(simple-form-path* pkg-path))
pkg-dir
#f ; no git-dir
(or (not in-place?) in-place-clean?)
given-checksum ; if a checksum is provided, just use it
(directory->module-paths pkg-dir pkg-name metadata-ns)
@ -485,6 +568,7 @@
(define info (stage-package/info source
#f
pkg-name
#:at-dir given-at-dir
#:given-checksum checksum
#:use-cache? use-cache?
check-sums?
@ -499,7 +583,7 @@
(update-install-info-checksum
info
checksum)
`(catalog ,pkg))]
(desc->orig-pkg 'name pkg #f))]
[else
(pkg-error "cannot infer package source type\n source: ~a" pkg)]))
@ -513,6 +597,7 @@
(define i (stage-package/info (pkg-desc-source desc)
(pkg-desc-type desc)
(pkg-desc-name desc)
#:at-dir (pkg-desc-extra-path desc)
#:given-checksum (pkg-desc-checksum desc)
#:use-cache? use-cache?
#t
@ -535,19 +620,25 @@
#:pkg-name [pkg-name "package"])
(define pkg-url
(string->url pkg-url-str))
(define type (or given-type
(let-values ([(name type) (package-source->name+type pkg-url-str given-type)])
type)))
(define type (if (eq? given-type 'clone)
(if (equal? "github" (url-scheme (string->url pkg-url-str)))
'github
'git)
(or given-type
(let-values ([(name type) (package-source->name+type pkg-url-str given-type)])
type))))
(case type
[(git)
(define-values (host repo branch path)
(define-values (host port repo branch path)
(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:
(git-checkout host repo
(git-checkout host #:port port repo
#:dest-dir #f
#: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)))]
[(github)
(match-define (list* user repo branch path)
@ -565,7 +656,7 @@
(cons 'client_secret (github-client_secret)))
empty))
#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))
(define api-bs
(call/input-url+200
@ -624,6 +715,8 @@
(cond
[(equal? "git" (url-scheme as-url))
str]
[(equal? "github" (url-scheme as-url))
str]
[else
(define p (reverse (url-path as-url)))
(define skip (if (equal? "" (path/param-path (car p)))
@ -651,35 +744,23 @@
(struct-copy install-info if
[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_secret (make-parameter #f))
(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)
(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 (lift-git-directory-content tmp-dir path)
(unless (null? path)
(unless (directory-exists? (apply build-path tmp-dir path))
(pkg-error
(~a "specified directory is not in Git respository\n"
" path: ~a")
(apply build-path path)))
(lift-directory-content tmp-dir path)))
;; ----------------------------------------