diff --git a/pkgs/net-pkgs/net-doc/net/scribblings/git-checkout.scrbl b/pkgs/net-pkgs/net-doc/net/scribblings/git-checkout.scrbl index ab05a3c113..1c6beee09f 100644 --- a/pkgs/net-pkgs/net-doc/net/scribblings/git-checkout.scrbl +++ b/pkgs/net-pkgs/net-doc/net/scribblings/git-checkout.scrbl @@ -7,7 +7,9 @@ @defmodule[net/git-checkout]{The @racketmodname[net/git-checkout] library provides support for extracting a directory tree from a Git repository that is hosted by a server that implements the @tt{git://} -protocol or the ``smart'' protocol over HTTP(S). The +protocol or the ``smart'' protocol over HTTP(S).@margin-note*{The +``dumb'' protocol over HTTP(S) is supported for reference discovery, +but not for obtaining repository content.} The @racketmodname[net/git-checkout] library does not rely on external binaries (such as a @exec{git} client) or Git-specific native libraries (such as @filepath{libgit}).} @@ -31,13 +33,14 @@ for information on command-line arguments and flags. [#: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] - [(https) 443])]) + [#:port port (or/c #f (integer-in 1 65535)) (case transport + [(git) 9418] + [(http) 80] + [(https) 443])]) string?]{ Contacts the server at @racket[hostname] and @racket[port] +(where @racket[#f] is replaced by the default) to download the repository whose name on the server is @racket[repository] (normally ending in @filepath{.git}). The tree within the repository that is identified by @racket[ref] (which can be @@ -47,7 +50,9 @@ 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. In the case of @racket['https], +HTTP(S) and the ``smart'' Git protocol; if the server supports only +the ``dumb'' protocol, then @racket[dest-dir] must be @racket[#f]. 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. diff --git a/racket/collects/net/git-checkout.rkt b/racket/collects/net/git-checkout.rkt index 1c8ebc934d..e8936389ae 100644 --- a/racket/collects/net/git-checkout.rkt +++ b/racket/collects/net/git-checkout.rkt @@ -8,6 +8,7 @@ openssl/sha1 openssl net/url + net/head (only-in net/url-connect current-https-protocol)) ;; Stefan Saasen's "Reimplementing 'git clone' in Haskell from the bottom up" @@ -31,13 +32,14 @@ #: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] - [(https) 443])]) + #:port [given-port #f]) (let retry-loop ([given-depth given-depth]) (define tmp-dir (or given-tmp-dir (make-temporary-file "git~a" 'directory))) + (define port (or given-port (case transport + [(git) 9418] + [(http) 80] + [(https) 443]))) (define (status fmt . args) (define msg (apply format fmt args)) @@ -45,16 +47,25 @@ (log-git-checkout-info msg)) (status "Contacting ~a" host) - (define-values (i o) (initial-connect transport host verify? port repo)) + (define-values (i o dumb-protocol?) + (initial-connect transport host verify? port repo status)) ((let/ec esc (dynamic-wind void (lambda () - (status "Getting refs") + (when (and dumb-protocol? dest-dir) + (error 'git-checkout + "server implements dumb protocol, which supports reference discovery only")) + + (status "Getting refs~a" (if dumb-protocol? " [dumb protocol]" "")) (write-pkt o "git-upload-pack " "/" repo "\0" "host=" host "\0") - (define pkts (read-pkts i)) + (define pkts (if dumb-protocol? + ;; dumb protocol provide plain lines: + (for/list ([l (in-lines i)]) (string-append l "\n")) + ;; smart protocol provides packets: + (read-pkts i))) (unless (pair? pkts) (error 'git-checkout "no initial pkts from the server")) @@ -176,39 +187,52 @@ ;; 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) +;; initial-connect: transport-sym string bool natural string status-proc +;; -> (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 -(define (initial-connect transport host verify? port repo) +;; 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) (case transport [(git) - (tcp-connect host port)] + (define-values (i o) (tcp-connect host port)) + (values i o #f)] [(http https) (define url-str (~a transport "://" host ":" port "/" repo "/info/refs?service=git-upload-pack")) - (define i (parameterize ([current-https-protocol (ssl-context verify?)]) - (get-pure-port (string->url url-str) - http-request-headers))) + (define-values (i headers) + (parameterize ([current-https-protocol (ssl-context verify?)]) + (get-pure-port/headers (string->url url-str) + http-request-headers + #:redirections 5))) (define ok? #f) (dynamic-wind void (lambda () - (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))) - (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)) + (define dumb? + (cond + [(equal? (extract-field "Content-Type" headers) + "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))) + (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)) + #f] + [else + ;; "dumb" protocol + #t])) (set! ok? #t) - (values i (open-output-nowhere))) + (values i (open-output-nowhere) dumb?)) (lambda () (unless ok? (close-input-port i))))] [else @@ -272,8 +296,8 @@ (filter values (for/list ([pkt (in-list pkts)]) - (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" + (define m (regexp-match #px#"^([0-9a-fA-F]{40})[ \t]([^\0\n]+)[\0\n]" pkt)) + (unless m (error 'git-checkout "could not parse ref pkt\n pkt: ~s" pkt)) (define name (caddr m)) (define id (bytes->string/utf-8 (cadr m)))