diff --git a/pkgs/net-doc/net/scribblings/git-checkout.scrbl b/pkgs/net-doc/net/scribblings/git-checkout.scrbl index 46cecaff20..55ade62a3e 100644 --- a/pkgs/net-doc/net/scribblings/git-checkout.scrbl +++ b/pkgs/net-doc/net/scribblings/git-checkout.scrbl @@ -36,7 +36,9 @@ for information on command-line arguments and flags. [(git) 9418] [(http) 80] [(https) 443])] - [#:strict-links? strict-links? any/c #f]) + [#:strict-links? strict-links? any/c #f] + [#:username username (or/c string? #f) (current-git-username)] + [#:password password (or/c string? #f) (current-git-password)]) string?]{ Contacts the server at @racket[hostname] and @racket[port] @@ -96,6 +98,27 @@ If @racket[strict-links?] is true, then the checkout fails with an error if it would produce a symbolic link that refers to an absolute path or to a relative path that contains up-directory elements. +If both @racket[username] and @racket[password] are non-@racket[#f] +@emph{and} @racket[transport] is @racket['http] or @racket['https], then +the provided credentials are passed to the remote server using HTTP Basic +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.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{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)])]{ +Parameters used by @racket[git-checkout] as the default values of the +@racket[_username] and @racket[_password] arguments to control +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"]} diff --git a/pkgs/racket-doc/pkg/scribblings/pkg.scrbl b/pkgs/racket-doc/pkg/scribblings/pkg.scrbl index fc0b6d328d..975213dfe7 100644 --- a/pkgs/racket-doc/pkg/scribblings/pkg.scrbl +++ b/pkgs/racket-doc/pkg/scribblings/pkg.scrbl @@ -944,6 +944,10 @@ for @nonterm{key}. documentation; an empty string, which is the default, disables the URL so that the local filesystem is used. This key can be set only in @exec{installation} scope.} + @item{@exec{git-checkout-credentials} --- A list of git credentials in the form + @nonterm{username}@litchar{:}@nonterm{password} that are tried when downloading + packages with git sources using the HTTP or HTTPS protocols. The credentials are + currently stored @bold{unencrypted} on the filesystem.} @item{@exec{trash-max-packages} --- A limit on the number of package implementations that are kept in a trash folder when the package is removed or updated.} @item{@exec{trash-max-seconds} --- A limit on the time since a package is removed or @@ -955,7 +959,8 @@ for @nonterm{key}. ] @history[#:changed "6.1.1.6" @elem{Added @exec{trash-max-packages} and @exec{trash-max-seconds}.} - #:changed "6.3" @elem{Added @exec{network-retries}.}]} + #:changed "6.3" @elem{Added @exec{network-retries}.} + #:changed "6.6.0.5" @elem{Added @exec{git-checkout-credentials}.}]} @subcommand{@command/toc{catalog-show} @nonterm{option} ... @nonterm{package-name} ... diff --git a/pkgs/racket-test/tests/pkg/git-http-proxy.rkt b/pkgs/racket-test/tests/pkg/git-http-proxy.rkt new file mode 100644 index 0000000000..aa72124191 --- /dev/null +++ b/pkgs/racket-test/tests/pkg/git-http-proxy.rkt @@ -0,0 +1,82 @@ +#lang racket/base + +(provide serve-git-http-proxy!) + +(require net/base64 + net/uri-codec + net/url + racket/match + racket/port + racket/runtime-path + racket/string + racket/system + web-server/http + web-server/servlet-env) + +(define (url-path-string url) + (string-join (map path/param-path (url-path url)) + "/" #:before-first "/")) + +(define (url-query-string url) + (alist->form-urlencoded (url-query url))) + +(define (verify-authorization header-value) + ; strip #"Basic " off of the header value + (define encoded-value (subbytes header-value 6)) + (equal? (string-split (bytes->string/utf-8 (base64-decode encoded-value)) ":") + '("user" "password"))) + +(define (serve-git-http-proxy req) + ; check if the right Authorization header is provided + (define authorization (headers-assq* #"Authorization" (request-headers/raw req))) + (cond + [(and authorization (verify-authorization (header-value authorization))) + (parameterize ([current-environment-variables (environment-variables-copy + (current-environment-variables))]) + ; git-http-backend depends on these environment variables to find the git repo + (putenv "GIT_PROJECT_ROOT" (path->string (find-system-path 'temp-dir))) + (putenv "GIT_HTTP_EXPORT_ALL" "") + + ; set standard CGI environment variables + (environment-variables-set! (current-environment-variables) + #"REQUEST_METHOD" (request-method req)) + (putenv "PATH_INFO" (url-path-string (request-uri req))) + (putenv "QUERY_STRING" (url-query-string (request-uri req))) + + (let ([content-type (headers-assq* #"Content-Type" (request-headers/raw req))]) + (when content-type + (environment-variables-set! (current-environment-variables) + #"CONTENT_TYPE" (header-value content-type)))) + + ; run git-http-backend + (match-define (list git-response-port git-body-port _ _ _) + (process*/ports #f #f (current-error-port) + (find-executable-path "git") "http-backend")) + + ; pass POST body to git-http-backend + (when (request-post-data/raw req) + (write-bytes (request-post-data/raw req) git-body-port)) + (close-output-port git-body-port) + + ; convert CGI headers to ones the web server can understand + (define headers + (for/list ([line (in-lines git-response-port)] + #:break (zero? (string-length line))) + (apply header (map string->bytes/utf-8 (string-split line ": "))))) + + ; produce a response + (response 200 #"OK" (current-seconds) #f headers + (λ (out) + (copy-port git-response-port out) + (close-input-port git-response-port))))] + ; if authorization fails, return a WWW-Authenticate header + [else (response/full 401 #"Authorization Required" (current-seconds) + #"text/plain; charset=utf-8" + (list (header #"WWW-Authenticate" #"Basic")) + (list #"Repository not found."))])) + +(define (serve-git-http-proxy! #:port port) + (serve/servlet serve-git-http-proxy + #:port port + #:command-line? #t + #:servlet-regexp #rx"")) diff --git a/pkgs/racket-test/tests/pkg/test-pkgs/pkg-git/info.rkt b/pkgs/racket-test/tests/pkg/test-pkgs/pkg-git/info.rkt new file mode 100644 index 0000000000..17a457b55e --- /dev/null +++ b/pkgs/racket-test/tests/pkg/test-pkgs/pkg-git/info.rkt @@ -0,0 +1,3 @@ +#lang info + +(define collection 'multi) diff --git a/pkgs/racket-test/tests/pkg/tests-catalogs.rkt b/pkgs/racket-test/tests/pkg/tests-catalogs.rkt index 9de6dba7f9..4818224cf7 100644 --- a/pkgs/racket-test/tests/pkg/tests-catalogs.rkt +++ b/pkgs/racket-test/tests/pkg/tests-catalogs.rkt @@ -14,6 +14,7 @@ (initialize-catalogs) $ "raco pkg config --set catalogs http://localhost:9990" + $ "raco pkg config --set git-checkout-credentials user:password" $ "racket -l racket/base -l pkg/lib -e '(pkg-config-catalogs)'" =stdout> "'(\"http://localhost:9990\")\n" diff --git a/pkgs/racket-test/tests/pkg/tests-install.rkt b/pkgs/racket-test/tests/pkg/tests-install.rkt index c2cff03092..d49fe287c3 100644 --- a/pkgs/racket-test/tests/pkg/tests-install.rkt +++ b/pkgs/racket-test/tests/pkg/tests-install.rkt @@ -251,4 +251,14 @@ $ "racket -e '(require pkg/lib)' -e '(path->pkg (build-path (pkg-directory \"pkg-test1\") \"pkg-test2\"))'" =stdout> "\"pkg-test1\"\n" $ "raco pkg remove pkg-test2-snd pkg-test1" - $ "racket -e '(require pkg-test1)'" =exit> 1))))) + $ "racket -e '(require pkg-test1)'" =exit> 1)) + + (with-fake-root + (shelly-case + "git package that requires authentication" + $ "raco pkg config --set catalogs http://localhost:9990" + $ "raco pkg install pkg-git" =exit> 1 + $ "raco pkg config --set git-checkout-credentials user:bad-password" + $ "raco pkg install pkg-git" =exit> 1 + $ "raco pkg config --set git-checkout-credentials user:password" + $ "raco pkg install pkg-git"))))) diff --git a/pkgs/racket-test/tests/pkg/util.rkt b/pkgs/racket-test/tests/pkg/util.rkt index 4e20a99fe9..d06ff1c8b7 100644 --- a/pkgs/racket-test/tests/pkg/util.rkt +++ b/pkgs/racket-test/tests/pkg/util.rkt @@ -10,8 +10,10 @@ racket/list racket/format racket/port + racket/string setup/dirs - "shelly.rkt") + "shelly.rkt" + "git-http-proxy.rkt") (define-runtime-path test-source-directory ".") @@ -167,8 +169,11 @@ (with-thread (λ () (start-pkg-server *index-ht-2* 9991)) (λ () - (with-thread (λ () (start-file-server)) - t)))))])) + (with-thread + (λ () (start-file-server)) + (λ () + (with-thread (λ () (serve-git-http-proxy! #:port 9996)) + t)))))))])) (define-syntax-rule (with-servers e ...) (with-servers* (λ () e ...))) @@ -246,7 +251,28 @@ 'source "http://localhost:9997/pkg-test2.zip" 'dependencies - '("pkg-test1")))) + '("pkg-test1"))) + + (initialize-catalogs/git)) + +(define (initialize-catalogs/git) + (define pkg-git.git (make-temporary-file "pkg-git-~a.git")) + (delete-file pkg-git.git) + (parameterize ([current-directory (build-path test-source-directory "test-pkgs")]) + (copy-directory/files (build-path test-source-directory "test-pkgs" "pkg-git") pkg-git.git)) + (define checksum + (parameterize ([current-directory pkg-git.git]) + (system "git init") + (system "git add -A") + (system "git commit -m 'initial commit'") + (string-trim + (with-output-to-string + (λ () (system "git rev-parse HEAD")))))) + + (match-define-values [_ pkg-git.git-filename _] (split-path pkg-git.git)) + (hash-set! *index-ht-1* "pkg-git" + (hasheq 'checksum checksum + 'source (~a "http://localhost:9996/" (path->string pkg-git.git-filename))))) (define (set-file path content) (make-parent-directory* path) diff --git a/racket/collects/net/git-checkout.rkt b/racket/collects/net/git-checkout.rkt index 00dd2b1b50..dbc323cf2e 100644 --- a/racket/collects/net/git-checkout.rkt +++ b/racket/collects/net/git-checkout.rkt @@ -7,6 +7,7 @@ file/gunzip file/private/check-path openssl/sha1 + net/base64 net/url net/head net/http-client @@ -16,10 +17,22 @@ ;; http://stefan.saasen.me/articles/git-clone-in-haskell-from-the-bottom-up/ ;; provided many helpful hints for this implementation. -(provide git-checkout) +(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 @@ -35,7 +48,9 @@ #:clean-tmp-dir? [clean-tmp-dir? (not given-tmp-dir)] #:verify-server? [verify? #t] #:port [given-port #f] - #:strict-links? [strict-links? #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))) @@ -51,7 +66,7 @@ (status "Contacting ~a" host) (define-values (i o dumb-protocol?) - (initial-connect transport host verify? port repo status)) + (initial-connect transport host verify? port repo status username password)) ((let/ec esc (dynamic-wind void @@ -66,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))) @@ -106,7 +121,7 @@ ;; 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 i o)) + (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. @@ -120,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)) @@ -189,18 +204,23 @@ ;; ---------------------------------------- ;; Transports: git, http, and https -(define http-request-headers +(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 - '("User-Agent: git/1.9")) + (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 +;; 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) +(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)) @@ -212,7 +232,7 @@ (define-values (i headers) (parameterize ([current-https-protocol (ssl-context verify?)]) (get-pure-port/headers (string->url url-str) - http-request-headers + (http-request-headers username password) #:redirections 5))) (define ok? #f) (dynamic-wind @@ -224,16 +244,16 @@ "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" - " response is not consistent with the Git protocol\n" - " initial portion: ~s") - (read-bytes 640 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) - (error 'git-checkout (~a "expected a null packet, received something else\n" - " packet: ~s") - term-pkt)) + (raise-git-error 'git-checkout (~a "expected a null packet, received something else\n" + " packet: ~s") + term-pkt)) #f] [else ;; "dumb" protocol @@ -243,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) @@ -256,12 +276,12 @@ (close-input-port i) (values (open-input-bytes #"") (open-output-bytes))])) -;; done-step: transport-sym string bool natural string input-port output-port +;; 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 i o) +(define (done-step transport host verify? port repo username password i o) (case transport [(git) (values i o)] [(http https) @@ -274,7 +294,7 @@ "/git-upload-pack")) s (append - http-request-headers + (http-request-headers username password) (list "Content-Type: application/x-git-upload-pack-request"))))) (values i (open-output-nowhere))])) @@ -305,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 @@ -351,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)) @@ -389,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 @@ -427,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 @@ -458,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) @@ -472,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)) @@ -592,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))))) @@ -624,17 +643,17 @@ (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" - (bytes->hex-string obj-id))) + (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 - (error 'git-checkout "cannot extract tree from ~a: ~s" - (object-type obj) - (bytes->hex-string obj-id))])) + (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. @@ -642,11 +661,11 @@ (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))) + (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)) @@ -693,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 @@ -758,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 @@ -818,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 @@ -827,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)) @@ -882,9 +901,9 @@ (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))) + (raise-git-error 'git-checkout "~a\n server respone: ~a" + msg + status-line))) ;; ---------------------------------------- ;; Temporary directory & database @@ -914,9 +933,9 @@ (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" - 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)) @@ -981,21 +1000,20 @@ (define bstr (read-bytes len i)) (unless (and (bytes? bstr) (= (bytes-length bstr) len)) - (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)))) + (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) - (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 @@ -1005,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) @@ -1068,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)) @@ -1109,6 +1127,10 @@ (set! ref branch/tag/commit)] [("--tmp") dir "Write temporary files to