raco pkg {install,update}: track Git repo source from a catalog
When a package is installed via a catalog, and the source provided by the catalog is a Git repostory, then allow `--clone` to use that repository when just the package name is given.
This commit is contained in:
Matthew Flatt
parent
6379aaddef
commit
8498eff8ef
|
|
@ -16,6 +16,7 @@ utilities for working with package paths and installed-package
|
|||
databases.}
|
||||
|
||||
@defstruct*[pkg-info ([orig-pkg (or/c (list/c 'catalog string?)
|
||||
(list/c 'catalog string? string?)
|
||||
(list/c 'url string?)
|
||||
(list/c 'link string?)
|
||||
(list/c 'static-link string?)
|
||||
|
|
@ -24,7 +25,18 @@ databases.}
|
|||
[auto? boolean?])
|
||||
#:prefab]{
|
||||
|
||||
A structure type that is used to report installed-package information.}
|
||||
A structure type that is used to report installed-package information.
|
||||
|
||||
The @racket[orig-pkg] field describes the source of the package as
|
||||
installed, where @racket['catalog] refers to a package that was
|
||||
installed by consulting a catalog with a package name, and so on. The
|
||||
two-element @racket['catalog] form records a URL for a Git or GitHub
|
||||
package source when the catalog reported such a source, and the URL is
|
||||
used for operations that adjust @racket['clone]-form installations.
|
||||
|
||||
@history[#:changed "6.1.1.5" @elem{Added @racket['clone] and two-level
|
||||
@racket['catalog] variants for
|
||||
@racket[orig-pkg].}]}
|
||||
|
||||
|
||||
@defstruct*[(sc-pkg-info pkg-info) ()]{
|
||||
|
|
|
|||
|
|
@ -552,9 +552,12 @@ within a package, then the enclosing package is updated.
|
|||
@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
|
||||
be currently installed from a Git or GitHub source---possibly as
|
||||
directed by a catalog---and that
|
||||
source is used for the clone (which replaces the existing package
|
||||
installation).}
|
||||
installation). If no @nonterm{pkg-source} is supplied, then
|
||||
the last path element of @nonterm{dir} is used as a package name
|
||||
and used as a @nonterm{pkg-source} argument.}
|
||||
@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}.}
|
||||
|
|
|
|||
|
|
@ -39,7 +39,8 @@
|
|||
"locking"
|
||||
"overwrite"
|
||||
"config"
|
||||
|
||||
"clone"
|
||||
|
||||
"network"
|
||||
"planet"
|
||||
"main-server"
|
||||
|
|
|
|||
|
|
@ -56,12 +56,23 @@
|
|||
(test-remote "git://github.com/mflatt/pkg-test")
|
||||
(test-remote "https://github.com/mflatt/pkg-test.git")
|
||||
(test-remote "https://bitbucket.org/mflatt/pkg-test.git")
|
||||
|
||||
(define (try-git-repo label type+repo)
|
||||
(define tmp-dir (make-temporary-file "~a-clone" 'directory))
|
||||
(shelly-install
|
||||
label
|
||||
type+repo
|
||||
(shelly-wind
|
||||
$ "racket -l racket/base -l pkg-test1/number -e '(number)'" =stdout> "10\n"
|
||||
$ (~a "raco pkg update --clone " tmp-dir " pkg-test1")
|
||||
$ "racket -l racket/base -l pkg-test1/number -e '(number)'" =stdout> "10\n"
|
||||
$ (~a "raco pkg update " type+repo)
|
||||
(finally
|
||||
(delete-directory/files tmp-dir)))))
|
||||
|
||||
(shelly-install
|
||||
(try-git-repo
|
||||
"remote/github with auto prefix and with branch"
|
||||
"--type github mflatt/pkg-test?path=pkg-test1/#alt"
|
||||
$ "racket -l racket/base -l pkg-test1/number -e '(number)'" =stdout> "10\n")
|
||||
(shelly-install
|
||||
"--type github mflatt/pkg-test?path=pkg-test1/#alt")
|
||||
(try-git-repo
|
||||
"remote/git type"
|
||||
"--type git https://bitbucket.org/mflatt/pkg-test?path=pkg-test1#alt"
|
||||
$ "racket -l racket/base -l pkg-test1/number -e '(number)'" =stdout> "10\n"))
|
||||
"--type git https://bitbucket.org/mflatt/pkg-test?path=pkg-test1#alt"))
|
||||
|
|
|
|||
|
|
@ -41,7 +41,9 @@
|
|||
|
||||
;; Selects scope from `given-scope' through `user' arguments, or infers
|
||||
;; a scope from `pkgs' if non-#f, and then calls `thunk'.
|
||||
(define (call-with-package-scope who given-scope scope-dir installation user pkgs pkgs-type thunk)
|
||||
(define (call-with-package-scope who given-scope scope-dir installation user pkgs
|
||||
pkgs-type clone-type-can-be-name? given-name
|
||||
thunk)
|
||||
(define scope
|
||||
(case given-scope
|
||||
[(installation user) given-scope]
|
||||
|
|
@ -63,15 +65,26 @@
|
|||
(with-pkg-lock/read-only
|
||||
(define-values (pkg scope)
|
||||
(for/fold ([prev-pkg #f] [prev-scope #f]) ([pkg (in-list pkgs)])
|
||||
(define-values (pkg-name pkg-type)
|
||||
(package-source->name+type pkg pkgs-type
|
||||
#:must-infer-name? #t
|
||||
#:complain
|
||||
(lambda (s msg)
|
||||
((current-pkg-error)
|
||||
(~a "~a\n"
|
||||
" given: ~a")
|
||||
msg s))))
|
||||
(define-values (pkg-name pkg-type/unused)
|
||||
(cond
|
||||
[given-name (values given-name #f)]
|
||||
[(and (eq? pkgs-type 'clone)
|
||||
clone-type-can-be-name?
|
||||
(let-values ([(pkg-name pkg-type)
|
||||
(package-source->name+type pkg #f)])
|
||||
(and (eq? pkg-type 'name)
|
||||
pkg-name)))
|
||||
=> (lambda (name)
|
||||
(values name #f))]
|
||||
[else
|
||||
(package-source->name+type pkg pkgs-type
|
||||
#:must-infer-name? #t
|
||||
#:complain
|
||||
(lambda (s msg)
|
||||
((current-pkg-error)
|
||||
(~a "~a\n"
|
||||
" given: ~a")
|
||||
msg s)))]))
|
||||
(define scope (find-pkg-installation-scope pkg-name))
|
||||
(cond
|
||||
[(not prev-pkg) (values pkg scope)]
|
||||
|
|
@ -168,7 +181,7 @@
|
|||
install-copy-defns ...
|
||||
(call-with-package-scope
|
||||
'install
|
||||
scope scope-dir installation user #f a-type
|
||||
scope scope-dir installation user #f a-type #f name
|
||||
(lambda ()
|
||||
install-copy-checks ...
|
||||
(when (and name (> (length pkg-source) 1))
|
||||
|
|
@ -232,19 +245,35 @@
|
|||
job-flags ...
|
||||
#:args pkg-source
|
||||
install-copy-defns ...
|
||||
(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])])
|
||||
(let ([pkg-source
|
||||
;; Implement special rules for an empty list of package sources
|
||||
(cond
|
||||
[(or (not (null? pkg-source))
|
||||
all) ; --all has is own treatment of an empty list
|
||||
pkg-source]
|
||||
[clone
|
||||
;; Use directory name as sole package name, if possible
|
||||
(define-values (base name dir?) (split-path clone))
|
||||
(cond
|
||||
[(and (path? name)
|
||||
(let-values ([(pkg-name pkg-type)
|
||||
(package-source->name+type (path-element->string name) #f)])
|
||||
(eq? pkg-type 'name)))
|
||||
(list (path-element->string name))]
|
||||
[else
|
||||
((pkg-error 'update)
|
||||
(~a "cannot extract a valid package name from the `--clone' path\n"
|
||||
" given path: ~a")
|
||||
clone)])]
|
||||
[else
|
||||
;; In a package directory?
|
||||
(define pkg (path->pkg (current-directory)))
|
||||
(if pkg
|
||||
(list pkg)
|
||||
null)])])
|
||||
(call-with-package-scope
|
||||
'update
|
||||
scope scope-dir installation user pkg-source #f
|
||||
scope scope-dir installation user pkg-source a-type #t name
|
||||
(lambda ()
|
||||
install-copy-checks ...
|
||||
(define setup-collects
|
||||
|
|
@ -293,7 +322,7 @@
|
|||
#:args pkg
|
||||
(call-with-package-scope
|
||||
'remove
|
||||
scope scope-dir installation user pkg 'name
|
||||
scope scope-dir installation user pkg 'name #f #f
|
||||
(lambda ()
|
||||
(define setup-collects
|
||||
(with-pkg-lock
|
||||
|
|
@ -370,7 +399,7 @@
|
|||
#:args (from-version)
|
||||
(call-with-package-scope
|
||||
'migrate
|
||||
scope scope-dir installation user #f #f
|
||||
scope scope-dir installation user #f #f #f #f
|
||||
(lambda ()
|
||||
(define setup-collects
|
||||
(with-pkg-lock
|
||||
|
|
@ -438,7 +467,7 @@
|
|||
(lambda (accum . key+vals)
|
||||
(call-with-package-scope
|
||||
'config
|
||||
scope scope-dir installation user #f #f
|
||||
scope scope-dir installation user #f #f #f #f
|
||||
(lambda ()
|
||||
(if set
|
||||
(with-pkg-lock
|
||||
|
|
|
|||
|
|
@ -195,9 +195,12 @@
|
|||
|
||||
(when (and (pair? orig-pkg)
|
||||
(or (eq? (car orig-pkg) 'link)
|
||||
(eq? (car orig-pkg) 'static-link)))
|
||||
(eq? (car orig-pkg) 'static-link)
|
||||
(eq? (car orig-pkg) 'clone)))
|
||||
(disallow-package-path-overlaps pkg-name
|
||||
pkg-dir
|
||||
(if (eq? (car orig-pkg) 'clone)
|
||||
git-dir
|
||||
pkg-dir)
|
||||
path-pkg-cache
|
||||
simultaneous-installs))
|
||||
(cond
|
||||
|
|
@ -906,10 +909,10 @@
|
|||
;; No checksum available => always update
|
||||
(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)))))
|
||||
(not (same-orig-pkg? (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)
|
||||
|
|
@ -1119,6 +1122,13 @@
|
|||
(pkg-error (~a "package is already a linked repository clone\n"
|
||||
" package: ~a")
|
||||
name)]
|
||||
[`(catalog ,lookup-name ,url-str)
|
||||
;; Found a catalog-based installation that can be converted
|
||||
;; to a clone:
|
||||
(pkg-desc url-str 'clone name
|
||||
(pkg-desc-checksum pkg-name)
|
||||
(pkg-desc-auto? pkg-name)
|
||||
(pkg-desc-extra-path pkg-name))]
|
||||
[`(url ,url-str)
|
||||
(define-values (current-name current-type)
|
||||
(package-source->name+type url-str #f))
|
||||
|
|
|
|||
|
|
@ -38,7 +38,7 @@
|
|||
#:unless (pkg-info-auto? info))
|
||||
(define-values (source type dir)
|
||||
(match (pkg-info-orig-pkg info)
|
||||
[(list 'catalog name) (values name 'name #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)]
|
||||
|
|
|
|||
|
|
@ -8,11 +8,14 @@
|
|||
;; An "orig-pkg" is the way that that a pacage source is recorded
|
||||
;; in the installed-package database.
|
||||
|
||||
(provide desc->orig-pkg)
|
||||
(provide desc->orig-pkg
|
||||
same-orig-pkg?)
|
||||
|
||||
(define (desc->orig-pkg type src extra-path)
|
||||
(define (desc->orig-pkg type src extra-path #:repo-url [repo-url #f])
|
||||
(case type
|
||||
[(name) `(catalog ,src)]
|
||||
[(name) (if repo-url
|
||||
`(catalog ,src ,repo-url)
|
||||
`(catalog ,src))]
|
||||
[(link static-link) `(,type
|
||||
,(path->string
|
||||
(find-relative-path (pkg-installed-dir)
|
||||
|
|
@ -31,3 +34,10 @@
|
|||
,src)]
|
||||
[(file dir) `(,type ,(simple-form-path* src))]
|
||||
[else `(url ,src)]))
|
||||
|
||||
;; Ignore URL that is potentially recorded for a 'catalog kind:
|
||||
(define (same-orig-pkg? a b)
|
||||
(if (and (eq? 'catalog (car a))
|
||||
(eq? 'catalog (car b)))
|
||||
(equal? (cadr a) (cadr b))
|
||||
(equal? a b)))
|
||||
|
|
|
|||
|
|
@ -39,7 +39,7 @@
|
|||
|
||||
(define (remote-package-checksum pkg download-printf pkg-name #:type [type #f])
|
||||
(match pkg
|
||||
[`(catalog ,pkg-name)
|
||||
[`(catalog ,pkg-name . ,_)
|
||||
(hash-ref (package-catalog-lookup pkg-name #f download-printf) 'checksum)]
|
||||
[`(url ,pkg-url-str)
|
||||
(package-url->checksum pkg-url-str
|
||||
|
|
@ -104,11 +104,20 @@
|
|||
#: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 pkg-no-query
|
||||
(url->string
|
||||
(if (equal? "github" (url-scheme pkg-url))
|
||||
;; Convert "github://" to a real URL:
|
||||
(url "https" #f host port #t
|
||||
(map (lambda (s) (path/param s null)) (string-split repo "/"))
|
||||
null
|
||||
#f)
|
||||
;; Drop any query or fragment in the URL:
|
||||
(struct-copy url pkg-url
|
||||
[query null]
|
||||
[fragment #f]))))
|
||||
(define clone-dir (or given-at-dir
|
||||
(current-directory)))
|
||||
|
||||
|
|
@ -579,11 +588,15 @@
|
|||
(when check-sums?
|
||||
(check-checksum given-checksum checksum "unexpected" pkg #f)
|
||||
(check-checksum checksum (install-info-checksum info) "incorrect" pkg #f))
|
||||
(define repo-url (let-values ([(name type) (package-source->name+type source #f)])
|
||||
(and (or (eq? type 'git)
|
||||
(eq? type 'github))
|
||||
source)))
|
||||
(update-install-info-orig-pkg
|
||||
(update-install-info-checksum
|
||||
info
|
||||
checksum)
|
||||
(desc->orig-pkg 'name pkg #f))]
|
||||
(desc->orig-pkg 'name pkg #f #:repo-url repo-url))]
|
||||
[else
|
||||
(pkg-error "cannot infer package source type\n source: ~a" pkg)]))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user