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

raco pkg: use Git protocol for GitHub sources

Browse Source 
Using the GitHub API for GitHub sources can run afoul of API
limits. Since we now support the Git protocol generall, use
that for GitHub sources, too.

Set the `PLT_USE_GITHUB_API` environment variable to use the
GitHub API, instead.
This commit is contained in:
Matthew Flatt 2015-09-09 12:45:54 -06:00
parent e318257a7f
commit 9bf68db7f7
6 changed files with 52 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -285,8 +285,8 @@ is a GitHub package source.
@margin-note{A Github repository source that starts with
@litchar{git://} obtains the same content that would be accessed if
@litchar{github.com} were not treated specially. The special treatment
is preserved for historical reasons and because GitHub provides an
interface that is always efficient.}
is preserved for historical reasons, especially in combination
with @envvar{PLT_USE_GITHUB_API}.}
For backward compatibility, an older format is also supported:
@ -304,7 +304,15 @@ with @litchar{git://github.com/} or @litchar{github://}; a package
source that is otherwise specified as a GitHub reference is
automatically prefixed with @litchar{git://github.com/}. The inferred
package name is the last element of @nonterm{path} if it is non-empty,
otherwise the inferred name is @nonterm{repo}.}
otherwise the inferred name is @nonterm{repo}.
If the @indexed-envvar{PLT_USE_GITHUB_API} environment variable is
set, GitHub packages are obtained using the GitHub API protocol
instead of using the Git protocol.
@history[#:changed "6.2.900.16" @elem{Changed handling of
GitHub sources to use the Git
protocol by default.}]}
@; ----------------------------------------
@item{a @tech{package name} --- A @tech{package catalog} is

6
racket/collects/pkg/private/clone-path.rkt
View File

@ -372,9 +372,9 @@
[else #f])]
[(git github clone)
(define pkg-url (string->url (pkg-desc-source d)))
(define-values (host port repo branch path)
(split-git-or-hub-url pkg-url))
(real-git-url pkg-url host port repo)]
(define-values (transport host port repo branch path)
(split-git-or-hub-url #:type type pkg-url))
(real-git-url pkg-url #:type type host port repo)]
[else #f])))
(define (pkg-info->clone-desc name info

11
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 port repo dest-dir checksum
(define (download-repo! url transport 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,11 +107,16 @@
(define unpacked? #f)
(define (download!)
(when download-printf
(download-printf "Downloading repository ~a\n" (url->string url)))
(git-checkout host #:port port repo
#:dest-dir dest-dir
#:ref checksum
#:status-printf (or download-printf void)
#:transport (string->symbol (url-scheme url)))
#:status-printf (lambda (fmt . args)
(define (strip-ending-newline s)
(regexp-replace #rx"\n$" s ""))
(log-pkg-debug (strip-ending-newline (apply format fmt args))))
#:transport transport)
(set! unpacked? #t)
;; package directory as ".tgz" so it can be cached:
(parameterize ([current-directory dest-dir])

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

@ -22,7 +22,7 @@
(simple-form-path src)
#:more-than-root? #t)))]
[(clone)
(define-values (host port repo branch path)
(define-values (transport host port repo branch path)
(split-git-or-hub-url (string->url src)))
`(clone ,(path->string
(find-relative-path (pkg-installed-dir)

22
racket/collects/pkg/private/repo-path.rkt
View File

@ -12,7 +12,10 @@
split-git-url
split-git-or-hub-url
enclosing-path-for-repo
real-git-url)
real-git-url
use-git-for-github?)
(define use-git-for-github? (not (getenv "PLT_USE_GITHUB_API")))
(define (split-github-url pkg-url)
(if (equal? (url-scheme pkg-url) "github")
@ -32,7 +35,8 @@
;; returns: (values host repo branch path)
(define (split-git-url pkg-url)
(values (url-host pkg-url)
(values (string->symbol (url-scheme pkg-url))
(url-host pkg-url)
(url-port pkg-url)
(string-join (map (compose ~a path/param-path)
(url-path/no-slash pkg-url))
@ -40,15 +44,16 @@
(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))
(define (split-git-or-hub-url pkg-url #:type [type #f])
(if (or (equal? "github" (url-scheme pkg-url))
(eq? type 'github))
(match (split-github-url pkg-url)
[(list* user repo branch path)
(values "github.com" #f (~a "/" user "/" repo) branch path)])
(values 'git "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)
(define-values (transport host port repo branch path)
(split-git-or-hub-url (string->url url-str)))
(let loop ([path path]
[in-repo-dir (simplify-path in-repo-dir)])
@ -60,9 +65,10 @@
(error "path for git repo link is too short for path in package source")
(loop (cdr path) base))])))
(define (real-git-url pkg-url host port repo)
(define (real-git-url pkg-url host port repo #:type [type #f])
(url->string
(if (equal? "github" (url-scheme pkg-url))
(if (or (equal? "github" (url-scheme pkg-url))
(eq? type 'github))
;; Convert "github://" to a real URL:
(url "https" #f host port #t
(map (lambda (s) (path/param s null)) (string-split repo "/"))

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

@ -40,6 +40,12 @@
(struct install-info (name orig-pkg directory git-directory clean? checksum module-paths additional-installs))
(define (communication-type type)
(if (and (eq? type 'github)
use-git-for-github?)
'git
type))
(define (remote-package-checksum pkg download-printf pkg-name
#:type [type #f]
#:catalog-lookup-cache [catalog-lookup-cache #f]
@ -123,7 +129,7 @@
#:force-strip? force-strip?)]
[(eq? type 'clone)
(define pkg-url (string->url pkg))
(define-values (host port repo branch path)
(define-values (transport host port repo branch path)
(split-git-or-hub-url pkg-url))
(define pkg-no-query (real-git-url pkg-url host port repo))
(define clone-dir (or given-at-dir
@ -245,14 +251,15 @@
(check-checksum given-checksum found-checksum "unexpected" pkg #f))
(define checksum (or found-checksum given-checksum))
(define downloaded-info
(match type
(match (communication-type type)
['git
(when (equal? checksum "")
(pkg-error
(~a "cannot use empty checksum for Git repostory package source\n"
" source: ~a")
pkg))
(define-values (host port repo branch path) (split-git-url pkg-url))
(define-values (transport host port repo branch path)
(split-git-or-hub-url pkg-url #:type type))
(define tmp-dir
(make-temporary-file
(string-append
@ -264,7 +271,7 @@
(dynamic-wind
void
(λ ()
(download-repo! pkg-url host port repo tmp-dir checksum
(download-repo! pkg-url transport host port repo tmp-dir checksum
#:use-cache? use-cache?
#:download-printf download-printf)
(lift-git-directory-content tmp-dir path)
@ -696,10 +703,10 @@
(or given-type
(let-values ([(name type) (package-source->name+type pkg-url-str given-type)])
type))))
(case type
(case (communication-type type)
[(git)
(define-values (host port repo branch path)
(split-git-url pkg-url))
(define-values (transport host port repo branch path)
(split-git-or-hub-url pkg-url #:type type))
(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:
@ -715,7 +722,7 @@
" the given URL might not refer to a Git repository\n"
" given URL: ~a")
pkg-url-str))
#:transport (string->symbol (url-scheme pkg-url)))]
#:transport transport)]
[(github)
(match-define (list* user repo branch path)
(split-github-url pkg-url))