raco pkg: wrap network access with retries
Retry communication up to five times when `exn:fail:network` is raised. Not all `exn:fail:network` exceptions are transient. For example, attempting to connect to a bad server name will produce an error more slowly than before, since the bad connection will be tried five times. Still, retrying on `exn:fail:network` seems like a good heuristic.
This commit is contained in:
Matthew Flatt
parent
2923a3adcf
commit
29223aaed7
|
|
@ -8,7 +8,8 @@
|
|||
"params.rkt"
|
||||
"config.rkt"
|
||||
"print.rkt"
|
||||
"prefetch.rkt")
|
||||
"prefetch.rkt"
|
||||
"network.rkt")
|
||||
|
||||
(provide select-info-version
|
||||
source->relative-source
|
||||
|
|
@ -236,19 +237,14 @@
|
|||
|
||||
;; uses a custodian to avoid leaks:
|
||||
(define (call-with-url url handler)
|
||||
(define c (make-custodian))
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda ()
|
||||
(define-values (p hs)
|
||||
(parameterize ([current-custodian c])
|
||||
(get-pure-port/headers url #:redirections 25 #:status? #t)))
|
||||
(begin0
|
||||
(and (string=? "200" (substring hs 9 12))
|
||||
(handler p))
|
||||
(close-input-port p)))
|
||||
(lambda ()
|
||||
(custodian-shutdown-all c))))
|
||||
(call-with-network-retries
|
||||
(lambda ()
|
||||
(define-values (p hs)
|
||||
(get-pure-port/headers url #:redirections 25 #:status? #t))
|
||||
(begin0
|
||||
(and (string=? "200" (substring hs 9 12))
|
||||
(handler p))
|
||||
(close-input-port p)))))
|
||||
|
||||
(define (db-pkg-info pkg details?)
|
||||
(if details?
|
||||
|
|
|
|||
|
|
@ -10,27 +10,14 @@
|
|||
net/git-checkout
|
||||
"path.rkt"
|
||||
"print.rkt"
|
||||
"config.rkt")
|
||||
"config.rkt"
|
||||
"network.rkt")
|
||||
|
||||
(provide call/input-url+200
|
||||
download-file!
|
||||
(provide download-file!
|
||||
download-repo!
|
||||
url-path/no-slash
|
||||
clean-cache)
|
||||
|
||||
(define (call/input-url+200 u fun
|
||||
#:headers [headers '()]
|
||||
#:failure [fail-k (lambda (s) #f)])
|
||||
#;(printf "\t\tReading ~a\n" (url->string u))
|
||||
(define-values (ip hs) (get-pure-port/headers u headers
|
||||
#:redirections 25
|
||||
#:status? #t))
|
||||
(if (string=? "200" (substring hs 9 12))
|
||||
(begin0
|
||||
(fun ip)
|
||||
(close-input-port ip))
|
||||
(fail-k hs)))
|
||||
|
||||
(define (url-path/no-slash url)
|
||||
(define p (url-path url))
|
||||
(define rp (reverse p))
|
||||
|
|
@ -72,20 +59,23 @@
|
|||
(define (download!)
|
||||
(when download-printf
|
||||
(download-printf "Downloading ~a\n" (url->string url)))
|
||||
(call-with-output-file*
|
||||
file
|
||||
#:exists 'truncate/replace
|
||||
(λ (op)
|
||||
(call/input-url+200
|
||||
url
|
||||
(λ (ip) (copy-port ip op))
|
||||
#:failure
|
||||
(lambda (reply-s)
|
||||
(pkg-error (~a "error downloading package\n"
|
||||
" URL: ~a\n"
|
||||
" server response: ~a")
|
||||
(url->string url)
|
||||
(read-line (open-input-string reply-s))))))))
|
||||
(call-with-network-retries
|
||||
(lambda ()
|
||||
(call-with-output-file*
|
||||
file
|
||||
#:exists 'truncate/replace
|
||||
(λ (op)
|
||||
(call/input-url+200
|
||||
url
|
||||
(λ (ip) (copy-port ip op))
|
||||
#:auto-retry? #f
|
||||
#:failure
|
||||
(lambda (reply-s)
|
||||
(pkg-error (~a "error downloading package\n"
|
||||
" URL: ~a\n"
|
||||
" server response: ~a")
|
||||
(url->string url)
|
||||
(read-line (open-input-string reply-s))))))))))
|
||||
(do-cache-file file url checksum use-cache? download-printf download!)))
|
||||
|
||||
(define (clean-cache pkg-url checksum)
|
||||
|
|
@ -109,14 +99,16 @@
|
|||
(define (download!)
|
||||
(when download-printf
|
||||
(download-printf "Downloading repository ~a\n" (url->string url)))
|
||||
(git-checkout host #:port port repo
|
||||
#:dest-dir dest-dir
|
||||
#:ref checksum
|
||||
#:status-printf (lambda (fmt . args)
|
||||
(define (strip-ending-newline s)
|
||||
(regexp-replace #rx"\n$" s ""))
|
||||
(log-pkg-debug (strip-ending-newline (apply format fmt args))))
|
||||
#:transport transport)
|
||||
(call-with-network-retries
|
||||
(lambda ()
|
||||
(git-checkout host #:port port repo
|
||||
#:dest-dir dest-dir
|
||||
#:ref checksum
|
||||
#:status-printf (lambda (fmt . args)
|
||||
(define (strip-ending-newline s)
|
||||
(regexp-replace #rx"\n$" s ""))
|
||||
(log-pkg-debug (strip-ending-newline (apply format fmt args))))
|
||||
#:transport transport)))
|
||||
(set! unpacked? #t)
|
||||
;; package directory as ".tgz" so it can be cached:
|
||||
(parameterize ([current-directory dest-dir])
|
||||
|
|
|
|||
51
racket/collects/pkg/private/network.rkt
Normal file
51
racket/collects/pkg/private/network.rkt
Normal file
|
|
@ -0,0 +1,51 @@
|
|||
#lang racket/base
|
||||
(require net/url
|
||||
"print.rkt")
|
||||
|
||||
(provide call-with-network-retries
|
||||
call/input-url+200)
|
||||
|
||||
(define NETWORK-RETRY-COUNT 5)
|
||||
(define NETWORK-INITIAL-PAUSE 0.1)
|
||||
|
||||
;; Retry `thunk` on any `exn:fail:network` exception. A fresh
|
||||
;; custodian is in place during the call to `thunk`, so resources
|
||||
;; are reliably cleaned up (and cannt be allocated and returned
|
||||
;; by `thunk`, except by using a different custodian).
|
||||
(define (call-with-network-retries thunk)
|
||||
(let loop ([retries NETWORK-RETRY-COUNT] [pause-time NETWORK-INITIAL-PAUSE])
|
||||
(with-handlers ([exn:fail:network? (lambda (exn)
|
||||
(cond
|
||||
[(zero? retries)
|
||||
(raise exn)]
|
||||
[else
|
||||
;; Pause, then try again
|
||||
(log-pkg-info "Network error; retrying after ~as"
|
||||
pause-time)
|
||||
(sleep pause-time)
|
||||
(loop (sub1 retries) (* 2 pause-time))]))])
|
||||
(define c (make-custodian))
|
||||
(parameterize ([current-custodian c])
|
||||
(dynamic-wind
|
||||
void
|
||||
thunk
|
||||
(lambda ()
|
||||
(custodian-shutdown-all c)))))))
|
||||
|
||||
(define (call/input-url+200 u fun
|
||||
#:auto-retry? [auto-retry? #t]
|
||||
#:headers [headers '()]
|
||||
#:failure [fail-k (lambda (s) #f)])
|
||||
((if auto-retry?
|
||||
call-with-network-retries
|
||||
(lambda (f) (f)))
|
||||
(lambda ()
|
||||
#;(printf "\t\tReading ~a\n" (url->string u))
|
||||
(define-values (ip hs) (get-pure-port/headers u headers
|
||||
#:redirections 25
|
||||
#:status? #t))
|
||||
(if (string=? "200" (substring hs 9 12))
|
||||
(begin0
|
||||
(fun ip)
|
||||
(close-input-port ip))
|
||||
(fail-k hs)))))
|
||||
|
|
@ -29,7 +29,8 @@
|
|||
"repo-path.rkt"
|
||||
"orig-pkg.rkt"
|
||||
"git.rkt"
|
||||
"prefetch.rkt")
|
||||
"prefetch.rkt"
|
||||
"network.rkt")
|
||||
|
||||
(provide (struct-out install-info)
|
||||
remote-package-checksum
|
||||
|
|
@ -732,21 +733,23 @@
|
|||
(define-values (transport host port repo branch path)
|
||||
(split-git-or-hub-url pkg-url #:type type))
|
||||
(download-printf "Querying Git references for ~a at ~a\n" pkg-name pkg-url-str)
|
||||
;; Supplying `#:dest-dir #f` means that we just resolve `branch`
|
||||
;; to an ID:
|
||||
(git-checkout host #:port port repo
|
||||
#:dest-dir #f
|
||||
#:ref branch
|
||||
#:status-printf (lambda (fmt . args)
|
||||
(define (strip-ending-newline s)
|
||||
(regexp-replace #rx"\n$" s ""))
|
||||
(log-pkg-debug (strip-ending-newline (apply format fmt args))))
|
||||
#:initial-error (lambda ()
|
||||
(pkg-error (~a "Git checkout initial protocol failed;\n"
|
||||
" the given URL might not refer to a Git repository\n"
|
||||
" given URL: ~a")
|
||||
pkg-url-str))
|
||||
#:transport transport)]
|
||||
(call-with-network-retries
|
||||
(lambda ()
|
||||
;; Supplying `#:dest-dir #f` means that we just resolve `branch`
|
||||
;; to an ID:
|
||||
(git-checkout host #:port port repo
|
||||
#:dest-dir #f
|
||||
#:ref branch
|
||||
#:status-printf (lambda (fmt . args)
|
||||
(define (strip-ending-newline s)
|
||||
(regexp-replace #rx"\n$" s ""))
|
||||
(log-pkg-debug (strip-ending-newline (apply format fmt args))))
|
||||
#:initial-error (lambda ()
|
||||
(pkg-error (~a "Git checkout initial protocol failed;\n"
|
||||
" the given URL might not refer to a Git repository\n"
|
||||
" given URL: ~a")
|
||||
pkg-url-str))
|
||||
#:transport transport)))]
|
||||
[(github)
|
||||
(match-define (list* user repo branch path)
|
||||
(split-github-url pkg-url))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user