Make raco pkg try git-checkout-credentials when cloning a repository

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)))))))

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,

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,6 +102,8 @@
   (define (download!)
     (when download-printf
       (download-printf "Downloading repository ~a\n" (url->string url)))
+    (call-with-git-checkout-credentials
+     (lambda ()
        (call-with-network-retries
         (lambda ()
           (git-checkout host #:port port repo
@@ -109,10 +112,11 @@
                         #: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))))
+                                          (log-pkg-debug (strip-ending-newline
+                                                          (apply format fmt args))))
                         #:transport transport
                         #:strict-links? #t
-                     #:depth 1)))
+                        #:depth 1)))))
     (set! unpacked? #t)
     ;; package directory as ".tgz" so it can be cached:
     (parameterize ([current-directory dest-dir])

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))

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,6 +736,8 @@
      (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-git-checkout-credentials
+      (lambda ()
         (call-with-network-retries
          (lambda ()
            ;; Supplying `#:dest-dir #f` means that we just resolve `branch`
@@ -751,7 +754,7 @@
                                                           " the given URL might not refer to a Git repository\n"
                                                           "  given URL: ~a")
                                                       pkg-url-str))
-                      #:transport transport)))]
+                         #:transport transport)))))]
     [(github)
      (match-define (list* user repo branch path)
                    (split-github-url pkg-url))