From d409fb5e2ec8b29932cde718b8383ffa0ce071e3 Mon Sep 17 00:00:00 2001
From: Alexis King <jaking@cj.com>
Date: Mon, 20 Jun 2016 11:37:18 -0700
Subject: [PATCH 1/6] Add #:username and #:password arguments to
 net/git-checkout

This can be used to provide authentication for accessing repositories
over HTTP(S), such as private repositories on GitHub.
---
 .../net/scribblings/git-checkout.scrbl        | 20 ++++++++-
 racket/collects/net/git-checkout.rkt          | 41 +++++++++++++------
 2 files changed, 47 insertions(+), 14 deletions(-)

diff --git a/pkgs/net-doc/net/scribblings/git-checkout.scrbl b/pkgs/net-doc/net/scribblings/git-checkout.scrbl
index 46cecaff20..2d22a6fe9c 100644
--- a/pkgs/net-doc/net/scribblings/git-checkout.scrbl
+++ b/pkgs/net-doc/net/scribblings/git-checkout.scrbl
@@ -36,7 +36,9 @@ for information on command-line arguments and flags.
                                                                      [(git) 9418]
                                                                      [(http) 80]
                                                                      [(https) 443])]
-                       [#:strict-links? strict-links? any/c #f])
+                       [#:strict-links? strict-links? any/c #f]
+                       [#:username username (or/c string? #f) (current-git-username)]
+                       [#:password password (or/c string? #f) (current-git-password)])
          string?]{
 
 Contacts the server at @racket[hostname] and @racket[port]
@@ -96,6 +98,20 @@ If @racket[strict-links?] is true, then the checkout fails with an
 error if it would produce a symbolic link that refers to an absolute path
 or to a relative path that contains up-directory elements.
 
+If both @racket[username] and @racket[password] are non-@racket[#f]
+@emph{and} @racket[transport] is @racket['http] or @racket['https], then
+the provided credentials are passed to the remote server using HTTP Basic
+Authentication.
+
 @history[#:added "6.1.1.1"
          #:changed "6.3" @elem{Added the @racket[initial-error] argument.}
-         #:changed "6.2.900.17" @elem{Added the @racket[strict-links?] argument.}]}
+         #:changed "6.2.900.17" @elem{Added the @racket[strict-links?] argument.}
+         #:changed "6.6.0.5" @elem{Added the @racket[username] and @racket[password] arguments.}]}
+
+@deftogether[(@defparam[current-git-username username (or/c string? #f)]
+              @defparam[current-git-password password (or/c string? #f)])]{
+Parameters used by @racket[git-checkout] as the default values of the
+@racket[_username] and @racket[_password] arguments to control
+authentication with the remote server.
+
+@history[#:added "6.6.0.5"]}
diff --git a/racket/collects/net/git-checkout.rkt b/racket/collects/net/git-checkout.rkt
index 00dd2b1b50..684fd13272 100644
--- a/racket/collects/net/git-checkout.rkt
+++ b/racket/collects/net/git-checkout.rkt
@@ -7,6 +7,7 @@
          file/gunzip
          file/private/check-path
          openssl/sha1
+         net/base64
          net/url
          net/head
          net/http-client
@@ -16,10 +17,15 @@
 ;;  http://stefan.saasen.me/articles/git-clone-in-haskell-from-the-bottom-up/
 ;; provided many helpful hints for this implementation.
 
-(provide git-checkout)
+(provide git-checkout
+         current-git-username
+         current-git-password)
 
 (define-logger git-checkout)
 
+(define current-git-username (make-parameter #f))
+(define current-git-password (make-parameter #f))
+
 ;; Like `git clone`, but producing just the checkout
 (define (git-checkout host
                       repo
@@ -35,7 +41,9 @@
                       #:clean-tmp-dir? [clean-tmp-dir? (not given-tmp-dir)]
                       #:verify-server? [verify? #t]
                       #:port [given-port #f]
-                      #:strict-links? [strict-links? #f])
+                      #:strict-links? [strict-links? #f]
+                      #:username [username (current-git-username)]
+                      #:password [password (current-git-password)])
   (let retry-loop ([given-depth given-depth])
     (define tmp-dir (or given-tmp-dir
                         (make-temporary-file "git~a" 'directory)))
@@ -51,7 +59,7 @@
     
     (status "Contacting ~a" host)
     (define-values (i o dumb-protocol?)
-      (initial-connect transport host verify? port repo status))
+      (initial-connect transport host verify? port repo status username password))
     ((let/ec esc
        (dynamic-wind
         void
@@ -106,7 +114,7 @@
 
             ;; Tell the server that we're ready for the objects
             (write-pkt o "done\n")
-            (set!-values (i o) (done-step transport host verify? port repo i o))
+            (set!-values (i o) (done-step transport host verify? port repo username password i o))
 
             (when depth
               ;; If we wrote `deepen`, then the server replies with `shallow`s.
@@ -189,18 +197,23 @@
 ;; ----------------------------------------
 ;; Transports: git, http, and https
 
-(define http-request-headers
+(define (http-request-headers username password)
   ;; bitbucket.org seems to require a "git" value for "User-Agent",
   ;; otherwise it returns a "broken link" web page
-  '("User-Agent: git/1.9"))
+  (define base-headers '("User-Agent: git/1.9"))
+  ;; include an Authorization header if credentials are provided
+  (if (and username password)
+      (cons (~a "Authorization: Basic " (base64-encode (string->bytes/utf-8 (~a username ":" password)) #""))
+            base-headers)
+      base-headers))
 
-;; initial-connect: transport-sym string bool natural string status-proc
+;; initial-connect: transport-sym string bool natural string status-proc string string
 ;;                  -> (values input-port output-port boolean)
 ;;  Contacts the server and returns an output port for writing
 ;;  the request (ignored if not needed for the the transport)
 ;;  and an input port from reading the available references. The
 ;;  boolean result indicates whether the protocol is "dumb".
-(define (initial-connect transport host verify? port repo status)
+(define (initial-connect transport host verify? port repo status username password)
   (case transport
     [(git)
      (define-values (i o) (tcp-or-tunnel-connect "git" host port))
@@ -212,7 +225,7 @@
      (define-values (i headers)
        (parameterize ([current-https-protocol (ssl-context verify?)])
          (get-pure-port/headers (string->url url-str)
-                                http-request-headers
+                                (http-request-headers username password)
                                 #:redirections 5)))
      (define ok? #f)
      (dynamic-wind
@@ -256,12 +269,12 @@
      (close-input-port i)
      (values (open-input-bytes #"") (open-output-bytes))]))
 
-;; done-step: transport-sym string bool natural string input-port output-port
+;; done-step: transport-sym string bool natural string string string input-port output-port
 ;;            -> (values input-port output-port)
 ;;  Replaces the connection, if appropriate to the transport, after
 ;;  writing the wanted references and before reading the server's
 ;;  response.
-(define (done-step transport host verify? port repo i o)
+(define (done-step transport host verify? port repo username password i o)
   (case transport
     [(git) (values i o)]
     [(http https)
@@ -274,7 +287,7 @@
                "/git-upload-pack"))
           s
           (append
-           http-request-headers
+           (http-request-headers username password)
            (list "Content-Type: application/x-git-upload-pack-request")))))
      (values i (open-output-nowhere))]))
 
@@ -1109,6 +1122,10 @@
       (set! ref branch/tag/commit)]
      [("--tmp") dir "Write temporary files to <dir>"
       (set! tmp-dir dir)]
+     [("-u" "--username") username "Username used to authenticate over HTTP(S)"
+      (current-git-username username)]
+     [("-p" "--password") password "Password used to authenticate over HTTP(S)"
+      (current-git-password password)]
      [("--quiet") "Suppress status printouts"
       (set! status-printf void)]
      #:args (host repo dest)

From 8de889df5ea3e0859cd01f1fcd39cdca5a7f949c Mon Sep 17 00:00:00 2001
From: Alexis King <lexi.lambda@gmail.com>
Date: Thu, 29 Sep 2016 10:22:38 -0700
Subject: [PATCH 2/6] Add support for the 'git-checkout-credentials raco config
 option

---
 pkgs/racket-doc/pkg/scribblings/pkg.scrbl |  6 +++-
 racket/collects/pkg/private/config.rkt    | 34 +++++++++++++++++++++++
 2 files changed, 39 insertions(+), 1 deletion(-)

diff --git a/pkgs/racket-doc/pkg/scribblings/pkg.scrbl b/pkgs/racket-doc/pkg/scribblings/pkg.scrbl
index fc0b6d328d..f09290e670 100644
--- a/pkgs/racket-doc/pkg/scribblings/pkg.scrbl
+++ b/pkgs/racket-doc/pkg/scribblings/pkg.scrbl
@@ -944,6 +944,9 @@ for @nonterm{key}.
         documentation; an empty string, which is the default, disables
         the URL so that the local filesystem is used. This key can be
         set only in @exec{installation} scope.}
+  @item{@exec{git-checkout-credentials} --- A list of git credentials in the form
+        @nonterm{username}@litchar{:}@nonterm{password} that are tried when downloading
+        packages with git sources using the HTTP or HTTPS protocols.}
   @item{@exec{trash-max-packages} --- A limit on the number of package implementations
         that are kept in a trash folder when the package is removed or updated.}
   @item{@exec{trash-max-seconds} --- A limit on the time since a package is removed or
@@ -955,7 +958,8 @@ for @nonterm{key}.
  ]
 
 @history[#:changed "6.1.1.6" @elem{Added @exec{trash-max-packages} and @exec{trash-max-seconds}.}
-         #:changed "6.3" @elem{Added @exec{network-retries}.}]}
+         #:changed "6.3" @elem{Added @exec{network-retries}.}
+         #:changed "6.6.0.5" @elem{Added @exec{git-checkout-credentials}.}]}
 
 
 @subcommand{@command/toc{catalog-show} @nonterm{option} ... @nonterm{package-name} ...
diff --git a/racket/collects/pkg/private/config.rkt b/racket/collects/pkg/private/config.rkt
index 994ce8fe1a..1296ad6a18 100644
--- a/racket/collects/pkg/private/config.rkt
+++ b/racket/collects/pkg/private/config.rkt
@@ -4,6 +4,7 @@
          racket/path
          racket/match
          racket/format
+         racket/string
          net/url
          "../path.rkt"
          "dirs.rkt"
@@ -56,6 +57,7 @@
       ['trash-max-packages 512]
       ['trash-max-seconds (* 60 60 24 2)] ; 2 days
       ['network-retries 5]
+      ['git-checkout-credentials '()]
       [_ #f]))
   (define c (read-pkg-file-hash (pkg-config-file)))
   (define v (hash-ref c k 'none))
@@ -197,6 +199,34 @@
                          "  current package scope: ~a")
                      (current-pkg-scope)))
         (update-pkg-cfg! 'doc-open-url (if (equal? val "") #f val))]
+       [(list* "git-checkout-credentials" vals)
+        (define (credentials-format-error msg val)
+          (pkg-error (~a msg "\n"
+                         "  given: ~a\n"
+                         "  expected: value in the form <username>:<password>")
+                     val))
+        (update-pkg-cfg! 'git-checkout-credentials
+                         (for/list ([val (in-list vals)])
+                           (match (string-split val ":" #:trim? #f)
+                             [(list "" _)
+                              (credentials-format-error
+                               "invalid empty username in git checkout credentials"
+                               val)]
+                             [(list _ "")
+                              (credentials-format-error
+                               "invalid empty password in git checkout credentials"
+                               val)]
+                             [(list username password)
+                              `#hasheq((username . ,username)
+                                       (password . ,password))]
+                             [(list* _ _ _)
+                              (credentials-format-error
+                               "too many elements for git checkout credentials"
+                               val)]
+                             [(list _)
+                              (credentials-format-error
+                               "not enough elements for git checkout credentials"
+                               val)])))]
        [(list* key args)
         (pkg-error "unsupported config key\n  key: ~a" key)])]
     [else
@@ -220,6 +250,9 @@
              (printf "~a~a\n" indent (read-pkg-cfg/def (string->symbol key)))]
             ["doc-open-url"
              (printf "~a~a\n" indent (or (read-pkg-cfg/def 'doc-open-url) ""))]
+            ["git-checkout-credentials"
+             (for ([creds (in-list (read-pkg-cfg/def 'git-checkout-credentials))])
+               (printf "~a~a:~a\n" indent (hash-ref creds 'username) (hash-ref creds 'password)))]
             [_
              (pkg-error "unsupported config key\n  key: ~e" key)])]
          [(list)
@@ -237,6 +270,7 @@
                               "download-cache-dir"
                               "download-cache-max-files"
                               "download-cache-max-bytes"
+                              "git-checkout-credentials"
                               "trash-max-packages"
                               "trash-max-seconds"
                               "network-retries"))])

From afa17a3df6f838d38635bbc5695e483d0080af3b Mon Sep 17 00:00:00 2001
From: Alexis King <lexi.lambda@gmail.com>
Date: Thu, 29 Sep 2016 12:56:02 -0700
Subject: [PATCH 3/6] Adjust net/git-checkout to raise exn:fail:git instead of
 exn:fail

This allows things like the package system to detect when something goes
wrong with the git transfer without catching everything else, too.
---
 .../net/scribblings/git-checkout.scrbl        |   9 +-
 racket/collects/net/git-checkout.rkt          | 117 +++++++++---------
 2 files changed, 69 insertions(+), 57 deletions(-)

diff --git a/pkgs/net-doc/net/scribblings/git-checkout.scrbl b/pkgs/net-doc/net/scribblings/git-checkout.scrbl
index 2d22a6fe9c..55ade62a3e 100644
--- a/pkgs/net-doc/net/scribblings/git-checkout.scrbl
+++ b/pkgs/net-doc/net/scribblings/git-checkout.scrbl
@@ -106,7 +106,9 @@ Authentication.
 @history[#:added "6.1.1.1"
          #:changed "6.3" @elem{Added the @racket[initial-error] argument.}
          #:changed "6.2.900.17" @elem{Added the @racket[strict-links?] argument.}
-         #:changed "6.6.0.5" @elem{Added the @racket[username] and @racket[password] arguments.}]}
+         #:changed "6.6.0.5" @elem{Added the @racket[username] and @racket[password] arguments.}
+         #:changed "6.6.0.5" @elem{Changed to raise @racket[exn:fail:git] exceptions
+                                   instead of @racket[exn:fail].}]}
 
 @deftogether[(@defparam[current-git-username username (or/c string? #f)]
               @defparam[current-git-password password (or/c string? #f)])]{
@@ -115,3 +117,8 @@ Parameters used by @racket[git-checkout] as the default values of the
 authentication with the remote server.
 
 @history[#:added "6.6.0.5"]}
+
+@defstruct[(exn:fail:git exn:fail) () #:transparent]{
+Raised by @racket[git-checkout] due to errors parsing or communicating with the git protocol.
+
+@history[#:added "6.6.0.5"]}
diff --git a/racket/collects/net/git-checkout.rkt b/racket/collects/net/git-checkout.rkt
index 684fd13272..dbc323cf2e 100644
--- a/racket/collects/net/git-checkout.rkt
+++ b/racket/collects/net/git-checkout.rkt
@@ -19,13 +19,20 @@
 
 (provide git-checkout
          current-git-username
-         current-git-password)
+         current-git-password
+         (struct-out exn:fail:git))
 
 (define-logger git-checkout)
 
 (define current-git-username (make-parameter #f))
 (define current-git-password (make-parameter #f))
 
+(struct exn:fail:git exn:fail () #:transparent)
+
+(define (raise-git-error name fmt . vals)
+  (raise (exn:fail:git (apply format (string-append "~s: " fmt) name vals)
+                       (current-continuation-marks))))
+
 ;; Like `git clone`, but producing just the checkout
 (define (git-checkout host
                       repo
@@ -74,7 +81,7 @@
                            ;; smart protocol provides packets:
                            (read-pkts i)))
           (unless (pair? pkts)
-            (error 'git-checkout "no initial pkts from the server"))
+            (raise-git-error 'git-checkout "no initial pkts from the server"))
 
           ;; Parse server's initial reply
           (define server-capabilities (parse-server-capabilities (car pkts)))
@@ -128,12 +135,12 @@
                  [(regexp-match? #rx"^shallow " r)
                   (loop)]
                  [else
-                  (error 'git-checkout "expected shallow, got ~s" r)])))
+                  (raise-git-error 'git-checkout "expected shallow, got ~s" r)])))
 
             ;; Tell the server that we're ready for the objects
             (define nak (read-pkt i))
             (unless (equal? #"NAK\n" nak)
-              (error 'git-checkout "expected NAK, got ~s" nak)))
+              (raise-git-error 'git-checkout "expected NAK, got ~s" nak)))
 
           (make-directory* tmp-dir)
           (define tmp (make-tmp-info tmp-dir #:fresh? #t))
@@ -237,16 +244,16 @@
                     "application/x-git-upload-pack-advertisement")
             ;; "smart" protocol
             (unless (regexp-match-peek #px#"^[0-9a-f]{4}#" i)
-              (error 'git-checkout (~a "error reading repository content;\n"
-                                       " response is not consistent with the Git protocol\n"
-                                       "  initial portion: ~s")
-                     (read-bytes 640 i)))
+              (raise-git-error 'git-checkout (~a "error reading repository content;\n"
+                                                 " response is not consistent with the Git protocol\n"
+                                                 "  initial portion: ~s")
+                               (read-bytes 640 i)))
             (define pkt (read-pkt i))
             (define term-pkt (read-pkt i))
             (unless (eof-object? term-pkt)
-              (error 'git-checkout (~a "expected a null packet, received something else\n"
-                                       "  packet: ~s")
-                     term-pkt))
+              (raise-git-error 'git-checkout (~a "expected a null packet, received something else\n"
+                                                 "  packet: ~s")
+                               term-pkt))
             #f]
            [else
             ;; "dumb" protocol
@@ -256,7 +263,7 @@
       (lambda ()
         (unless ok? (close-input-port i))))]
     [else
-     (error 'git-checkout "unrecognized transport\n  given: ~e" transport)]))
+     (raise-git-error 'git-checkout "unrecognized transport\n  given: ~e" transport)]))
 
 ;; want-step: transport-sym string natural string input-port output-port
 ;;            -> (values input-port output-port)
@@ -318,8 +325,7 @@
      (define m (regexp-match #px#"^([0-9a-fA-F]{40})[ \t]([^\0\n]+)[\0\n]" pkt))
      (unless m 
        (when initial-error (initial-error))
-       (error 'git-checkout "could not parse ref pkt\n  pkt: ~s"
-              pkt))
+       (raise-git-error 'git-checkout "could not parse ref pkt\n  pkt: ~s" pkt))
      (define name (caddr m))
      (define id (bytes->string/utf-8 (cadr m)))
      (cond
@@ -364,7 +370,7 @@
       (for/list ([ref (in-list refs)])
         (cadr ref))]
      [else
-      (error 'git "could not find requested reference\n  reference: ~a" ref)]))
+      (raise-git-error 'git "could not find requested reference\n  reference: ~a" ref)]))
   
   (values ref-commit want-commits))
 
@@ -402,16 +408,16 @@
    [else
     (unless (and (bytes? len-bstr)
                  (= 4 (bytes-length len-bstr)))
-      (error 'git-checkout "error getting pkt length"))
+      (raise-git-error 'git-checkout "error getting pkt length"))
     (define len (string->number (bytes->string/utf-8 len-bstr #\?) 16))
     (unless len
-      (error 'git-checkout "error getting pkt length\n  length string: ~e" len-bstr))
+      (raise-git-error 'git-checkout "error getting pkt length\n  length string: ~e" len-bstr))
     (cond
      [(= len 0) eof] ; flush pkt
      [else
       (define payload-len (- len 4))
       (unless (payload-len . >= . 0)
-        (error 'git-checkout "pkt length makes no sense\n  length: ~a" len))
+        (raise-git-error 'git-checkout "pkt length makes no sense\n  length: ~a" len))
       (read-bytes-exactly 'payload payload-len i)])]))
 
 ;; read a list of pkts until an empty packet is found
@@ -440,10 +446,10 @@
     (when (and (eof-object? pack-bstr)
                initial-eof-handler)
       (initial-eof-handler))
-    (error 'git-checkout "header error\n  bytes: ~s" pack-bstr))
+    (raise-git-error 'git-checkout "header error\n  bytes: ~s" pack-bstr))
   (define vers (read-bytes 4 i))
   (unless (equal? vers #"\0\0\0\2")
-    (error 'git-checkout "only version 2 supported"))
+    (raise-git-error 'git-checkout "only version 2 supported"))
   (define count-bstr (read-bytes-exactly 'count 4 i))
   (define count (integer-bytes->integer count-bstr #t #t))
   (define obj-stream-poses (make-hash)) ; for OBJ_OFS_DELTA references
@@ -471,7 +477,7 @@
   (define obj-stream-pos (file-position i))
   (define c (read-byte-only 'type-and-size i))
   (define type (bitwise-and (arithmetic-shift c -4) #x7))
-  (when (zero? type) (error 'git-checkout "bad packfile type"))
+  (when (zero? type) (raise-git-error 'git-checkout "bad packfile type"))
   (define init-len (bitwise-and c #xF))
   (define len
     (if (msb-set? c)
@@ -485,7 +491,7 @@
      [(ofs-delta)
       (define delta (read-offset-integer i))
       (hash-ref obj-stream-poses (- obj-stream-pos delta)
-                (lambda () (error 'git-checkout "OBJ_OFS_DELTA object not found")))]
+                (lambda () (raise-git-error 'git-checkout "OBJ_OFS_DELTA object not found")))]
      [else #f]))
   (define obj
     (save-object (lambda (o) (zlib-inflate i o)) len type-sym type-info tmp))
@@ -605,9 +611,9 @@
   (cond
    [(= 1 (length matches)) (car matches)]
    [(null? matches)
-    (error 'git-checkout "no commit found matching id: ~a" ref)]
+    (raise-git-error 'git-checkout "no commit found matching id: ~a" ref)]
    [else
-    (error 'git-checkout "found multiple commits matching id: ~a" ref)]))
+    (raise-git-error 'git-checkout "found multiple commits matching id: ~a" ref)]))
 
 (define (id-ref->regexp ref)
   (regexp (~a "^" (regexp-quote (string-downcase ref)))))
@@ -637,17 +643,17 @@
         (lambda (i)
           (define m (regexp-try-match #px"^object ([0-9a-fA-F]{40})" i))
           (unless m
-            (error 'git-checkout "cannot extract commit from tag file for ~s"
-                   (bytes->hex-string obj-id)))
+            (raise-git-error 'git-checkout "cannot extract commit from tag file for ~s"
+                             (bytes->hex-string obj-id)))
           (cadr m))))
      (define commit-id (hex-string->bytes (bytes->string/utf-8 commit-id-bstr)))
      (extract-commit-tree commit-id obj-ids tmp dest-dir strict-links?)]
     [(tree)
      (extract-tree obj-id obj-ids tmp dest-dir strict-links?)]
     [else
-     (error 'git-checkout "cannot extract tree from ~a: ~s"
-            (object-type obj)
-            (bytes->hex-string obj-id))]))
+     (raise-git-error 'git-checkout "cannot extract tree from ~a: ~s"
+                      (object-type obj)
+                      (bytes->hex-string obj-id))]))
 
 ;; extract-commit-info: input-port bytes -> string (listof string)
 ;;  Returns the commit's tree and parent ids.
@@ -655,11 +661,11 @@
 (define (extract-commit-info i obj-id)
   (define m (regexp-try-match #px"^tree ([0-9a-fA-F]{40})" i))
   (unless m
-    (error 'git-checkout
-           (~a "cannot extract tree from commit file for ~s\n"
-               "  content starts: ~s")
-           (bytes->hex-string obj-id)
-           (peek-bytes 64 0 i)))
+    (raise-git-error 'git-checkout
+                     (~a "cannot extract tree from commit file for ~s\n"
+                         "  content starts: ~s")
+                     (bytes->hex-string obj-id)
+                     (peek-bytes 64 0 i)))
   (values
    ;; tree id string:
    (bytes->string/utf-8 (cadr m))
@@ -706,7 +712,7 @@
            ;; submodule; just make a directory placeholder
            (make-directory* (build-path dest-dir fn))]
           [else
-           (error 'extract-tree "unknown mode: ~s" mode)])
+           (raise-git-error 'extract-tree "unknown mode: ~s" mode)])
          (loop))))))
 
 ;; extract-tree-entry: input-port -> bytes-or-#f bytes-or-#f path-or-#f
@@ -771,7 +777,7 @@
   (for/list ([l (in-lines i)]
              #:unless (equal? l ""))
     (define m (regexp-match #rx"^P (.*)" l))
-    (unless m (error 'git-checkout "error parsing packfile list line\n  line: ~e" l))
+    (unless m (raise-git-error 'git-checkout "error parsing packfile list line\n  line: ~e" l))
     (cadr m)))
 
 ;; read-dumb-packfile : string (hashof string object) tmp conn strung status
@@ -831,7 +837,7 @@
           ;; Parse the object description:
           (define header-m (regexp-try-match #rx#"^[^\0]*\0" i))
           (unless header-m
-            (error 'git-checkout "bad initial line for object content"))
+            (raise-git-error 'git-checkout "bad initial line for object content"))
           (define header (car header-m))
           (define header-len (bytes-length header))
           (define type-sym (string->symbol
@@ -840,7 +846,7 @@
                             (bytes->string/utf-8 (cadr (or (regexp-match #rx"[^ ]* ([0-9]+)" header)
                                                            '(#"" #""))))))        
           (unless (memq type-sym valid-types)
-            (error 'git-checkout "bad type: ~e" type-sym))
+            (raise-git-error 'git-checkout "bad type: ~e" type-sym))
           
           (define obj
             (save-object (lambda (o) (copy-port i o))
@@ -895,9 +901,9 @@
   (define status (let ([m (regexp-match #rx"^[^ ]* ([0-9]+)" status-line)])
                    (and m (string->number (bytes->string/utf-8 (cadr m))))))
   (unless (memv status '(200))
-    (error 'git-checkout "~a\n  server respone: ~a"
-           msg
-           status-line)))
+    (raise-git-error 'git-checkout "~a\n  server respone: ~a"
+                     msg
+                     status-line)))
 
 ;; ----------------------------------------
 ;; Temporary directory & database
@@ -927,9 +933,9 @@
 (define (call-with-output-object tmp filename len proc)
   (define (check-len got-len)
     (unless (= len got-len)
-      (error 'git-checkout "size mismatch\n  expected: ~a\n  received: ~a"
-             len
-             got-len)))
+      (raise-git-error 'git-checkout "size mismatch\n  expected: ~a\n  received: ~a"
+                       len
+                       got-len)))
   (cond
    [(len . < . 256)
     (define location (tmp-info-pos tmp))
@@ -994,21 +1000,20 @@
   (define bstr (read-bytes len i))
   (unless (and (bytes? bstr)
                (= (bytes-length bstr) len))
-    (error 'git-checkout (~a "error getting bytes for ~a\n"
-                             "  expected length: ~a\n"
-                             "  got length: ~a")
-           what
-           len
-           (if (eof-object? bstr)
-               eof
-               (bytes-length bstr))))
+    (raise-git-error 'git-checkout (~a "error getting bytes for ~a\n"
+                                       "  expected length: ~a\n"
+                                       "  got length: ~a")
+                     what
+                     len
+                     (if (eof-object? bstr)
+                         eof
+                         (bytes-length bstr))))
   bstr)
 
 (define (read-byte-only what i)
   (define c (read-byte i))
   (unless (byte? c)
-    (error 'git-checkout "expected to get a byte for ~a, got enf-of-file"
-           what))
+    (raise-git-error 'git-checkout "expected to get a byte for ~a, got enf-of-file" what))
   c)
 
 ;; copy-port-n : input-port output-port natural -> void
@@ -1018,7 +1023,7 @@
     (define bstr (read-bytes n i))
     (unless (and (bytes? bstr)
                  (= (bytes-length bstr) n))
-      (error 'git-checkout "not enough bytes during copy"))
+      (raise-git-error 'git-checkout "not enough bytes during copy"))
     (write-bytes bstr o)]
    [else
     (copy-port-n i o 4096)
@@ -1081,7 +1086,7 @@
   (define cmf (read-byte-only 'zlib-cmf i))
   (define flg (read-byte-only 'zlib-flag i))
   (unless (= 8 (bitwise-and cmf #xF))
-    (error 'git-checkout "compression is not `deflate`"))
+    (raise-git-error 'git-checkout "compression is not `deflate`"))
   (when (bitwise-bit-set? flg 5)
     ;; read dictid
     (read-bytes-exactly 'dictid 4 i))

From 6d63e4443ffad0b73c9632033dbf2adcb0871658 Mon Sep 17 00:00:00 2001
From: Alexis King <lexi.lambda@gmail.com>
Date: Thu, 29 Sep 2016 12:57:19 -0700
Subject: [PATCH 4/6] 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))

From 4111dbc967801b764d3eb407be7224f328b67b30 Mon Sep 17 00:00:00 2001
From: Alexis King <lexi.lambda@gmail.com>
Date: Wed, 5 Oct 2016 16:39:00 -0700
Subject: [PATCH 5/6] Add test for raco pkg install for authenticated git
 packages

---
 pkgs/racket-test/tests/pkg/git-http-proxy.rkt | 82 +++++++++++++++++++
 .../tests/pkg/test-pkgs/pkg-git/info.rkt      |  3 +
 pkgs/racket-test/tests/pkg/tests-catalogs.rkt |  1 +
 pkgs/racket-test/tests/pkg/tests-install.rkt  | 12 ++-
 pkgs/racket-test/tests/pkg/util.rkt           | 34 +++++++-
 5 files changed, 127 insertions(+), 5 deletions(-)
 create mode 100644 pkgs/racket-test/tests/pkg/git-http-proxy.rkt
 create mode 100644 pkgs/racket-test/tests/pkg/test-pkgs/pkg-git/info.rkt

diff --git a/pkgs/racket-test/tests/pkg/git-http-proxy.rkt b/pkgs/racket-test/tests/pkg/git-http-proxy.rkt
new file mode 100644
index 0000000000..aa72124191
--- /dev/null
+++ b/pkgs/racket-test/tests/pkg/git-http-proxy.rkt
@@ -0,0 +1,82 @@
+#lang racket/base
+
+(provide serve-git-http-proxy!)
+
+(require net/base64
+         net/uri-codec
+         net/url
+         racket/match
+         racket/port
+         racket/runtime-path
+         racket/string
+         racket/system
+         web-server/http
+         web-server/servlet-env)
+
+(define (url-path-string url)
+  (string-join (map path/param-path (url-path url))
+               "/" #:before-first "/"))
+
+(define (url-query-string url)
+  (alist->form-urlencoded (url-query url)))
+
+(define (verify-authorization header-value)
+  ; strip #"Basic " off of the header value
+  (define encoded-value (subbytes header-value 6))
+  (equal? (string-split (bytes->string/utf-8 (base64-decode encoded-value)) ":")
+          '("user" "password")))
+
+(define (serve-git-http-proxy req)
+  ; check if the right Authorization header is provided
+  (define authorization (headers-assq* #"Authorization" (request-headers/raw req)))
+  (cond
+    [(and authorization (verify-authorization (header-value authorization)))
+     (parameterize ([current-environment-variables (environment-variables-copy
+                                                    (current-environment-variables))])
+       ; git-http-backend depends on these environment variables to find the git repo
+       (putenv "GIT_PROJECT_ROOT" (path->string (find-system-path 'temp-dir)))
+       (putenv "GIT_HTTP_EXPORT_ALL" "")
+
+       ; set standard CGI environment variables
+       (environment-variables-set! (current-environment-variables)
+                                   #"REQUEST_METHOD" (request-method req))
+       (putenv "PATH_INFO" (url-path-string (request-uri req)))
+       (putenv "QUERY_STRING" (url-query-string (request-uri req)))
+
+       (let ([content-type (headers-assq* #"Content-Type" (request-headers/raw req))])
+         (when content-type
+           (environment-variables-set! (current-environment-variables)
+                                       #"CONTENT_TYPE" (header-value content-type))))
+
+       ; run git-http-backend
+       (match-define (list git-response-port git-body-port _ _ _)
+         (process*/ports #f #f (current-error-port)
+                         (find-executable-path "git") "http-backend"))
+
+       ; pass POST body to git-http-backend
+       (when (request-post-data/raw req)
+         (write-bytes (request-post-data/raw req) git-body-port))
+       (close-output-port git-body-port)
+
+       ; convert CGI headers to ones the web server can understand
+       (define headers
+         (for/list ([line (in-lines git-response-port)]
+                    #:break (zero? (string-length line)))
+           (apply header (map string->bytes/utf-8 (string-split line ": ")))))
+
+       ; produce a response
+       (response 200 #"OK" (current-seconds) #f headers
+                 (λ (out)
+                   (copy-port git-response-port out)
+                   (close-input-port git-response-port))))]
+    ; if authorization fails, return a WWW-Authenticate header
+    [else (response/full 401 #"Authorization Required" (current-seconds)
+                         #"text/plain; charset=utf-8"
+                         (list (header #"WWW-Authenticate" #"Basic"))
+                         (list #"Repository not found."))]))
+
+(define (serve-git-http-proxy! #:port port)
+  (serve/servlet serve-git-http-proxy
+                 #:port port
+                 #:command-line? #t
+                 #:servlet-regexp #rx""))
diff --git a/pkgs/racket-test/tests/pkg/test-pkgs/pkg-git/info.rkt b/pkgs/racket-test/tests/pkg/test-pkgs/pkg-git/info.rkt
new file mode 100644
index 0000000000..17a457b55e
--- /dev/null
+++ b/pkgs/racket-test/tests/pkg/test-pkgs/pkg-git/info.rkt
@@ -0,0 +1,3 @@
+#lang info
+
+(define collection 'multi)
diff --git a/pkgs/racket-test/tests/pkg/tests-catalogs.rkt b/pkgs/racket-test/tests/pkg/tests-catalogs.rkt
index 9de6dba7f9..4818224cf7 100644
--- a/pkgs/racket-test/tests/pkg/tests-catalogs.rkt
+++ b/pkgs/racket-test/tests/pkg/tests-catalogs.rkt
@@ -14,6 +14,7 @@
   (initialize-catalogs)
 
   $ "raco pkg config --set catalogs http://localhost:9990"
+  $ "raco pkg config --set git-checkout-credentials user:password"
 
   $ "racket -l racket/base -l pkg/lib -e '(pkg-config-catalogs)'"
   =stdout> "'(\"http://localhost:9990\")\n"
diff --git a/pkgs/racket-test/tests/pkg/tests-install.rkt b/pkgs/racket-test/tests/pkg/tests-install.rkt
index c2cff03092..d49fe287c3 100644
--- a/pkgs/racket-test/tests/pkg/tests-install.rkt
+++ b/pkgs/racket-test/tests/pkg/tests-install.rkt
@@ -251,4 +251,14 @@
      $ "racket -e '(require pkg/lib)' -e '(path->pkg (build-path (pkg-directory \"pkg-test1\") \"pkg-test2\"))'"
      =stdout> "\"pkg-test1\"\n"
      $ "raco pkg remove pkg-test2-snd pkg-test1"
-     $ "racket -e '(require pkg-test1)'" =exit> 1)))))
+     $ "racket -e '(require pkg-test1)'" =exit> 1))
+
+   (with-fake-root
+    (shelly-case
+     "git package that requires authentication"
+     $ "raco pkg config --set catalogs http://localhost:9990"
+     $ "raco pkg install pkg-git" =exit> 1
+     $ "raco pkg config --set git-checkout-credentials user:bad-password"
+     $ "raco pkg install pkg-git" =exit> 1
+     $ "raco pkg config --set git-checkout-credentials user:password"
+     $ "raco pkg install pkg-git")))))
diff --git a/pkgs/racket-test/tests/pkg/util.rkt b/pkgs/racket-test/tests/pkg/util.rkt
index 4e20a99fe9..d06ff1c8b7 100644
--- a/pkgs/racket-test/tests/pkg/util.rkt
+++ b/pkgs/racket-test/tests/pkg/util.rkt
@@ -10,8 +10,10 @@
          racket/list
          racket/format
          racket/port
+         racket/string
          setup/dirs
-         "shelly.rkt")
+         "shelly.rkt"
+         "git-http-proxy.rkt")
 
 (define-runtime-path test-source-directory ".")
 
@@ -167,8 +169,11 @@
         (with-thread
          (λ () (start-pkg-server *index-ht-2* 9991))
          (λ ()
-           (with-thread (λ () (start-file-server))
-                        t)))))]))
+           (with-thread
+            (λ () (start-file-server))
+            (λ ()
+              (with-thread (λ () (serve-git-http-proxy! #:port 9996))
+                           t)))))))]))
 (define-syntax-rule (with-servers e ...)
   (with-servers* (λ () e ...)))
 
@@ -246,7 +251,28 @@
                      'source
                      "http://localhost:9997/pkg-test2.zip"
                      'dependencies
-                     '("pkg-test1"))))
+                     '("pkg-test1")))
+
+  (initialize-catalogs/git))
+
+(define (initialize-catalogs/git)
+  (define pkg-git.git (make-temporary-file "pkg-git-~a.git"))
+  (delete-file pkg-git.git)
+  (parameterize ([current-directory (build-path test-source-directory "test-pkgs")])
+    (copy-directory/files (build-path test-source-directory "test-pkgs" "pkg-git") pkg-git.git))
+  (define checksum
+    (parameterize ([current-directory pkg-git.git])
+      (system "git init")
+      (system "git add -A")
+      (system "git commit -m 'initial commit'")
+      (string-trim
+       (with-output-to-string
+         (λ () (system "git rev-parse HEAD"))))))
+
+  (match-define-values [_ pkg-git.git-filename _] (split-path pkg-git.git))
+  (hash-set! *index-ht-1* "pkg-git"
+             (hasheq 'checksum checksum
+                     'source (~a "http://localhost:9996/" (path->string pkg-git.git-filename)))))
 
 (define (set-file path content)
   (make-parent-directory* path)

From c459886fc55356e0b2167cf5968fba7878034ba7 Mon Sep 17 00:00:00 2001
From: Alexis King <lexi.lambda@gmail.com>
Date: Thu, 6 Oct 2016 11:48:48 -0700
Subject: [PATCH 6/6] Add some warnings about checkout credentials being stored
 unencrypted

---
 pkgs/racket-doc/pkg/scribblings/pkg.scrbl | 3 ++-
 racket/collects/pkg/private/config.rkt    | 3 ++-
 2 files changed, 4 insertions(+), 2 deletions(-)

diff --git a/pkgs/racket-doc/pkg/scribblings/pkg.scrbl b/pkgs/racket-doc/pkg/scribblings/pkg.scrbl
index f09290e670..975213dfe7 100644
--- a/pkgs/racket-doc/pkg/scribblings/pkg.scrbl
+++ b/pkgs/racket-doc/pkg/scribblings/pkg.scrbl
@@ -946,7 +946,8 @@ for @nonterm{key}.
         set only in @exec{installation} scope.}
   @item{@exec{git-checkout-credentials} --- A list of git credentials in the form
         @nonterm{username}@litchar{:}@nonterm{password} that are tried when downloading
-        packages with git sources using the HTTP or HTTPS protocols.}
+        packages with git sources using the HTTP or HTTPS protocols. The credentials are
+        currently stored @bold{unencrypted} on the filesystem.}
   @item{@exec{trash-max-packages} --- A limit on the number of package implementations
         that are kept in a trash folder when the package is removed or updated.}
   @item{@exec{trash-max-seconds} --- A limit on the time since a package is removed or
diff --git a/racket/collects/pkg/private/config.rkt b/racket/collects/pkg/private/config.rkt
index ff379fd37e..c62ed196c9 100644
--- a/racket/collects/pkg/private/config.rkt
+++ b/racket/collects/pkg/private/config.rkt
@@ -230,7 +230,8 @@
                              [(list _)
                               (credentials-format-error
                                "not enough elements for git checkout credentials"
-                               val)])))]
+                               val)])))
+        (displayln "WARNING: checkout credentials are stored UNENCRYPTED" (current-error-port))]
        [(list* key args)
         (pkg-error "unsupported config key\n  key: ~a" key)])]
     [else