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

net/git-checkout: finish support for "dumb" HTTP(S)

Browse Source 
Full dumb-server support is even more useful for testing.
This commit is contained in:
Matthew Flatt 2014-11-22 15:42:44 -07:00
parent 8498eff8ef
commit 37a209b60e
2 changed files with 393 additions and 135 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -7,9 +7,7 @@
@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).@margin-note*{The protocol or its layering over HTTP(S). 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}).}
@ -50,9 +48,7 @@ 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; if the server supports only HTTP(S). In the case of @racket['https],
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.

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

@ -9,6 +9,7 @@
openssl openssl
net/url net/url
net/head net/head
net/http-client
(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"
@ -53,10 +54,6 @@
(dynamic-wind (dynamic-wind
void void
(lambda () (lambda ()
(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]" "")) (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"
@ -95,69 +92,76 @@
(status "Server does not support `shallow`") (status "Server does not support `shallow`")
#f]))) #f])))
;; Tell the server which commits we need (unless dumb-protocol?
(set!-values (i o) (want-step transport host port repo i o)) ;; Tell the server which commits we need
(for ([want-commit (in-list want-commits)] (set!-values (i o) (want-step transport host port repo i o))
[pos (in-naturals)]) (for ([want-commit (in-list want-commits)]
(write-pkt o "want " want-commit (if (zero? pos) " " "") "\n")) [pos (in-naturals)])
(when depth (write-pkt o "want " want-commit (if (zero? pos) " " "") "\n"))
(write-pkt o "deepen " depth "\n")) (when depth
(write-pkt o) (write-pkt o "deepen " depth "\n"))
(write-pkt o)
;; Tell the server that we're ready for the objects ;; Tell the server that we're ready for the objects
(write-pkt o "done\n") (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 i o))
(when depth (when depth
;; If we wrote `deepen`, then the server replies with `shallow`s. ;; If we wrote `deepen`, then the server replies with `shallow`s.
;; Note that these were available before writing `done` in the ;; Note that these were available before writing `done` in the
;; case of the 'git transport, but it works here for all transports. ;; case of the 'git transport, but it works here for all transports.
(let loop () (let loop ()
(define r (read-pkt i)) (define r (read-pkt i))
(cond (cond
[(eof-object? r) [(eof-object? r)
(void)] (void)]
[(regexp-match? #rx"^shallow " r) [(regexp-match? #rx"^shallow " r)
(loop)] (loop)]
[else [else
(error 'git-checkout "expected shallow, got ~s" r)]))) (error 'git-checkout "expected shallow, got ~s" r)])))
;; Tell the server that we're ready for the objects ;; Tell the server that we're ready for the objects
(define nak (read-pkt i)) (define nak (read-pkt i))
(unless (equal? #"NAK\n" nak) (unless (equal? #"NAK\n" nak)
(error 'git-checkout "expected NAK, got ~s" nak)) (error 'git-checkout "expected NAK, got ~s" nak)))
(make-directory* tmp-dir) (make-directory* tmp-dir)
(define tmp (make-tmp-info tmp-dir #:fresh? #t)) (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 (dynamic-wind
void void
(lambda () (lambda ()
;; Read packfile pbjects, which are written into (define obj-ids
;; `tmp-dir`. If `depth` gives the server trouble, (cond
;; we might get an EOF, in which case we'll try again: [dumb-protocol?
(define objs (read-packfile i tmp status (read-dumb-objects want-commits tmp
(and depth transport host verify? port repo
(lambda () status maybe-save-objects)]
(esc (lambda () [else
(status "Unexpected EOF; retrying without depth") ;; Read packfile pbjects, which are written into
(retry-loop #f))))))) ;; `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)))))))
(unless clean-tmp-dir? (maybe-save-objects objs "objs")
(call-with-output-file*
(build-path tmp-dir "objs")
#:exists 'truncate
(lambda (o) (write objs o) (newline o))))
;; Convert deltas into full objects withing `tmp`: ;; Convert deltas into full objects withing `tmp`:
(status "Applying deltas") (rewrite-deltas objs tmp status)]))
(define obj-ids (rewrite-deltas objs tmp))
(unless clean-tmp-dir? (maybe-save-objects obj-ids "all-objs")
(call-with-output-file*
(build-path tmp-dir "all-objs")
#:exists 'truncate
(lambda (o) (write obj-ids o) (newline o))))
(define commit (define commit
(or ref-commit (or ref-commit
@ -406,8 +410,9 @@
(struct object (location ; filename within tmp or position in small-object file (struct object (location ; filename within tmp or position in small-object file
type ; 'blob, 'commit, etc.; see `type-num->sym` type ; 'blob, 'commit, etc.; see `type-num->sym`
type-info ; #f or id [type-info #:mutable] ; #f, id, or object
id) ; sha1 as bytes id ; sha1 as bytes
[undelta #:mutable])
#:prefab) #:prefab)
;; read-packfile : input-port tmp-info status-proc (or/c #f (-> any)) -> (listof object) ;; read-packfile : input-port tmp-info status-proc (or/c #f (-> any)) -> (listof object)
@ -424,9 +429,10 @@
(error 'git-checkout "only version 2 supported")) (error 'git-checkout "only version 2 supported"))
(define count-bstr (read-bytes-exactly 'count 4 i)) (define count-bstr (read-bytes-exactly 'count 4 i))
(define count (integer-bytes->integer count-bstr #t #t)) (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) (status "Getting ~a objects" count)
(for/list ([pos (in-range count)]) (for/list ([pos (in-range count)])
(read-object i pos tmp))) (read-object i tmp obj-stream-poses)))
(define OBJ_COMMIT 1) (define OBJ_COMMIT 1)
(define OBJ_TREE 2) (define OBJ_TREE 2)
@ -441,9 +447,11 @@
OBJ_TAG 'tag OBJ_TAG 'tag
OBJ_OFS_DELTA 'ofs-delta OBJ_OFS_DELTA 'ofs-delta
OBJ_REF_DELTA 'ref-delta)) OBJ_REF_DELTA 'ref-delta))
(define valid-types (for/list ([v (in-hash-values type-num->sym)]) v))
;; read-object : input-port integer tmp-info -> object ;; read-object : input-port tmp-info (hash-of integer obj) -> object
(define (read-object i pos tmp) (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 c (read-byte-only 'type-and-size i))
(define type (bitwise-and (arithmetic-shift c -4) #x7)) (define type (bitwise-and (arithmetic-shift c -4) #x7))
(when (zero? type) (error 'git-checkout "bad packfile type")) (when (zero? type) (error 'git-checkout "bad packfile type"))
@ -458,19 +466,27 @@
[(ref-delta) [(ref-delta)
(read-bytes-exactly 'referenced-id 20 i)] (read-bytes-exactly 'referenced-id 20 i)]
[(ofs-delta) [(ofs-delta)
(error 'gi-checkout "got OFS delta when we didn't claim to support it")] (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")))]
[else #f])) [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 (define filename (~a (case type-sym
[(ref-delta) "delta"] [(ref-delta ofs-delta) "delta"]
[else "obj"]) [else "obj"])
pos)) (increment-object-count! tmp)))
(define location (define location
(call-with-output-object (call-with-output-object
tmp tmp
filename filename
len len
(lambda (o) write-data))
(zlib-inflate i o))))
(construct-object location type-sym type-info len tmp)) (construct-object location type-sym type-info len tmp))
;; To build an `object`, we need to construct a SHA-1 from the object ;; To build an `object`, we need to construct a SHA-1 from the object
@ -484,65 +500,79 @@
(define prefix (~a type-sym " " size "\0")) (define prefix (~a type-sym " " size "\0"))
(sha1-bytes (input-port-append #f (sha1-bytes (input-port-append #f
(open-input-string prefix) (open-input-string prefix)
i)))))) i))))
#f))
;; rewrite-deltas : (listof object) -> tmp ;; rewrite-deltas : (listof object) tmp status -> (hashof bytes object)
;; Given a mapping from ids to objects, combine each "delta" file with ;; Given a mapping from ids to objects, combine each "delta" file with
;; a referenced object to create a new object file. The deltas, ;; a referenced object to create a new object file. The deltas,
;; referenced objects, and generated objects all are in `tmp`. The ;; referenced objects, and generated objects all are in `tmp`. The
;; result is an id-to-object mapping that includes all the given ;; result is an id-to-object mapping that includes all the given
;; objects plus the generated ones. ;; objects plus the generated ones.
(define (rewrite-deltas objs tmp) (define (rewrite-deltas objs tmp status)
(status "Applying deltas")
(define ids (hash-copy (define ids (hash-copy
(for/hash ([obj (in-list objs)]) (for/hash ([obj (in-list objs)])
(values (object-id obj) obj)))) (values (object-id obj) obj))))
(for ([obj (in-list objs)] (for ([obj (in-list objs)])
[pos (in-naturals)]) (case (object-type obj)
(when (eq? (object-type obj) 'ref-delta) [(ref-delta ofs-delta)
(define base-obj (hash-ref ids (object-type-info obj))) (define base-obj-id (if (eq? (object-type obj) 'ref-delta)
(define new-filename (~a "obj" pos)) ;; Base object is referenced directly:
(call-with-input-object (object-type-info obj)
tmp ;; We have to find the object generated by another
;; the delta file: ;; "object", where the "object" may be a delta:
(object-location obj) (let ([v (object-type-info obj)])
(lambda (i) (set-object-type-info! obj (object-id v))
(call-with-input-object (case (object-type v)
tmp [(ref-delta ofs-delta) (object-undelta v)]
;; apply delta to this base object: [else (object-id v)]))))
(object-location base-obj) (define base-obj (hash-ref ids base-obj-id))
(lambda (src-in) (define new-filename (~a "obj" (increment-object-count! tmp)))
(define src-len (read-integer i)) (call-with-input-object
(define dest-len (read-integer i)) tmp
(define location ;; the delta file:
(call-with-output-object (object-location obj)
tmp (lambda (i)
;; write to this new object: (call-with-input-object
new-filename tmp
dest-len ;; apply delta to this base object:
(lambda (o) (object-location base-obj)
;; Each delta command is either "copy" or "insert" (lambda (src-in)
(let loop () (define src-len (read-integer i))
(define c (read-byte i)) (define dest-len (read-integer i))
(cond (define location
[(eof-object? c) (call-with-output-object
(void)] tmp
[(msb-set? c) ;; write to this new object:
;; Copy new-filename
(define src-offset (read-number-by-bits i (bitwise-and c #xF))) dest-len
(define raw-src-len (read-number-by-bits i (bitwise-and (arithmetic-shift c -4) (lambda (o)
#x7))) ;; Each delta command is either "copy" or "insert"
(define src-len (if (zero? raw-src-len) #x10000 raw-src-len)) (let loop ()
(file-position src-in src-offset) (define c (read-byte i))
(copy-port-n src-in o src-len) (cond
(loop)] [(eof-object? c)
[else (void)]
;; Insert [(msb-set? c)
(copy-port-n i o c) ;; Copy
(loop)]))))) (define src-offset (read-number-by-bits i (bitwise-and c #xF)))
;; Add the geemrated object to our table: (define raw-src-len (read-number-by-bits i (bitwise-and (arithmetic-shift c -4)
(define new-obj (construct-object location (object-type base-obj) #f #x7)))
dest-len tmp)) (define src-len (if (zero? raw-src-len) #x10000 raw-src-len))
(hash-set! ids (object-id new-obj) new-obj))))))) (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) ids)
;; ---------------------------------------- ;; ----------------------------------------
@ -574,17 +604,13 @@
(define obj (hash-ref obj-ids obj-id)) (define obj (hash-ref obj-ids obj-id))
(case (object-type obj) (case (object-type obj)
[(commit) [(commit)
(define tree-id-bstr (define-values (tree-id-str parent-id-strs)
(call-with-input-object (call-with-input-object
tmp tmp
(object-location obj) (object-location obj)
(lambda (i) (lambda (i)
(define m (regexp-try-match #px"^tree ([0-9a-fA-F]{40})" i)) (extract-commit-info i obj-id))))
(unless m (define tree-id (hex-string->bytes tree-id-str))
(error 'git-checkout "cannot extract tree from commit file for ~s"
(bytes->hex-string obj-id)))
(cadr m))))
(define tree-id (hex-string->bytes (bytes->string/utf-8 tree-id-bstr)))
(extract-tree tree-id obj-ids tmp dest-dir)] (extract-tree tree-id obj-ids tmp dest-dir)]
[(tag) [(tag)
(define commit-id-bstr (define commit-id-bstr
@ -606,6 +632,28 @@
(object-type obj) (object-type obj)
(bytes->hex-string obj-id))])) (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
(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-commit-tree : bytes (hash/c bytes object) tmp-info path -> void ;; extract-commit-tree : bytes (hash/c bytes object) tmp-info path -> void
;; Extract the designated tree to `dest-dir`, using objects from `tmp` ;; Extract the designated tree to `dest-dir`, using objects from `tmp`
(define (extract-tree tree-id obj-ids tmp dest-dir) (define (extract-tree tree-id obj-ids tmp dest-dir)
@ -616,11 +664,8 @@
(object-location tree-obj) (object-location tree-obj)
(lambda (i) (lambda (i)
(let loop () (let loop ()
(define m (regexp-try-match #px"^([0-7]{3,6}) ([^\0]+)\0" i)) (define-values (id mode fn) (extract-tree-entry i))
(when m (when id
(define id (read-bytes-exactly 'id 20 i))
(define mode (cadr m))
(define fn (bytes->path-element (caddr m)))
(define (this-object-location) (define (this-object-location)
(object-location (hash-ref obj-ids id))) (object-location (hash-ref obj-ids id)))
(case (datum-intern-literal mode) (case (datum-intern-literal mode)
@ -641,10 +686,200 @@
(error 'extract-tree "unknown mode: ~s" mode)]) (error 'extract-tree "unknown mode: ~s" mode)])
(loop)))))) (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 (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
(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)
(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))
(error 'git-checkout "~a\n server respone: ~a"
msg
status-line)))
;; ---------------------------------------- ;; ----------------------------------------
;; Temporary directory & database ;; Temporary directory & database
(struct tmp-info (dir small-i small-o [pos #:mutable] [flush? #:mutable])) (struct tmp-info (dir small-i small-o [pos #:mutable] [flush? #:mutable] [obj-counter #:mutable]))
;; make-tmp-info : path -> tmp-info ;; make-tmp-info : path -> tmp-info
(define (make-tmp-info tmp-dir #:fresh? [fresh? #f]) (define (make-tmp-info tmp-dir #:fresh? [fresh? #f])
@ -652,13 +887,19 @@
(build-path tmp-dir "objs-small") (build-path tmp-dir "objs-small")
#:exists (if fresh? 'truncate 'update))) #:exists (if fresh? 'truncate 'update)))
(file-stream-buffer-mode i 'none) (file-stream-buffer-mode i 'none)
(tmp-info tmp-dir i o 0 #f)) (tmp-info tmp-dir i o 0 #f 0))
;; close-tmp-info : tmp-info -> void ;; close-tmp-info : tmp-info -> void
(define (close-tmp-info tmp) (define (close-tmp-info tmp)
(close-input-port (tmp-info-small-i tmp)) (close-input-port (tmp-info-small-i tmp))
(close-output-port (tmp-info-small-o 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 ;; call-with-output-object : tmp-info string natural (output-port -> any) -> location
(define (call-with-output-object tmp filename len proc) (define (call-with-output-object tmp filename len proc)
(define (check-len got-len) (define (check-len got-len)
@ -776,6 +1017,27 @@
(loop new-amt (+ shift 7)) (loop new-amt (+ shift 7))
new-amt)]))) 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 ;; Another number format, where a bitmap `n` indicates
;; when to read a byte ;; when to read a byte
(define (read-number-by-bits i n) (define (read-number-by-bits i n)