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

Better fix for git checkout problem

Browse Source
This commit is contained in:
Jay McCarthy 2017-10-28 07:23:28 -04:00
parent 12febe5cc2
commit 033cd43b8f
2 changed files with 18 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
racket/collects/pkg/private/checkout-credentials.rkt
View File

@ -8,7 +8,7 @@
(define (call-with-git-checkout-credentials t) (define (call-with-git-checkout-credentials t)
(let loop ([credentials-list (cons #f (get-git-checkout-credentials))]) (let loop ([credentials-list (cons #f (get-git-checkout-credentials))])
(define credentials (first credentials-list)) (define credentials (first credentials-list))
(with-handlers ([exn:fail? (with-handlers ([exn:fail:git?
(λ (x) (λ (x)
(if (empty? (rest credentials-list)) (if (empty? (rest credentials-list))
(raise x) (raise x)

26
racket/collects/pkg/private/stage.rkt
View File

@ -745,15 +745,23 @@
(git-checkout host #:port port repo (git-checkout host #:port port repo
#:dest-dir #f #:dest-dir #f
#:ref branch #:ref branch
#:status-printf (lambda (fmt . args) #:status-printf
(define (strip-ending-newline s) (lambda (fmt . args)
(regexp-replace #rx"\n$" s "")) (define (strip-ending-newline s)
(log-pkg-debug (strip-ending-newline (apply format fmt args)))) (regexp-replace #rx"\n$" s ""))
#:initial-error (lambda () (log-pkg-debug
(pkg-error (~a "Git checkout initial protocol failed;\n" (strip-ending-newline (apply format fmt args))))
" the given URL might not refer to a Git repository\n" #:initial-error
" given URL: ~a") (lambda ()
pkg-url-str)) (raise
;; This is a git error so that
;; call-with-git-checkout-credentials will retry
(exn:fail:git
(~a "pkg: Git checkout initial protocol failed;\n"
" the given URL might not refer to a Git repository\n"
" given URL: "
pkg-url-str)
(current-continuation-marks))))
#:transport transport)))))] #:transport transport)))))]
[(github) [(github)
(match-define (list* user repo branch path) (match-define (list* user repo branch path)