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" @history[#:added "6.1.1.1"
#:changed "6.3" @elem{Added the @racket[initial-error] argument.} #:changed "6.3" @elem{Added the @racket[initial-error] argument.}
#:changed "6.2.900.17" @elem{Added the @racket[strict-links?] 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)] @deftogether[(@defparam[current-git-username username (or/c string? #f)]
@defparam[current-git-password password (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. authentication with the remote server.
@history[#:added "6.6.0.5"]} @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 (provide git-checkout
current-git-username current-git-username
current-git-password) current-git-password
(struct-out exn:fail:git))
(define-logger git-checkout) (define-logger git-checkout)
(define current-git-username (make-parameter #f)) (define current-git-username (make-parameter #f))
(define current-git-password (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 ;; Like `git clone`, but producing just the checkout
(define (git-checkout host (define (git-checkout host
repo repo
@ -74,7 +81,7 @@
;; smart protocol provides packets: ;; smart protocol provides packets:
(read-pkts i))) (read-pkts i)))
(unless (pair? pkts) (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 ;; Parse server's initial reply
(define server-capabilities (parse-server-capabilities (car pkts))) (define server-capabilities (parse-server-capabilities (car pkts)))
@ -128,12 +135,12 @@
[(regexp-match? #rx"^shallow " r) [(regexp-match? #rx"^shallow " r)
(loop)] (loop)]
[else [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 ;; 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))) (raise-git-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))
@ -237,14 +244,14 @@
"application/x-git-upload-pack-advertisement") "application/x-git-upload-pack-advertisement")
;; "smart" protocol ;; "smart" protocol
(unless (regexp-match-peek #px#"^[0-9a-f]{4}#" i) (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" " response is not consistent with the Git protocol\n"
" initial portion: ~s") " initial portion: ~s")
(read-bytes 640 i))) (read-bytes 640 i)))
(define pkt (read-pkt i)) (define pkt (read-pkt i))
(define term-pkt (read-pkt i)) (define term-pkt (read-pkt i))
(unless (eof-object? term-pkt) (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") " packet: ~s")
term-pkt)) term-pkt))
#f] #f]
@ -256,7 +263,7 @@
(lambda () (lambda ()
(unless ok? (close-input-port i))))] (unless ok? (close-input-port i))))]
[else [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 ;; want-step: transport-sym string natural string input-port output-port
;; -> (values 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)) (define m (regexp-match #px#"^([0-9a-fA-F]{40})[ \t]([^\0\n]+)[\0\n]" pkt))
(unless m (unless m
(when initial-error (initial-error)) (when initial-error (initial-error))
(error 'git-checkout "could not parse ref pkt\n pkt: ~s" (raise-git-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)))
(cond (cond
@ -364,7 +370,7 @@
(for/list ([ref (in-list refs)]) (for/list ([ref (in-list refs)])
(cadr ref))] (cadr ref))]
[else [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)) (values ref-commit want-commits))
@ -402,16 +408,16 @@
[else [else
(unless (and (bytes? len-bstr) (unless (and (bytes? len-bstr)
(= 4 (bytes-length 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)) (define len (string->number (bytes->string/utf-8 len-bstr #\?) 16))
(unless len (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 (cond
[(= len 0) eof] ; flush pkt [(= len 0) eof] ; flush pkt
[else [else
(define payload-len (- len 4)) (define payload-len (- len 4))
(unless (payload-len . >= . 0) (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-bytes-exactly 'payload payload-len i)])]))
;; read a list of pkts until an empty packet is found ;; read a list of pkts until an empty packet is found
@ -440,10 +446,10 @@
(when (and (eof-object? pack-bstr) (when (and (eof-object? pack-bstr)
initial-eof-handler) initial-eof-handler)
(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)) (define vers (read-bytes 4 i))
(unless (equal? vers #"\0\0\0\2") (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-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 (define obj-stream-poses (make-hash)) ; for OBJ_OFS_DELTA references
@ -471,7 +477,7 @@
(define obj-stream-pos (file-position i)) (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) (raise-git-error 'git-checkout "bad packfile type"))
(define init-len (bitwise-and c #xF)) (define init-len (bitwise-and c #xF))
(define len (define len
(if (msb-set? c) (if (msb-set? c)
@ -485,7 +491,7 @@
[(ofs-delta) [(ofs-delta)
(define delta (read-offset-integer i)) (define delta (read-offset-integer i))
(hash-ref obj-stream-poses (- obj-stream-pos delta) (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])) [else #f]))
(define obj (define obj
(save-object (lambda (o) (zlib-inflate i o)) len type-sym type-info tmp)) (save-object (lambda (o) (zlib-inflate i o)) len type-sym type-info tmp))
@ -605,9 +611,9 @@
(cond (cond
[(= 1 (length matches)) (car matches)] [(= 1 (length matches)) (car matches)]
[(null? 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 [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) (define (id-ref->regexp ref)
(regexp (~a "^" (regexp-quote (string-downcase ref))))) (regexp (~a "^" (regexp-quote (string-downcase ref)))))
@ -637,7 +643,7 @@
(lambda (i) (lambda (i)
(define m (regexp-try-match #px"^object ([0-9a-fA-F]{40})" i)) (define m (regexp-try-match #px"^object ([0-9a-fA-F]{40})" i))
(unless m (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))) (bytes->hex-string obj-id)))
(cadr m)))) (cadr m))))
(define commit-id (hex-string->bytes (bytes->string/utf-8 commit-id-bstr))) (define commit-id (hex-string->bytes (bytes->string/utf-8 commit-id-bstr)))
@ -645,7 +651,7 @@
[(tree) [(tree)
(extract-tree obj-id obj-ids tmp dest-dir strict-links?)] (extract-tree obj-id obj-ids tmp dest-dir strict-links?)]
[else [else
(error 'git-checkout "cannot extract tree from ~a: ~s" (raise-git-error 'git-checkout "cannot extract tree from ~a: ~s"
(object-type obj) (object-type obj)
(bytes->hex-string obj-id))])) (bytes->hex-string obj-id))]))
@ -655,7 +661,7 @@
(define (extract-commit-info i obj-id) (define (extract-commit-info i obj-id)
(define m (regexp-try-match #px"^tree ([0-9a-fA-F]{40})" i)) (define m (regexp-try-match #px"^tree ([0-9a-fA-F]{40})" i))
(unless m (unless m
(error 'git-checkout (raise-git-error 'git-checkout
(~a "cannot extract tree from commit file for ~s\n" (~a "cannot extract tree from commit file for ~s\n"
" content starts: ~s") " content starts: ~s")
(bytes->hex-string obj-id) (bytes->hex-string obj-id)
@ -706,7 +712,7 @@
;; submodule; just make a directory placeholder ;; submodule; just make a directory placeholder
(make-directory* (build-path dest-dir fn))] (make-directory* (build-path dest-dir fn))]
[else [else
(error 'extract-tree "unknown mode: ~s" mode)]) (raise-git-error 'extract-tree "unknown mode: ~s" mode)])
(loop)))))) (loop))))))
;; extract-tree-entry: input-port -> bytes-or-#f bytes-or-#f path-or-#f ;; extract-tree-entry: input-port -> bytes-or-#f bytes-or-#f path-or-#f
@ -771,7 +777,7 @@
(for/list ([l (in-lines i)] (for/list ([l (in-lines i)]
#:unless (equal? l "")) #:unless (equal? l ""))
(define m (regexp-match #rx"^P (.*)" 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))) (cadr m)))
;; read-dumb-packfile : string (hashof string object) tmp conn strung status ;; read-dumb-packfile : string (hashof string object) tmp conn strung status
@ -831,7 +837,7 @@
;; Parse the object description: ;; Parse the object description:
(define header-m (regexp-try-match #rx#"^[^\0]*\0" i)) (define header-m (regexp-try-match #rx#"^[^\0]*\0" i))
(unless header-m (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 (car header-m))
(define header-len (bytes-length header)) (define header-len (bytes-length header))
(define type-sym (string->symbol (define type-sym (string->symbol
@ -840,7 +846,7 @@
(bytes->string/utf-8 (cadr (or (regexp-match #rx"[^ ]* ([0-9]+)" header) (bytes->string/utf-8 (cadr (or (regexp-match #rx"[^ ]* ([0-9]+)" header)
'(#"" #"")))))) '(#"" #""))))))
(unless (memq type-sym valid-types) (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 (define obj
(save-object (lambda (o) (copy-port i o)) (save-object (lambda (o) (copy-port i o))
@ -895,7 +901,7 @@
(define status (let ([m (regexp-match #rx"^[^ ]* ([0-9]+)" status-line)]) (define status (let ([m (regexp-match #rx"^[^ ]* ([0-9]+)" status-line)])
(and m (string->number (bytes->string/utf-8 (cadr m)))))) (and m (string->number (bytes->string/utf-8 (cadr m))))))
(unless (memv status '(200)) (unless (memv status '(200))
(error 'git-checkout "~a\n server respone: ~a" (raise-git-error 'git-checkout "~a\n server respone: ~a"
msg msg
status-line))) status-line)))
@ -927,7 +933,7 @@
(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)
(unless (= 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 len
got-len))) got-len)))
(cond (cond
@ -994,7 +1000,7 @@
(define bstr (read-bytes len i)) (define bstr (read-bytes len i))
(unless (and (bytes? bstr) (unless (and (bytes? bstr)
(= (bytes-length bstr) len)) (= (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" " expected length: ~a\n"
" got length: ~a") " got length: ~a")
what what
@ -1007,8 +1013,7 @@
(define (read-byte-only what i) (define (read-byte-only what i)
(define c (read-byte i)) (define c (read-byte i))
(unless (byte? c) (unless (byte? c)
(error 'git-checkout "expected to get a byte for ~a, got enf-of-file" (raise-git-error 'git-checkout "expected to get a byte for ~a, got enf-of-file" what))
what))
c) c)
;; copy-port-n : input-port output-port natural -> void ;; copy-port-n : input-port output-port natural -> void
@ -1018,7 +1023,7 @@
(define bstr (read-bytes n i)) (define bstr (read-bytes n i))
(unless (and (bytes? bstr) (unless (and (bytes? bstr)
(= (bytes-length bstr) n)) (= (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)] (write-bytes bstr o)]
[else [else
(copy-port-n i o 4096) (copy-port-n i o 4096)
@ -1081,7 +1086,7 @@
(define cmf (read-byte-only 'zlib-cmf i)) (define cmf (read-byte-only 'zlib-cmf i))
(define flg (read-byte-only 'zlib-flag i)) (define flg (read-byte-only 'zlib-flag i))
(unless (= 8 (bitwise-and cmf #xF)) (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) (when (bitwise-bit-set? flg 5)
;; read dictid ;; read dictid
(read-bytes-exactly 'dictid 4 i)) (read-bytes-exactly 'dictid 4 i))