From 6d63e4443ffad0b73c9632033dbf2adcb0871658 Mon Sep 17 00:00:00 2001 From: Alexis King Date: Thu, 29 Sep 2016 12:57:19 -0700 Subject: [PATCH] Make raco pkg try git-checkout-credentials when cloning a repository --- .../pkg/private/checkout-credentials.rkt | 24 +++++++++++++ racket/collects/pkg/private/config.rkt | 4 +++ racket/collects/pkg/private/download.rkt | 26 ++++++++------ racket/collects/pkg/private/params.rkt | 3 ++ racket/collects/pkg/private/stage.rkt | 35 ++++++++++--------- 5 files changed, 65 insertions(+), 27 deletions(-) create mode 100644 racket/collects/pkg/private/checkout-credentials.rkt diff --git a/racket/collects/pkg/private/checkout-credentials.rkt b/racket/collects/pkg/private/checkout-credentials.rkt new file mode 100644 index 0000000000..08b7c775cd --- /dev/null +++ b/racket/collects/pkg/private/checkout-credentials.rkt @@ -0,0 +1,24 @@ +#lang racket/base + +(require net/git-checkout + racket/list + "config.rkt") + +(provide call-with-git-checkout-credentials) + +(define (call-with-git-checkout-credentials thunk) + (let loop ([credentials-list (cons #f (get-git-checkout-credentials))]) + (define credentials (first credentials-list)) + (with-handlers ([exn:fail:git? (λ (exn) + (if (empty? (rest credentials-list)) + (raise exn) + (loop (rest credentials-list))))]) + (define c (make-custodian)) + (parameterize ([current-custodian c] + [current-git-username (and credentials (hash-ref credentials 'username))] + [current-git-password (and credentials (hash-ref credentials 'password))]) + (dynamic-wind + void + thunk + (lambda () + (custodian-shutdown-all c))))))) diff --git a/racket/collects/pkg/private/config.rkt b/racket/collects/pkg/private/config.rkt index 1296ad6a18..ff379fd37e 100644 --- a/racket/collects/pkg/private/config.rkt +++ b/racket/collects/pkg/private/config.rkt @@ -38,6 +38,10 @@ (or (current-pkg-network-retries) (read-pkg-cfg/def 'network-retries))) +(define (get-git-checkout-credentials) + (or (current-pkg-git-checkout-credentials) + (read-pkg-cfg/def 'git-checkout-credentials))) + (define (read-pkg-cfg/def k) ;; Lock is held for the current scope, but if ;; the key is not found in the current scope, diff --git a/racket/collects/pkg/private/download.rkt b/racket/collects/pkg/private/download.rkt index f7b4e88a4d..59fde4081f 100644 --- a/racket/collects/pkg/private/download.rkt +++ b/racket/collects/pkg/private/download.rkt @@ -11,6 +11,7 @@ "path.rkt" "print.rkt" "config.rkt" + "checkout-credentials.rkt" "network.rkt") (provide download-file! @@ -101,18 +102,21 @@ (define (download!) (when download-printf (download-printf "Downloading repository ~a\n" (url->string url))) - (call-with-network-retries + (call-with-git-checkout-credentials (lambda () - (git-checkout host #:port port repo - #:dest-dir dest-dir - #:ref checksum - #: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 - #:strict-links? #t - #:depth 1))) + (call-with-network-retries + (lambda () + (git-checkout host #:port port repo + #:dest-dir dest-dir + #:ref checksum + #: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 + #:strict-links? #t + #:depth 1))))) (set! unpacked? #t) ;; package directory as ".tgz" so it can be cached: (parameterize ([current-directory dest-dir]) diff --git a/racket/collects/pkg/private/params.rkt b/racket/collects/pkg/private/params.rkt index e99d25bef2..3690840243 100644 --- a/racket/collects/pkg/private/params.rkt +++ b/racket/collects/pkg/private/params.rkt @@ -34,3 +34,6 @@ (define current-pkg-network-retries (make-parameter #f)) + +(define current-pkg-git-checkout-credentials + (make-parameter #f)) diff --git a/racket/collects/pkg/private/stage.rkt b/racket/collects/pkg/private/stage.rkt index 070c39a504..4867e57e35 100644 --- a/racket/collects/pkg/private/stage.rkt +++ b/racket/collects/pkg/private/stage.rkt @@ -31,6 +31,7 @@ "orig-pkg.rkt" "git.rkt" "prefetch.rkt" + "checkout-credentials.rkt" "network.rkt") (provide (struct-out install-info) @@ -735,23 +736,25 @@ (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) - (call-with-network-retries + (call-with-git-checkout-credentials (lambda () - ;; Supplying `#:dest-dir #f` means that we just resolve `branch` - ;; to an ID: - (git-checkout host #:port port repo - #:dest-dir #f - #:ref branch - #: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)))) - #:initial-error (lambda () - (pkg-error (~a "Git checkout initial protocol failed;\n" - " the given URL might not refer to a Git repository\n" - " given URL: ~a") - pkg-url-str)) - #:transport transport)))] + (call-with-network-retries + (lambda () + ;; Supplying `#:dest-dir #f` means that we just resolve `branch` + ;; to an ID: + (git-checkout host #:port port repo + #:dest-dir #f + #:ref branch + #: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)))) + #:initial-error (lambda () + (pkg-error (~a "Git checkout initial protocol failed;\n" + " the given URL might not refer to a Git repository\n" + " given URL: ~a") + pkg-url-str)) + #:transport transport)))))] [(github) (match-define (list* user repo branch path) (split-github-url pkg-url))