net/git-checkout: repairs for HTTP(S)

Declare a "git" user agent, and use a secure client context for HTTPS
unless the `GIT_SSL_NO_VERIFY` environment variable is defined.

pkgs/net-pkgs/net-doc/net/scribblings/git-checkout.scrbl

@@ -30,6 +30,7 @@ for information on command-line arguments and flags.
                                                                                          (flush-output))]
                        [#:tmp-dir given-tmp-dir (or/c #f path-string?) #f]
                        [#:clean-tmp-dir? clean-tmp-dir? any/c (not given-tmp-dir)]
+                       [#:verify-server? verify-server? any/c #t]
                        [#:port port (integer-in 1 65535) (case transport
                                                            [(git) 9418]
                                                            [(http) 80]
@@ -46,7 +47,10 @@ a branch, tag, commit ID, or tree ID) is extracted to
 If @racket[transport] is @racket['git], then the server is contacted
 using Git's native transport. If @racket[transport] is
 @racket['http] or @racket['https], then the server is contacted using
-HTTP(S) and the ``smart'' Git protocol.
+HTTP(S) and the ``smart'' Git protocol. In the case of @racket['https],
+the server's identity is verified unless @racket[verify-server?] is
+false or the @indexed-envvar{GIT_SSL_NO_VERIFY} environment variable
+is set.
 
 If @racket[dest-dir] is @racket[#f], then the result is an ID
 determined for @racket[ref] from just the server's report of the

racket/collects/net/git-checkout.rkt

@@ -6,7 +6,9 @@
          racket/string
          file/gunzip
          openssl/sha1
-         net/url)
+         openssl
+         net/url
+         (only-in net/url-connect current-https-protocol))
 
 ;; Stefan Saasen's "Reimplementing 'git clone' in Haskell from the bottom up"
 ;;  http://stefan.saasen.me/articles/git-clone-in-haskell-from-the-bottom-up/
@@ -28,6 +30,7 @@
                                                        (flush-output))]
                       #:tmp-dir [given-tmp-dir #f]
                       #:clean-tmp-dir? [clean-tmp-dir? (not given-tmp-dir)]
+                      #:verify-server? [verify? #t]
                       #:port [port (case transport
                                      [(git) 9418]
                                      [(http) 80]
@@ -42,7 +45,7 @@
       (log-git-checkout-info msg))
     
     (status "Contacting ~a" host)
-    (define-values (i o) (initial-connect transport host port repo))
+    (define-values (i o) (initial-connect transport host verify? port repo))
     ((let/ec esc
        (dynamic-wind
         void
@@ -92,7 +95,7 @@
 
           ;; Tell the server that we're ready for the objects
           (write-pkt o "done\n")
-          (set!-values (i o) (done-step transport host port repo i o))
+          (set!-values (i o) (done-step transport host verify? port repo i o))
 
           (when depth
             ;; If we wrote `deepen`, then the server replies with `shallow`s.
@@ -168,29 +171,36 @@
 ;; ----------------------------------------
 ;; Transports: git, http, and https
 
-;; initial-connect: transport-sym string natural string
+(define http-request-headers
+  ;; bitbucket.org seems to require a "git" value for "User-Agent",
+  ;; otherwise it returns a "broken link" web page
+  '("User-Agent: git/1.9"))
+
+;; initial-connect: transport-sym string bool natural string
 ;;                  -> (values input-port output-port)
 ;;  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
-(define (initial-connect transport host port repo)
+(define (initial-connect transport host verify? port repo)
   (case transport
     [(git)
      (tcp-connect host port)]
     [(http https)
-     (define i
+     (define url-str
-       (get-pure-port
+       (~a transport "://" host ":" port "/" repo
-        (string->url
+           "/info/refs?service=git-upload-pack"))
-         (~a transport "://" host ":" port "/" repo
+     (define i (parameterize ([current-https-protocol (ssl-context verify?)])
-             "/info/refs?service=git-upload-pack"))))
+                 (get-pure-port (string->url url-str)
+                                http-request-headers)))
      (define ok? #f)
      (dynamic-wind
       void
       (lambda ()
         (unless (regexp-match-peek #px#"^[0-9a-f]{4}#" i)
-          (error 'git-checkout (~a "response is not consistent with the Git protocol\n"
+          (error 'git-checkout (~a "error reading repository content;\n"
+                                   " response is not consistent with the Git protocol\n"
                                    "  initial portion: ~s")
-                 (read-bytes 64 i)))
+                 (read-bytes 640 i)))
         (define pkt (read-pkt i))
         (define term-pkt (read-pkt i))
         (unless (eof-object? term-pkt)
@@ -215,25 +225,37 @@
      (close-input-port i)
      (values (open-input-bytes #"") (open-output-bytes))]))
 
-;; done-step: transport-sym string natural string input-port output-port
+;; done-step: transport-sym string bool natural 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 port repo i o)
+(define (done-step transport host verify? port repo i o)
   (case transport
     [(git) (values i o)]
     [(http https)
      (define s (get-output-bytes o))
      (define i
-       (post-pure-port
+       (parameterize ([current-https-protocol (ssl-context verify?)])
-        (string->url
+         (post-pure-port
-         (~a transport "://" host ":" port "/" repo
+          (string->url
-             "/git-upload-pack"))
+           (~a transport "://" host ":" port "/" repo
-        s
+               "/git-upload-pack"))
-        (list "Content-Type: application/x-git-upload-pack-request")))
+          s
+          (append
+           http-request-headers
+           (list "Content-Type: application/x-git-upload-pack-request")))))
      (values i (open-output-nowhere))]))
 
+(define (ssl-context verify?)
+  (cond
+   [(or (not verify?)
+        (getenv "GIT_SSL_NO_VERIFY")
+        (not ssl-available?))
+    (current-https-protocol)]
+   [else
+    (ssl-secure-client-context)]))
+
 ;; ----------------------------------------
 
 ;; parse-server-capabilities : bytes -> (listof string)
@@ -250,7 +272,7 @@
   (filter
    values
    (for/list ([pkt (in-list pkts)])
-     (define m (regexp-match #px#"^([0-9a-fA-F]{40}) (.+)[\0\n]" pkt))  
+     (define m (regexp-match #px#"^([0-9a-fA-F]{40}) ([^\0\n]+)[\0\n]" pkt))
      (unless m (error 'git-checkout "count not parse ref pkt\n  pkt: ~a"
                       pkt))
      (define name (caddr m))