From 9bf68db7f72755bf90a820305aa69abfe059e3ee Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 9 Sep 2015 12:45:54 -0600 Subject: [PATCH] raco pkg: use Git protocol for GitHub sources 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. --- pkgs/racket-doc/pkg/scribblings/pkg.scrbl | 14 ++++++++++--- racket/collects/pkg/private/clone-path.rkt | 6 +++--- racket/collects/pkg/private/download.rkt | 11 ++++++++--- racket/collects/pkg/private/orig-pkg.rkt | 2 +- racket/collects/pkg/private/repo-path.rkt | 22 +++++++++++++-------- racket/collects/pkg/private/stage.rkt | 23 ++++++++++++++-------- 6 files changed, 52 insertions(+), 26 deletions(-) diff --git a/pkgs/racket-doc/pkg/scribblings/pkg.scrbl b/pkgs/racket-doc/pkg/scribblings/pkg.scrbl index 354bf9fc97..c580f061d3 100644 --- a/pkgs/racket-doc/pkg/scribblings/pkg.scrbl +++ b/pkgs/racket-doc/pkg/scribblings/pkg.scrbl @@ -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 diff --git a/racket/collects/pkg/private/clone-path.rkt b/racket/collects/pkg/private/clone-path.rkt index f7d79f7ee1..c6635fa9a6 100644 --- a/racket/collects/pkg/private/clone-path.rkt +++ b/racket/collects/pkg/private/clone-path.rkt @@ -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 diff --git a/racket/collects/pkg/private/download.rkt b/racket/collects/pkg/private/download.rkt index 0fd31d07c1..93325312c2 100644 --- a/racket/collects/pkg/private/download.rkt +++ b/racket/collects/pkg/private/download.rkt @@ -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]) diff --git a/racket/collects/pkg/private/orig-pkg.rkt b/racket/collects/pkg/private/orig-pkg.rkt index 1c62ecc29c..4bd4d93906 100644 --- a/racket/collects/pkg/private/orig-pkg.rkt +++ b/racket/collects/pkg/private/orig-pkg.rkt @@ -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) diff --git a/racket/collects/pkg/private/repo-path.rkt b/racket/collects/pkg/private/repo-path.rkt index acc9d91e46..a6589192c1 100644 --- a/racket/collects/pkg/private/repo-path.rkt +++ b/racket/collects/pkg/private/repo-path.rkt @@ -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 "/")) diff --git a/racket/collects/pkg/private/stage.rkt b/racket/collects/pkg/private/stage.rkt index ca3ab5f24e..f62a5a578a 100644 --- a/racket/collects/pkg/private/stage.rkt +++ b/racket/collects/pkg/private/stage.rkt @@ -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))