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

Adjust net/git-checkout to raise exn:fail:git instead of exn:fail

Browse Source 
This allows things like the package system to detect when something goes
wrong with the git transfer without catching everything else, too.
This commit is contained in:
Alexis King 2016-09-29 12:56:02 -07:00
parent 8de889df5e
commit afa17a3df6
2 changed files with 69 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -106,7 +106,9 @@ Authentication.
@history[#:added "6.1.1.1"
#:changed "6.3" @elem{Added the @racket[initial-error] argument.}
#:changed "6.2.900.17" @elem{Added the @racket[strict-links?] argument.}
#:changed "6.6.0.5" @elem{Added the @racket[username] and @racket[password] arguments.}]}
#:changed "6.6.0.5" @elem{Added the @racket[username] and @racket[password] arguments.}
#:changed "6.6.0.5" @elem{Changed to raise @racket[exn:fail:git] exceptions
instead of @racket[exn:fail].}]}
@deftogether[(@defparam[current-git-username username (or/c string? #f)]
@defparam[current-git-password password (or/c string? #f)])]{
@ -115,3 +117,8 @@ Parameters used by @racket[git-checkout] as the default values of the
authentication with the remote server.
@history[#:added "6.6.0.5"]}
@defstruct[(exn:fail:git exn:fail) () #:transparent]{
Raised by @racket[git-checkout] due to errors parsing or communicating with the git protocol.
@history[#:added "6.6.0.5"]}

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

@ -19,13 +19,20 @@
(provide git-checkout
current-git-username
current-git-password)
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
@ -74,7 +81,7 @@
;; smart protocol provides packets:
(read-pkts i)))
(unless (pair? pkts)
(error 'git-checkout "no initial pkts from the server"))
(raise-git-error 'git-checkout "no initial pkts from the server"))
;; Parse server's initial reply
(define server-capabilities (parse-server-capabilities (car pkts)))
@ -128,12 +135,12 @@
[(regexp-match? #rx"^shallow " r)
(loop)]
[else
(error 'git-checkout "expected shallow, got ~s" r)])))
(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)
(error 'git-checkout "expected NAK, got ~s" nak)))
(raise-git-error 'git-checkout "expected NAK, got ~s" nak)))
(make-directory* tmp-dir)
(define tmp (make-tmp-info tmp-dir #:fresh? #t))
@ -237,14 +244,14 @@
"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"
(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)
(error 'git-checkout (~a "expected a null packet, received something else\n"
(raise-git-error 'git-checkout (~a "expected a null packet, received something else\n"
" packet: ~s")
term-pkt))
#f]
@ -256,7 +263,7 @@
(lambda ()
(unless ok? (close-input-port i))))]
[else
(error 'git-checkout "unrecognized transport\n given: ~e" transport)]))
(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)
@ -318,8 +325,7 @@
(define m (regexp-match #px#"^([0-9a-fA-F]{40})[ \t]([^\0\n]+)[\0\n]" pkt))
(unless m
(when initial-error (initial-error))
(error 'git-checkout "could not parse ref pkt\n pkt: ~s"
pkt))
(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
@ -364,7 +370,7 @@
(for/list ([ref (in-list refs)])
(cadr ref))]
[else
(error 'git "could not find requested reference\n reference: ~a" ref)]))
(raise-git-error 'git "could not find requested reference\n reference: ~a" ref)]))
(values ref-commit want-commits))
@ -402,16 +408,16 @@
[else
(unless (and (bytes? len-bstr)
(= 4 (bytes-length len-bstr)))
(error 'git-checkout "error getting pkt length"))
(raise-git-error 'git-checkout "error getting pkt length"))
(define len (string->number (bytes->string/utf-8 len-bstr #\?) 16))
(unless len
(error 'git-checkout "error getting pkt length\n length string: ~e" len-bstr))
(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)
(error 'git-checkout "pkt length makes no sense\n length: ~a" len))
(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
@ -440,10 +446,10 @@
(when (and (eof-object? pack-bstr)
initial-eof-handler)
(initial-eof-handler))
(error 'git-checkout "header error\n bytes: ~s" pack-bstr))
(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")
(error 'git-checkout "only version 2 supported"))
(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
@ -471,7 +477,7 @@
(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) (error 'git-checkout "bad packfile type"))
(when (zero? type) (raise-git-error 'git-checkout "bad packfile type"))
(define init-len (bitwise-and c #xF))
(define len
(if (msb-set? c)
@ -485,7 +491,7 @@
[(ofs-delta)
(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")))]
(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))
@ -605,9 +611,9 @@
(cond
[(= 1 (length matches)) (car matches)]
[(null? matches)
(error 'git-checkout "no commit found matching id: ~a" ref)]
(raise-git-error 'git-checkout "no commit found matching id: ~a" ref)]
[else
(error 'git-checkout "found multiple commits matching id: ~a" ref)]))
(raise-git-error 'git-checkout "found multiple commits matching id: ~a" ref)]))
(define (id-ref->regexp ref)
(regexp (~a "^" (regexp-quote (string-downcase ref)))))
@ -637,7 +643,7 @@
(lambda (i)
(define m (regexp-try-match #px"^object ([0-9a-fA-F]{40})" i))
(unless m
(error 'git-checkout "cannot extract commit from tag file for ~s"
(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)))
@ -645,7 +651,7 @@
[(tree)
(extract-tree obj-id obj-ids tmp dest-dir strict-links?)]
[else
(error 'git-checkout "cannot extract tree from ~a: ~s"
(raise-git-error 'git-checkout "cannot extract tree from ~a: ~s"
(object-type obj)
(bytes->hex-string obj-id))]))
@ -655,7 +661,7 @@
(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
(raise-git-error 'git-checkout
(~a "cannot extract tree from commit file for ~s\n"
" content starts: ~s")
(bytes->hex-string obj-id)
@ -706,7 +712,7 @@
;; submodule; just make a directory placeholder
(make-directory* (build-path dest-dir fn))]
[else
(error 'extract-tree "unknown mode: ~s" mode)])
(raise-git-error 'extract-tree "unknown mode: ~s" mode)])
(loop))))))
;; extract-tree-entry: input-port -> bytes-or-#f bytes-or-#f path-or-#f
@ -771,7 +777,7 @@
(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))
(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
@ -831,7 +837,7 @@
;; 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"))
(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
@ -840,7 +846,7 @@
(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))
(raise-git-error 'git-checkout "bad type: ~e" type-sym))
(define obj
(save-object (lambda (o) (copy-port i o))
@ -895,7 +901,7 @@
(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"
(raise-git-error 'git-checkout "~a\n server respone: ~a"
msg
status-line)))
@ -927,7 +933,7 @@
(define (call-with-output-object tmp filename len proc)
(define (check-len got-len)
(unless (= len got-len)
(error 'git-checkout "size mismatch\n expected: ~a\n received: ~a"
(raise-git-error 'git-checkout "size mismatch\n expected: ~a\n received: ~a"
len
got-len)))
(cond
@ -994,7 +1000,7 @@
(define bstr (read-bytes len i))
(unless (and (bytes? bstr)
(= (bytes-length bstr) len))
(error 'git-checkout (~a "error getting bytes for ~a\n"
(raise-git-error 'git-checkout (~a "error getting bytes for ~a\n"
" expected length: ~a\n"
" got length: ~a")
what
@ -1007,8 +1013,7 @@
(define (read-byte-only what i)
(define c (read-byte i))
(unless (byte? c)
(error 'git-checkout "expected to get a byte for ~a, got enf-of-file"
what))
(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
@ -1018,7 +1023,7 @@
(define bstr (read-bytes n i))
(unless (and (bytes? bstr)
(= (bytes-length bstr) n))
(error 'git-checkout "not enough bytes during copy"))
(raise-git-error 'git-checkout "not enough bytes during copy"))
(write-bytes bstr o)]
[else
(copy-port-n i o 4096)
@ -1081,7 +1086,7 @@
(define cmf (read-byte-only 'zlib-cmf i))
(define flg (read-byte-only 'zlib-flag i))
(unless (= 8 (bitwise-and cmf #xF))
(error 'git-checkout "compression is not `deflate`"))
(raise-git-error 'git-checkout "compression is not `deflate`"))
(when (bitwise-bit-set? flg 5)
;; read dictid
(read-bytes-exactly 'dictid 4 i))