afa17a3df6
This allows things like the package system to detect when something goes wrong with the git transfer without catching everything else, too.
1146 lines
43 KiB
Racket
1146 lines
43 KiB
Racket
#lang racket/base
|
|
(require racket/tcp
|
|
racket/format
|
|
racket/file
|
|
racket/port
|
|
racket/string
|
|
file/gunzip
|
|
file/private/check-path
|
|
openssl/sha1
|
|
net/base64
|
|
net/url
|
|
net/head
|
|
net/http-client
|
|
(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/
|
|
;; provided many helpful hints for this implementation.
|
|
|
|
(provide git-checkout
|
|
current-git-username
|
|
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
|
|
#:dest-dir dest-dir ; #f => only find checkout
|
|
#:transport [transport 'git]
|
|
#:ref [ref "master"]
|
|
#:depth [given-depth 1]
|
|
#:status-printf [status-printf (lambda args
|
|
(apply printf args)
|
|
(flush-output))]
|
|
#:initial-error [initial-error #f]
|
|
#:tmp-dir [given-tmp-dir #f]
|
|
#:clean-tmp-dir? [clean-tmp-dir? (not given-tmp-dir)]
|
|
#:verify-server? [verify? #t]
|
|
#:port [given-port #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)))
|
|
(define port (or given-port (case transport
|
|
[(git) 9418]
|
|
[(http) 80]
|
|
[(https) 443])))
|
|
|
|
(define (status fmt . args)
|
|
(define msg (apply format fmt args))
|
|
(status-printf "~a\n" msg)
|
|
(log-git-checkout-info msg))
|
|
|
|
(status "Contacting ~a" host)
|
|
(define-values (i o dumb-protocol?)
|
|
(initial-connect transport host verify? port repo status username password))
|
|
((let/ec esc
|
|
(dynamic-wind
|
|
void
|
|
(lambda ()
|
|
(status "Getting refs~a" (if dumb-protocol? " [dumb protocol]" ""))
|
|
(write-pkt o
|
|
"git-upload-pack " "/" repo "\0"
|
|
"host=" host "\0")
|
|
(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)
|
|
(raise-git-error 'git-checkout "no initial pkts from the server"))
|
|
|
|
;; Parse server's initial reply
|
|
(define server-capabilities (parse-server-capabilities (car pkts)))
|
|
(define refs ; (list (list <name> <ID>) ...)
|
|
(parse-initial-refs pkts initial-error))
|
|
|
|
;; Find the commits needed for `ref`:
|
|
(define-values (ref-commit ; #f or an ID string
|
|
want-commits) ; list of ID string
|
|
(select-commits ref refs status))
|
|
|
|
(unless dest-dir
|
|
(write-pkt o) ; clean termination
|
|
((esc (lambda ()
|
|
;; If we get this far and `ref-commit` is #f,
|
|
;; then `ref` looks like a commit
|
|
(or ref-commit ref)))))
|
|
|
|
(define depth (and given-depth
|
|
ref-commit
|
|
(cond
|
|
[(member "shallow" server-capabilities)
|
|
given-depth]
|
|
[else
|
|
(status "Server does not support `shallow`")
|
|
#f])))
|
|
|
|
(unless dumb-protocol?
|
|
;; Tell the server which commits we need
|
|
(set!-values (i o) (want-step transport host port repo i o))
|
|
(for ([want-commit (in-list want-commits)]
|
|
[pos (in-naturals)])
|
|
(write-pkt o "want " want-commit (if (zero? pos) " " "") "\n"))
|
|
(when depth
|
|
(write-pkt o "deepen " depth "\n"))
|
|
(write-pkt o)
|
|
|
|
;; 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 username password i o))
|
|
|
|
(when depth
|
|
;; If we wrote `deepen`, then the server replies with `shallow`s.
|
|
;; Note that these were available before writing `done` in the
|
|
;; case of the 'git transport, but it works here for all transports.
|
|
(let loop ()
|
|
(define r (read-pkt i))
|
|
(cond
|
|
[(eof-object? r)
|
|
(void)]
|
|
[(regexp-match? #rx"^shallow " r)
|
|
(loop)]
|
|
[else
|
|
(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)
|
|
(raise-git-error 'git-checkout "expected NAK, got ~s" nak)))
|
|
|
|
(make-directory* tmp-dir)
|
|
(define tmp (make-tmp-info tmp-dir #:fresh? #t))
|
|
|
|
(define (maybe-save-objects objs fn)
|
|
(unless clean-tmp-dir?
|
|
(call-with-output-file*
|
|
(build-path tmp-dir fn)
|
|
#:exists 'truncate
|
|
(lambda (o) (write objs o) (newline o)))))
|
|
|
|
(dynamic-wind
|
|
void
|
|
(lambda ()
|
|
(define obj-ids
|
|
(cond
|
|
[dumb-protocol?
|
|
(read-dumb-objects want-commits tmp
|
|
transport host verify? port repo
|
|
status maybe-save-objects)]
|
|
[else
|
|
;; Read packfile pbjects, which are written into
|
|
;; `tmp-dir`. If `depth` gives the server trouble,
|
|
;; we might get an EOF, in which case we'll try again:
|
|
(define objs
|
|
(read-packfile i tmp status
|
|
(and depth
|
|
(lambda ()
|
|
(esc (lambda ()
|
|
(status "Unexpected EOF; retrying without depth")
|
|
(retry-loop #f)))))))
|
|
|
|
(maybe-save-objects objs "objs")
|
|
|
|
;; Convert deltas into full objects withing `tmp`:
|
|
(rewrite-deltas objs tmp status)]))
|
|
|
|
(maybe-save-objects obj-ids "all-objs")
|
|
|
|
(define commit
|
|
(or ref-commit
|
|
(find-commit-as-reference ref obj-ids)))
|
|
|
|
;; Extract the tree from the packfile objects:
|
|
(status "Extracting tree to ~a" dest-dir)
|
|
(extract-commit-tree (hex-string->bytes commit)
|
|
obj-ids tmp dest-dir
|
|
strict-links?)
|
|
|
|
;; Done; return checkout id
|
|
(lambda () commit))
|
|
(lambda ()
|
|
(status "Cleaning up")
|
|
(close-tmp-info tmp)
|
|
(when clean-tmp-dir?
|
|
(delete-directory/files tmp-dir)))))
|
|
(lambda ()
|
|
(close-input-port i)
|
|
(close-output-port o)))))))
|
|
|
|
;; ----------------------------------------
|
|
;; Transports: git, http, and https
|
|
|
|
(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
|
|
(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 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 username password)
|
|
(case transport
|
|
[(git)
|
|
(define-values (i o) (tcp-or-tunnel-connect "git" host port))
|
|
(values i o #f)]
|
|
[(http https)
|
|
(define url-str
|
|
(~a transport "://" host ":" port "/" repo
|
|
"/info/refs?service=git-upload-pack"))
|
|
(define-values (i headers)
|
|
(parameterize ([current-https-protocol (ssl-context verify?)])
|
|
(get-pure-port/headers (string->url url-str)
|
|
(http-request-headers username password)
|
|
#:redirections 5)))
|
|
(define ok? #f)
|
|
(dynamic-wind
|
|
void
|
|
(lambda ()
|
|
(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)
|
|
(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)
|
|
(raise-git-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) dumb?))
|
|
(lambda ()
|
|
(unless ok? (close-input-port i))))]
|
|
[else
|
|
(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)
|
|
;; Replaces the connection, if appropriate to the transport, for
|
|
;; writing the wanted references.
|
|
(define (want-step transport host port repo i o)
|
|
(case transport
|
|
[(git) (values i o)]
|
|
[(http https)
|
|
(close-input-port i)
|
|
(values (open-input-bytes #"") (open-output-bytes))]))
|
|
|
|
;; 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 username password i o)
|
|
(case transport
|
|
[(git) (values i o)]
|
|
[(http https)
|
|
(define s (get-output-bytes o))
|
|
(define i
|
|
(parameterize ([current-https-protocol (ssl-context verify?)])
|
|
(post-pure-port
|
|
(string->url
|
|
(~a transport "://" host ":" port "/" repo
|
|
"/git-upload-pack"))
|
|
s
|
|
(append
|
|
(http-request-headers username password)
|
|
(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"))
|
|
(current-https-protocol)]
|
|
[else
|
|
'secure]))
|
|
|
|
;; ----------------------------------------
|
|
|
|
;; parse-server-capabilities : bytes -> (listof string)
|
|
(define (parse-server-capabilities first-pkt)
|
|
(let ([m (regexp-match #rx#"\0(.*)\n$" first-pkt)])
|
|
(cond
|
|
[m (string-split (bytes->string/utf-8 (cadr m)))]
|
|
[else null])))
|
|
|
|
;; parse-initial-refs : (listof bytes) -> (listof (list bytes string))
|
|
;; In each element of the returned list, first item is
|
|
;; the branch or tag name, second is the ID
|
|
(define (parse-initial-refs pkts initial-error)
|
|
(filter
|
|
values
|
|
(for/list ([pkt (in-list pkts)])
|
|
(define m (regexp-match #px#"^([0-9a-fA-F]{40})[ \t]([^\0\n]+)[\0\n]" pkt))
|
|
(unless m
|
|
(when initial-error (initial-error))
|
|
(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
|
|
[(regexp-match? #rx#"\\^{}$" name)
|
|
;; drop parent references
|
|
#f]
|
|
[else (list name id)]))))
|
|
|
|
;; select-commits : string (listof (list bytes string))
|
|
;; -> (values string-or-#f (listof string))
|
|
;; Convert the user's request `ref`, which is a branch or tag or ID,
|
|
;; into a specific ID --- if we can determine it from the server's
|
|
;; initial response. If we can, the list of requested IDs will be
|
|
;; just that one. Otherwise, we'll have to return a list of all
|
|
;; IDs, and then we'll look for the reference later.
|
|
(define (select-commits ref refs status)
|
|
(define ref-looks-like-id? (regexp-match? #rx"^[0-9a-f]+$" ref))
|
|
|
|
(define ref-rx (byte-regexp (bytes-append
|
|
#"^refs/(?:heads|tags)/"
|
|
(regexp-quote (string->bytes/utf-8 ref))
|
|
#"$")))
|
|
(define ref-commit
|
|
(or
|
|
;; Search list of branch and tag names:
|
|
(for/or ([ref (in-list refs)])
|
|
(and (regexp-match? ref-rx (car ref))
|
|
(cadr ref)))
|
|
;; Try matching the references as a commit/tag ID of a branch or tag:
|
|
(let ([rx (id-ref->regexp ref)])
|
|
(for/or ([a-ref (in-list refs)])
|
|
(and (regexp-match? rx (cadr a-ref))
|
|
(begin
|
|
(status "Commit id ~s matches ~a" ref (car a-ref))
|
|
(cadr a-ref)))))))
|
|
|
|
(define want-commits
|
|
(cond
|
|
[ref-commit (list ref-commit)]
|
|
[ref-looks-like-id?
|
|
(status "Requested reference looks like commit id; getting all commits")
|
|
(for/list ([ref (in-list refs)])
|
|
(cadr ref))]
|
|
[else
|
|
(raise-git-error 'git "could not find requested reference\n reference: ~a" ref)]))
|
|
|
|
(values ref-commit want-commits))
|
|
|
|
;; ----------------------------------------
|
|
;; A "pkt" is the basic unit of communiation in many parts
|
|
;; of the git protocol. The first four bytes specify the
|
|
;; length of the package (including those bytes).
|
|
|
|
;; write-pkt : output-port any ... -> void
|
|
;; `display`s each argument to create a package
|
|
(define (write-pkt o . args)
|
|
(define s (open-output-bytes))
|
|
(for ([arg (in-list args)])
|
|
(display arg s))
|
|
(define msg (get-output-bytes s))
|
|
(define len (bytes-length msg))
|
|
(define full-msg
|
|
(cond
|
|
[(zero? len) #"0000"]
|
|
[else
|
|
(define len-bstr (string->bytes/utf-8 (format "~x" (+ 4 len))))
|
|
(bytes-append (make-bytes (- 4 (bytes-length len-bstr))
|
|
(char->integer #\0))
|
|
len-bstr
|
|
msg)]))
|
|
(write-bytes full-msg o)
|
|
(flush-output o))
|
|
|
|
;; read-pkg : input-port -> bstr-or-eof
|
|
;; Reads one pkt, returning eof of the special "null" pkt
|
|
(define (read-pkt i)
|
|
(define len-bstr (read-bytes 4 i))
|
|
(cond
|
|
[(eof-object? len-bstr) eof]
|
|
[else
|
|
(unless (and (bytes? len-bstr)
|
|
(= 4 (bytes-length len-bstr)))
|
|
(raise-git-error 'git-checkout "error getting pkt length"))
|
|
(define len (string->number (bytes->string/utf-8 len-bstr #\?) 16))
|
|
(unless len
|
|
(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)
|
|
(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
|
|
(define (read-pkts i)
|
|
(define pkt (read-pkt i))
|
|
(if (or (eof-object? pkt)
|
|
(equal? #"" pkt))
|
|
null
|
|
(cons pkt (read-pkts i))))
|
|
|
|
;; ----------------------------------------
|
|
;; Packfile objects
|
|
|
|
(struct object (location ; filename within tmp or position in small-object file
|
|
type ; 'blob, 'commit, etc.; see `type-num->sym`
|
|
[type-info #:mutable] ; #f, id, or object
|
|
id ; sha1 as bytes
|
|
[undelta #:mutable])
|
|
#:prefab)
|
|
|
|
;; read-packfile : input-port tmp-info status-proc (or/c #f (-> any)) -> (listof object)
|
|
;; The `initial-eof-handler` argument should escape, if it's not #f
|
|
(define (read-packfile i tmp status initial-eof-handler)
|
|
(define pack-bstr (read-bytes 4 i))
|
|
(unless (equal? pack-bstr #"PACK")
|
|
(when (and (eof-object? pack-bstr)
|
|
initial-eof-handler)
|
|
(initial-eof-handler))
|
|
(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")
|
|
(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
|
|
(status "Getting ~a objects" count)
|
|
(for/list ([pos (in-range count)])
|
|
(read-object i tmp obj-stream-poses)))
|
|
|
|
(define OBJ_COMMIT 1)
|
|
(define OBJ_TREE 2)
|
|
(define OBJ_BLOB 3)
|
|
(define OBJ_TAG 4)
|
|
(define OBJ_OFS_DELTA 6)
|
|
(define OBJ_REF_DELTA 7)
|
|
|
|
(define type-num->sym (hash OBJ_COMMIT 'commit
|
|
OBJ_TREE 'tree
|
|
OBJ_BLOB 'blob
|
|
OBJ_TAG 'tag
|
|
OBJ_OFS_DELTA 'ofs-delta
|
|
OBJ_REF_DELTA 'ref-delta))
|
|
(define valid-types (for/list ([v (in-hash-values type-num->sym)]) v))
|
|
|
|
;; read-object : input-port tmp-info (hash-of integer obj) -> object
|
|
(define (read-object i tmp obj-stream-poses)
|
|
(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) (raise-git-error 'git-checkout "bad packfile type"))
|
|
(define init-len (bitwise-and c #xF))
|
|
(define len
|
|
(if (msb-set? c)
|
|
(+ init-len (arithmetic-shift (read-integer i) 4))
|
|
init-len))
|
|
(define type-sym (hash-ref type-num->sym type))
|
|
(define type-info
|
|
(case type-sym
|
|
[(ref-delta)
|
|
(read-bytes-exactly 'referenced-id 20 i)]
|
|
[(ofs-delta)
|
|
(define delta (read-offset-integer i))
|
|
(hash-ref obj-stream-poses (- obj-stream-pos delta)
|
|
(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))
|
|
(hash-set! obj-stream-poses obj-stream-pos obj)
|
|
obj)
|
|
|
|
;; save-object : (output-port ->) integer symbol any tmp-info -> object
|
|
(define (save-object write-data len type-sym type-info tmp)
|
|
(define filename (~a (case type-sym
|
|
[(ref-delta ofs-delta) "delta"]
|
|
[else "obj"])
|
|
(increment-object-count! tmp)))
|
|
(define location
|
|
(call-with-output-object
|
|
tmp
|
|
filename
|
|
len
|
|
write-data))
|
|
(construct-object location type-sym type-info len tmp))
|
|
|
|
;; To build an `object`, we need to construct a SHA-1 from the object
|
|
;; content, which is in a file in `tmp`
|
|
(define (construct-object filename type-sym type-info size tmp)
|
|
(object filename type-sym type-info
|
|
(call-with-input-object
|
|
tmp
|
|
filename
|
|
(lambda (i)
|
|
(define prefix (~a type-sym " " size "\0"))
|
|
(sha1-bytes (input-port-append #f
|
|
(open-input-string prefix)
|
|
i))))
|
|
#f))
|
|
|
|
;; rewrite-deltas : (listof object) tmp status -> (hashof bytes object)
|
|
;; Given a mapping from ids to objects, combine each "delta" file with
|
|
;; a referenced object to create a new object file. The deltas,
|
|
;; referenced objects, and generated objects all are in `tmp`. The
|
|
;; result is an id-to-object mapping that includes all the given
|
|
;; objects plus the generated ones.
|
|
(define (rewrite-deltas objs tmp status)
|
|
(status "Applying deltas")
|
|
(define ids (hash-copy
|
|
(for/hash ([obj (in-list objs)])
|
|
(values (object-id obj) obj))))
|
|
(for ([obj (in-list objs)])
|
|
(case (object-type obj)
|
|
[(ref-delta ofs-delta)
|
|
(define base-obj-id (if (eq? (object-type obj) 'ref-delta)
|
|
;; Base object is referenced directly:
|
|
(object-type-info obj)
|
|
;; We have to find the object generated by another
|
|
;; "object", where the "object" may be a delta:
|
|
(let ([v (object-type-info obj)])
|
|
(set-object-type-info! obj (object-id v))
|
|
(case (object-type v)
|
|
[(ref-delta ofs-delta) (object-undelta v)]
|
|
[else (object-id v)]))))
|
|
(define base-obj (hash-ref ids base-obj-id))
|
|
(define new-filename (~a "obj" (increment-object-count! tmp)))
|
|
(call-with-input-object
|
|
tmp
|
|
;; the delta file:
|
|
(object-location obj)
|
|
(lambda (i)
|
|
(call-with-input-object
|
|
tmp
|
|
;; apply delta to this base object:
|
|
(object-location base-obj)
|
|
(lambda (src-in)
|
|
(define src-len (read-integer i))
|
|
(define dest-len (read-integer i))
|
|
(define location
|
|
(call-with-output-object
|
|
tmp
|
|
;; write to this new object:
|
|
new-filename
|
|
dest-len
|
|
(lambda (o)
|
|
;; Each delta command is either "copy" or "insert"
|
|
(let loop ()
|
|
(define c (read-byte i))
|
|
(cond
|
|
[(eof-object? c)
|
|
(void)]
|
|
[(msb-set? c)
|
|
;; Copy
|
|
(define src-offset (read-number-by-bits i (bitwise-and c #xF)))
|
|
(define raw-src-len (read-number-by-bits i (bitwise-and (arithmetic-shift c -4)
|
|
#x7)))
|
|
(define src-len (if (zero? raw-src-len) #x10000 raw-src-len))
|
|
(file-position src-in src-offset)
|
|
(copy-port-n src-in o src-len)
|
|
(loop)]
|
|
[else
|
|
;; Insert
|
|
(copy-port-n i o c)
|
|
(loop)])))))
|
|
;; Add the generated object to our table:
|
|
(define new-obj (construct-object location (object-type base-obj) #f
|
|
dest-len tmp))
|
|
(hash-set! ids (object-id new-obj) new-obj)
|
|
;; Record undelta id:
|
|
(set-object-undelta! obj (object-id new-obj))))))]))
|
|
ids)
|
|
|
|
;; ----------------------------------------
|
|
;; Finding a commit id
|
|
|
|
(define (find-commit-as-reference ref obj-ids)
|
|
(define rx (id-ref->regexp ref))
|
|
(define matches
|
|
(for/list ([(id obj) (in-hash obj-ids)]
|
|
#:when (eq? 'commit (object-type obj))
|
|
#:when (regexp-match? rx (bytes->hex-string id)))
|
|
(bytes->hex-string id)))
|
|
(cond
|
|
[(= 1 (length matches)) (car matches)]
|
|
[(null? matches)
|
|
(raise-git-error 'git-checkout "no commit found matching id: ~a" ref)]
|
|
[else
|
|
(raise-git-error 'git-checkout "found multiple commits matching id: ~a" ref)]))
|
|
|
|
(define (id-ref->regexp ref)
|
|
(regexp (~a "^" (regexp-quote (string-downcase ref)))))
|
|
|
|
;; ----------------------------------------
|
|
;; Extract a checkout tree
|
|
|
|
;; extract-commit-tree : bytes (hash/c bytes object) tmp-info path -> void
|
|
;; Extract the designated commit to `dest-dir`, using objects from `tmp`
|
|
(define (extract-commit-tree obj-id obj-ids tmp dest-dir strict-links?)
|
|
(define obj (hash-ref obj-ids obj-id))
|
|
(case (object-type obj)
|
|
[(commit)
|
|
(define-values (tree-id-str parent-id-strs)
|
|
(call-with-input-object
|
|
tmp
|
|
(object-location obj)
|
|
(lambda (i)
|
|
(extract-commit-info i obj-id))))
|
|
(define tree-id (hex-string->bytes tree-id-str))
|
|
(extract-tree tree-id obj-ids tmp dest-dir strict-links?)]
|
|
[(tag)
|
|
(define commit-id-bstr
|
|
(call-with-input-object
|
|
tmp
|
|
(object-location obj)
|
|
(lambda (i)
|
|
(define m (regexp-try-match #px"^object ([0-9a-fA-F]{40})" i))
|
|
(unless m
|
|
(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
|
|
(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.
|
|
;; The `obj-id` argument is used for error reporting, only.
|
|
(define (extract-commit-info i obj-id)
|
|
(define m (regexp-try-match #px"^tree ([0-9a-fA-F]{40})" i))
|
|
(unless m
|
|
(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))
|
|
;; Loop for parent ids strings:
|
|
(let loop ()
|
|
(define m (regexp-try-match #px"^\nparent ([0-9a-fA-F]{40})" i))
|
|
(if m
|
|
(cons (bytes->string/utf-8 (cadr m))
|
|
(loop))
|
|
null))))
|
|
|
|
;; extract-tree : bytes (hash/c bytes object) tmp-info path -> void
|
|
;; Extract the designated tree to `dest-dir`, using objects from `tmp`
|
|
(define (extract-tree tree-id obj-ids tmp dest-dir strict-links?)
|
|
(make-directory* dest-dir)
|
|
(define tree-obj (hash-ref obj-ids tree-id))
|
|
(call-with-input-object
|
|
tmp
|
|
(object-location tree-obj)
|
|
(lambda (i)
|
|
(let loop ()
|
|
(define-values (id mode fn) (extract-tree-entry i))
|
|
(when id
|
|
(define (this-object-location)
|
|
(object-location (hash-ref obj-ids id)))
|
|
(define (copy-this-object perms)
|
|
(copy-object tmp
|
|
(this-object-location)
|
|
perms
|
|
(build-path dest-dir fn)))
|
|
(case (datum-intern-literal mode)
|
|
[(#"100755") #"755"
|
|
(copy-this-object #o755)]
|
|
[(#"100644" #"644")
|
|
(copy-this-object #o644)]
|
|
[(#"40000" #"040000")
|
|
(extract-tree id obj-ids tmp (build-path dest-dir fn) strict-links?)]
|
|
[(#"120000")
|
|
(define target (bytes->path (object->bytes tmp (this-object-location))))
|
|
(when strict-links?
|
|
(check-unpack-path 'git-checkout target))
|
|
(make-file-or-directory-link target (build-path dest-dir fn))]
|
|
[(#"160000")
|
|
;; submodule; just make a directory placeholder
|
|
(make-directory* (build-path dest-dir fn))]
|
|
[else
|
|
(raise-git-error 'extract-tree "unknown mode: ~s" mode)])
|
|
(loop))))))
|
|
|
|
;; extract-tree-entry: input-port -> bytes-or-#f bytes-or-#f path-or-#f
|
|
(define (extract-tree-entry i)
|
|
(define m (regexp-try-match #px"^([0-7]{3,6}) ([^\0]+)\0" i))
|
|
(cond
|
|
[m
|
|
(define id (read-bytes-exactly 'id 20 i))
|
|
(define mode (cadr m))
|
|
(define fn (bytes->path-element (caddr m)))
|
|
(values id mode fn)]
|
|
[else
|
|
(values #f #f #f)]))
|
|
|
|
;; ----------------------------------------
|
|
;; ``Dumb'' HTTP(S) server support
|
|
|
|
;; read-dumb-objects : (listof string) (hash-of string object)
|
|
;; symbol string boolean integer string
|
|
;; status maybe-save-objects
|
|
;; -> (hash-of string object)
|
|
;; Read the package files available on the server, then round up
|
|
;; any additional loose objects that we'll need.
|
|
(define (read-dumb-objects id-strs tmp
|
|
transport host verify? port repo
|
|
status maybe-save-objects)
|
|
(define conn (http-conn))
|
|
(http-conn-open! conn
|
|
host
|
|
#:ssl? (if (eq? transport 'https)
|
|
(ssl-context verify?)
|
|
#f)
|
|
#:port port)
|
|
|
|
(define packfiles
|
|
(get-packfile-list conn repo))
|
|
|
|
(define packed-objects
|
|
(for/fold ([objects (hash)]) ([packfile (in-list packfiles)])
|
|
(read-dumb-packfile packfile objects tmp conn repo status)))
|
|
|
|
(maybe-save-objects packed-objects "packed-objs")
|
|
|
|
(status "Downloading loose objects")
|
|
(define objects
|
|
(read-dumb-loose-objects id-strs packed-objects (make-hash)
|
|
tmp conn repo status))
|
|
|
|
(http-conn-close! conn)
|
|
|
|
(for/hash ([obj (in-hash-values objects)])
|
|
(values (object-id obj) obj)))
|
|
|
|
;; get-packfile-list : conn string -> (listof string)
|
|
;; Get a list of packfiles available from the server
|
|
(define (get-packfile-list conn repo)
|
|
(define-values (status-line headers i)
|
|
(http-conn-sendrecv! conn
|
|
(~a "/" repo "/objects/info/packs")))
|
|
(check-status status-line "error getting packfile list")
|
|
|
|
(for/list ([l (in-lines i)]
|
|
#:unless (equal? l ""))
|
|
(define m (regexp-match #rx"^P (.*)" 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
|
|
;; -> (hashof string object)
|
|
;; Read a packfile and apply its deltas, producing an updated mapping of objects
|
|
;; that we have unpacked so far.
|
|
(define (read-dumb-packfile packfile objects tmp conn repo status)
|
|
(define-values (status-line headers i)
|
|
(http-conn-sendrecv! conn
|
|
(~a "/" repo "/objects/pack/" packfile)))
|
|
(check-status status-line (~a "error getting packfile " packfile))
|
|
|
|
(define obj-list (read-packfile i tmp status #f))
|
|
(define obj-ids (rewrite-deltas obj-list tmp status))
|
|
|
|
;; Add new objects to hash table:
|
|
(for/fold ([objects objects]) ([obj (in-hash-values obj-ids)])
|
|
(hash-set objects (bytes->hex-string (object-id obj)) obj)))
|
|
|
|
;; read-dumb-loose-objects : (listof string) (hash-of string object)
|
|
;; (mutable-hash-of string #t)
|
|
;; conn string status
|
|
;; -> (hash-of string object)
|
|
;; Traverse the tree, looking for extra objects (not supplied by a packfile)
|
|
;; that we need to download
|
|
(define (read-dumb-loose-objects id-strs objects seen tmp conn repo status)
|
|
(for/fold ([objects objects]) ([id-str (in-list id-strs)])
|
|
(cond
|
|
[(hash-ref seen id-str #f) objects]
|
|
[else
|
|
(define obj
|
|
(cond
|
|
[(hash-ref objects id-str #f)
|
|
=> (lambda (obj) obj)]
|
|
[else
|
|
(define-values (status-line headers compressed-i)
|
|
(http-conn-sendrecv! conn
|
|
(~a "/" repo
|
|
"/objects/" (substring id-str 0 2)
|
|
"/" (substring id-str 2))))
|
|
(check-status status-line (format "error getting object ~a" id-str))
|
|
|
|
;; Set up decompression of stream:
|
|
(define-values (i decompressed-o) (make-pipe 4096))
|
|
(define exn #f)
|
|
(define inflate-thread
|
|
(thread (lambda ()
|
|
(dynamic-wind
|
|
void
|
|
(lambda ()
|
|
(with-handlers ([values (lambda (x) (set! exn x))])
|
|
(zlib-inflate compressed-i decompressed-o)))
|
|
(lambda ()
|
|
(close-output-port decompressed-o)
|
|
(close-input-port compressed-i))))))
|
|
|
|
;; Parse the object description:
|
|
(define header-m (regexp-try-match #rx#"^[^\0]*\0" i))
|
|
(unless header-m
|
|
(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
|
|
(bytes->string/utf-8 (car (regexp-match #rx"^[^ ]*" header)))))
|
|
(define data-len (string->number
|
|
(bytes->string/utf-8 (cadr (or (regexp-match #rx"[^ ]* ([0-9]+)" header)
|
|
'(#"" #""))))))
|
|
(unless (memq type-sym valid-types)
|
|
(raise-git-error 'git-checkout "bad type: ~e" type-sym))
|
|
|
|
(define obj
|
|
(save-object (lambda (o) (copy-port i o))
|
|
data-len type-sym #f tmp))
|
|
|
|
;; Just in case:
|
|
(kill-thread inflate-thread)
|
|
(close-input-port compressed-i)
|
|
(when exn (raise exn))
|
|
|
|
obj]))
|
|
|
|
;; Add the (potentially) new object to out table:
|
|
(define new-objects (hash-set objects id-str obj))
|
|
(hash-set! seen id-str #t)
|
|
|
|
;; Inspect the new object, looking for additional objects to download:
|
|
(define id (object-id obj))
|
|
(define (call-with-content proc)
|
|
(call-with-input-object
|
|
tmp
|
|
(object-location obj)
|
|
proc))
|
|
(define more-id-strs
|
|
(case (object-type obj)
|
|
[(commit)
|
|
(define-values (tree parents)
|
|
(call-with-content (lambda (i) (extract-commit-info i id))))
|
|
(cons tree parents)]
|
|
[(tree)
|
|
(call-with-content
|
|
(lambda (i)
|
|
(let loop ()
|
|
(define-values (content-id mode fn) (extract-tree-entry i))
|
|
(cond
|
|
[(not content-id) null]
|
|
[(equal? mode #"160000")
|
|
;; don't try to get a submodule commit
|
|
(loop)]
|
|
[else
|
|
(cons (bytes->hex-string content-id)
|
|
(loop))]))))]
|
|
[else
|
|
null]))
|
|
|
|
(read-dumb-loose-objects more-id-strs new-objects seen
|
|
tmp conn repo status)])))
|
|
|
|
;; check-status : string string -> any
|
|
;; Check an HTTP status result and complain if there's a problem
|
|
(define (check-status status-line msg)
|
|
(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))
|
|
(raise-git-error 'git-checkout "~a\n server respone: ~a"
|
|
msg
|
|
status-line)))
|
|
|
|
;; ----------------------------------------
|
|
;; Temporary directory & database
|
|
|
|
(struct tmp-info (dir small-i small-o [pos #:mutable] [flush? #:mutable] [obj-counter #:mutable]))
|
|
|
|
;; make-tmp-info : path -> tmp-info
|
|
(define (make-tmp-info tmp-dir #:fresh? [fresh? #f])
|
|
(define-values (i o) (open-input-output-file
|
|
(build-path tmp-dir "objs-small")
|
|
#:exists (if fresh? 'truncate 'update)))
|
|
(file-stream-buffer-mode i 'none)
|
|
(tmp-info tmp-dir i o 0 #f 0))
|
|
|
|
;; close-tmp-info : tmp-info -> void
|
|
(define (close-tmp-info tmp)
|
|
(close-input-port (tmp-info-small-i tmp))
|
|
(close-output-port (tmp-info-small-o tmp)))
|
|
|
|
;; increment-object-count! : tmp-info -> integer
|
|
(define (increment-object-count! tmp)
|
|
(define n (add1 (tmp-info-obj-counter tmp)))
|
|
(set-tmp-info-obj-counter! tmp n)
|
|
n)
|
|
|
|
;; call-with-output-object : tmp-info string natural (output-port -> any) -> location
|
|
(define (call-with-output-object tmp filename len proc)
|
|
(define (check-len got-len)
|
|
(unless (= 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))
|
|
(define s (open-output-bytes))
|
|
(proc s)
|
|
(let ([bstr (get-output-bytes s)])
|
|
(check-len (bytes-length bstr))
|
|
(define o (tmp-info-small-o tmp))
|
|
(file-position o location)
|
|
(write-bytes bstr o)
|
|
(set-tmp-info-pos! tmp (+ len (tmp-info-pos tmp)))
|
|
(set-tmp-info-flush?! tmp #t))
|
|
(cons location len)]
|
|
[else
|
|
(define path (build-path (tmp-info-dir tmp) filename))
|
|
(call-with-output-file* path proc #:exists 'truncate)
|
|
(check-len (file-size path))
|
|
filename]))
|
|
|
|
;; call-with-input-object : tmp-info location (input-port -> X) -> X
|
|
(define (call-with-input-object tmp location proc)
|
|
(cond
|
|
[(pair? location)
|
|
(define bstr (object->bytes tmp location))
|
|
(proc (open-input-bytes bstr))]
|
|
[else
|
|
(call-with-input-file* (build-path (tmp-info-dir tmp) location) proc)]))
|
|
|
|
;; copy-object : tmp-info location integer path -> void
|
|
(define (copy-object tmp location perms dest-file)
|
|
(cond
|
|
[(pair? location)
|
|
(define bstr (object->bytes tmp location))
|
|
(call-with-output-file*
|
|
dest-file
|
|
#:exists 'truncate
|
|
(lambda (o) (write-bytes bstr o)))]
|
|
[else
|
|
(copy-file (build-path (tmp-info-dir tmp) location)
|
|
dest-file
|
|
#t)])
|
|
(unless (equal? 'windows (system-type 'os))
|
|
(file-or-directory-permissions dest-file perms)))
|
|
|
|
;; object->bytes : tmp-info location -> bytes
|
|
(define (object->bytes tmp location)
|
|
(cond
|
|
[(pair? location)
|
|
(when (tmp-info-flush? tmp)
|
|
(flush-output (tmp-info-small-o tmp))
|
|
(set-tmp-info-flush?! tmp #f))
|
|
(define i (tmp-info-small-i tmp))
|
|
(file-position i (car location))
|
|
(read-bytes (cdr location) i)]
|
|
[else
|
|
(file->bytes (build-path (tmp-info-dir tmp) location))]))
|
|
|
|
;; ----------------------------------------
|
|
;; Utils
|
|
|
|
(define (read-bytes-exactly what len i)
|
|
(define bstr (read-bytes len i))
|
|
(unless (and (bytes? bstr)
|
|
(= (bytes-length bstr) len))
|
|
(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)
|
|
(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
|
|
(define (copy-port-n i o n)
|
|
(cond
|
|
[(n . <= . 4096)
|
|
(define bstr (read-bytes n i))
|
|
(unless (and (bytes? bstr)
|
|
(= (bytes-length bstr) n))
|
|
(raise-git-error 'git-checkout "not enough bytes during copy"))
|
|
(write-bytes bstr o)]
|
|
[else
|
|
(copy-port-n i o 4096)
|
|
(copy-port-n i o (- n 4096))]))
|
|
|
|
(define (msb-set? c)
|
|
(bitwise-bit-set? c 7))
|
|
|
|
;; A common integer encoding is a sequence of 7-bit
|
|
;; piecs of the number, where the most-significant bit
|
|
;; indicates whether the number continues
|
|
(define (read-integer i)
|
|
(let loop ([amt 0] [shift 0])
|
|
(define c (read-byte i))
|
|
(cond
|
|
[(eof-object? c) amt]
|
|
[else
|
|
(define new-amt (+ amt
|
|
(arithmetic-shift (bitwise-and c #x7F) shift)))
|
|
(if (msb-set? c)
|
|
(loop new-amt (+ shift 7))
|
|
new-amt)])))
|
|
|
|
;; Similar to read-integer, but for (negative) offsets
|
|
(define (read-offset-integer i)
|
|
(define c (read-byte i))
|
|
(cond
|
|
[(eof-object? c) 0]
|
|
[else
|
|
(define delta (bitwise-and c #x7F))
|
|
(cond
|
|
[(not (msb-set? c)) delta]
|
|
[else
|
|
(let loop ([delta delta])
|
|
(define c (read-byte i))
|
|
(cond
|
|
[(eof-object? c) delta]
|
|
[else
|
|
(let ([delta (+ (arithmetic-shift (+ delta 1) 7)
|
|
(bitwise-and c #x7F))])
|
|
(if (msb-set? c)
|
|
(loop delta)
|
|
delta))]))])]))
|
|
|
|
;; Another number format, where a bitmap `n` indicates
|
|
;; when to read a byte
|
|
(define (read-number-by-bits i n)
|
|
(cond
|
|
[(zero? n) 0]
|
|
[else
|
|
(+ (if (bitwise-bit-set? n 0)
|
|
(read-byte i)
|
|
0)
|
|
(arithmetic-shift (read-number-by-bits i (arithmetic-shift n -1))
|
|
8))]))
|
|
|
|
;; zlib-inflate : input-port output-port
|
|
;; Reads compressed data from `i`, writes uncompressed to `o`
|
|
(define (zlib-inflate i o)
|
|
(define cmf (read-byte-only 'zlib-cmf i))
|
|
(define flg (read-byte-only 'zlib-flag i))
|
|
(unless (= 8 (bitwise-and cmf #xF))
|
|
(raise-git-error 'git-checkout "compression is not `deflate`"))
|
|
(when (bitwise-bit-set? flg 5)
|
|
;; read dictid
|
|
(read-bytes-exactly 'dictid 4 i))
|
|
(inflate i o)
|
|
;; Verify checksum?
|
|
(read-bytes-exactly 'adler-checksum 4 i)
|
|
(void))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(module+ main
|
|
(require racket/cmdline)
|
|
|
|
(define depth 1)
|
|
(define ref "master")
|
|
(define tmp-dir #f)
|
|
(define transport 'git)
|
|
(define status-printf
|
|
(lambda args
|
|
(apply printf args)
|
|
(flush-output)))
|
|
|
|
(define-values (host repo dest)
|
|
(command-line
|
|
#:once-any
|
|
[("--git") "Use the Git transport (the default)"
|
|
(set! transport 'git)]
|
|
[("--http") "Use the \"smart\" HTTP transport"
|
|
(set! transport 'http)]
|
|
[("--https") "Use the \"smart\" HTTPS transport"
|
|
(set! transport 'https)]
|
|
#:once-each
|
|
[("--depth") d "Commit depth of <d> (default is 1, 0 means \"all\")"
|
|
(set! depth (string->number d))
|
|
(unless (exact-nonnegative-integer? depth)
|
|
(raise-user-error 'git-checkout "bad depth: ~a" d))]
|
|
[("--ref") branch/tag/commit "Checkout specified commit"
|
|
(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)
|
|
(values host repo dest)))
|
|
|
|
(git-checkout host repo
|
|
#:transport transport
|
|
#:dest-dir dest
|
|
#:tmp-dir tmp-dir
|
|
#:ref ref
|
|
#:depth (if (eq? 0 depth) #f depth)
|
|
#:status-printf status-printf))
|