suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

net/git-checkout: support "dumb" protocol for discovery

Browse Source 
Supporting just reference discovery can be useful for certain
testing configurations.
This commit is contained in:
Matthew Flatt 2014-11-21 07:00:18 -07:00
parent 389e971cea
commit 04f5fe3815
2 changed files with 64 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
pkgs/net-pkgs/net-doc/net/scribblings/git-checkout.scrbl
View File

@ -7,7 +7,9 @@
@defmodule[net/git-checkout]{The @racketmodname[net/git-checkout] @defmodule[net/git-checkout]{The @racketmodname[net/git-checkout]
library provides support for extracting a directory tree from a Git library provides support for extracting a directory tree from a Git
repository that is hosted by a server that implements the @tt{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 @racketmodname[net/git-checkout] library does not rely on external
binaries (such as a @exec{git} client) or Git-specific native binaries (such as a @exec{git} client) or Git-specific native
libraries (such as @filepath{libgit}).} 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] [#:tmp-dir given-tmp-dir (or/c #f path-string?) #f]
[#:clean-tmp-dir? clean-tmp-dir? any/c (not given-tmp-dir)] [#:clean-tmp-dir? clean-tmp-dir? any/c (not given-tmp-dir)]
[#:verify-server? verify-server? any/c #t] [#:verify-server? verify-server? any/c #t]
[#:port port (integer-in 1 65535) (case transport [#:port port (or/c #f (integer-in 1 65535)) (case transport
[(git) 9418] [(git) 9418]
[(http) 80] [(http) 80]
[(https) 443])]) [(https) 443])])
string?]{ string?]{
Contacts the server at @racket[hostname] and @racket[port] 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 to download the repository whose name on the server is
@racket[repository] (normally ending in @filepath{.git}). The tree @racket[repository] (normally ending in @filepath{.git}). The tree
within the repository that is identified by @racket[ref] (which can be 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 If @racket[transport] is @racket['git], then the server is contacted
using Git's native transport. If @racket[transport] is using Git's native transport. If @racket[transport] is
@racket['http] or @racket['https], then the server is contacted using @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 the server's identity is verified unless @racket[verify-server?] is
false or the @indexed-envvar{GIT_SSL_NO_VERIFY} environment variable false or the @indexed-envvar{GIT_SSL_NO_VERIFY} environment variable
is set. is set.

82
racket/collects/net/git-checkout.rkt
View File

@ -8,6 +8,7 @@
openssl/sha1 openssl/sha1
openssl openssl
net/url net/url
net/head
(only-in net/url-connect current-https-protocol)) (only-in net/url-connect current-https-protocol))
;; Stefan Saasen's "Reimplementing 'git clone' in Haskell from the bottom up" ;; Stefan Saasen's "Reimplementing 'git clone' in Haskell from the bottom up"
@ -31,13 +32,14 @@
#:tmp-dir [given-tmp-dir #f] #:tmp-dir [given-tmp-dir #f]
#:clean-tmp-dir? [clean-tmp-dir? (not given-tmp-dir)] #:clean-tmp-dir? [clean-tmp-dir? (not given-tmp-dir)]
#:verify-server? [verify? #t] #:verify-server? [verify? #t]
#:port [port (case transport #:port [given-port #f])
[(git) 9418]
[(http) 80]
[(https) 443])])
(let retry-loop ([given-depth given-depth]) (let retry-loop ([given-depth given-depth])
(define tmp-dir (or given-tmp-dir (define tmp-dir (or given-tmp-dir
(make-temporary-file "git~a" 'directory))) (make-temporary-file "git~a" 'directory)))
(define port (or given-port (case transport
[(git) 9418]
[(http) 80]
[(https) 443])))
(define (status fmt . args) (define (status fmt . args)
(define msg (apply format fmt args)) (define msg (apply format fmt args))
@ -45,16 +47,25 @@
(log-git-checkout-info msg)) (log-git-checkout-info msg))
(status "Contacting ~a" host) (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 ((let/ec esc
(dynamic-wind (dynamic-wind
void void
(lambda () (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 (write-pkt o
"git-upload-pack " "/" repo "\0" "git-upload-pack " "/" repo "\0"
"host=" host "\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) (unless (pair? pkts)
(error 'git-checkout "no initial pkts from the server")) (error 'git-checkout "no initial pkts from the server"))
@ -176,39 +187,52 @@
;; otherwise it returns a "broken link" web page ;; otherwise it returns a "broken link" web page
'("User-Agent: git/1.9")) '("User-Agent: git/1.9"))
;; initial-connect: transport-sym string bool natural string ;; initial-connect: transport-sym string bool natural string status-proc
;; -> (values input-port output-port) ;; -> (values input-port output-port boolean)
;; Contacts the server and returns an output port for writing ;; Contacts the server and returns an output port for writing
;; the request (ignored if not needed for the the transport) ;; the request (ignored if not needed for the the transport)
;; and an input port from reading the available references ;; and an input port from reading the available references. The
(define (initial-connect transport host verify? port repo) ;; boolean result indicates whether the protocol is "dumb".
(define (initial-connect transport host verify? port repo status)
(case transport (case transport
[(git) [(git)
(tcp-connect host port)] (define-values (i o) (tcp-connect host port))
(values i o #f)]
[(http https) [(http https)
(define url-str (define url-str
(~a transport "://" host ":" port "/" repo (~a transport "://" host ":" port "/" repo
"/info/refs?service=git-upload-pack")) "/info/refs?service=git-upload-pack"))
(define i (parameterize ([current-https-protocol (ssl-context verify?)]) (define-values (i headers)
(get-pure-port (string->url url-str) (parameterize ([current-https-protocol (ssl-context verify?)])
http-request-headers))) (get-pure-port/headers (string->url url-str)
http-request-headers
#:redirections 5)))
(define ok? #f) (define ok? #f)
(dynamic-wind (dynamic-wind
void void
(lambda () (lambda ()
(unless (regexp-match-peek #px#"^[0-9a-f]{4}#" i) (define dumb?
(error 'git-checkout (~a "error reading repository content;\n" (cond
" response is not consistent with the Git protocol\n" [(equal? (extract-field "Content-Type" headers)
" initial portion: ~s") "application/x-git-upload-pack-advertisement")
(read-bytes 640 i))) ;; "smart" protocol
(define pkt (read-pkt i)) (unless (regexp-match-peek #px#"^[0-9a-f]{4}#" i)
(define term-pkt (read-pkt i)) (error 'git-checkout (~a "error reading repository content;\n"
(unless (eof-object? term-pkt) " response is not consistent with the Git protocol\n"
(error 'git-checkout (~a "expected a null packet, received something else\n" " initial portion: ~s")
" packet: ~s") (read-bytes 640 i)))
term-pkt)) (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) (set! ok? #t)
(values i (open-output-nowhere))) (values i (open-output-nowhere) dumb?))
(lambda () (lambda ()
(unless ok? (close-input-port i))))] (unless ok? (close-input-port i))))]
[else [else
@ -272,8 +296,8 @@
(filter (filter
values values
(for/list ([pkt (in-list pkts)]) (for/list ([pkt (in-list pkts)])
(define m (regexp-match #px#"^([0-9a-fA-F]{40}) ([^\0\n]+)[\0\n]" pkt)) (define m (regexp-match #px#"^([0-9a-fA-F]{40})[ \t]([^\0\n]+)[\0\n]" pkt))
(unless m (error 'git-checkout "count not parse ref pkt\n pkt: ~a" (unless m (error 'git-checkout "could not parse ref pkt\n pkt: ~s"
pkt)) pkt))
(define name (caddr m)) (define name (caddr m))
(define id (bytes->string/utf-8 (cadr m))) (define id (bytes->string/utf-8 (cadr m)))