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

raco pkg: wrap network access with retries

Browse Source 
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 2015-09-11 13:53:41 -06:00
parent 2923a3adcf
commit 29223aaed7
4 changed files with 110 additions and 68 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
racket/collects/pkg/private/catalog.rkt
View File

@ -8,7 +8,8 @@
"params.rkt" "params.rkt"
"config.rkt" "config.rkt"
"print.rkt" "print.rkt"
"prefetch.rkt") "prefetch.rkt"
"network.rkt")
(provide select-info-version (provide select-info-version
source->relative-source source->relative-source
@ -236,19 +237,14 @@
;; uses a custodian to avoid leaks: ;; uses a custodian to avoid leaks:
(define (call-with-url url handler) (define (call-with-url url handler)
(define c (make-custodian)) (call-with-network-retries
(dynamic-wind (lambda ()
void (define-values (p hs)
(lambda () (get-pure-port/headers url #:redirections 25 #:status? #t))
(define-values (p hs) (begin0
(parameterize ([current-custodian c]) (and (string=? "200" (substring hs 9 12))
(get-pure-port/headers url #:redirections 25 #:status? #t))) (handler p))
(begin0 (close-input-port p)))))
(and (string=? "200" (substring hs 9 12))
(handler p))
(close-input-port p)))
(lambda ()
(custodian-shutdown-all c))))
(define (db-pkg-info pkg details?) (define (db-pkg-info pkg details?)
(if details? (if details?

68
racket/collects/pkg/private/download.rkt
View File

@ -10,27 +10,14 @@
net/git-checkout net/git-checkout
"path.rkt" "path.rkt"
"print.rkt" "print.rkt"
"config.rkt") "config.rkt"
"network.rkt")
(provide call/input-url+200 (provide download-file!
download-file!
download-repo! download-repo!
url-path/no-slash url-path/no-slash
clean-cache) 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 (url-path/no-slash url)
(define p (url-path url)) (define p (url-path url))
(define rp (reverse p)) (define rp (reverse p))
@ -72,20 +59,23 @@
(define (download!) (define (download!)
(when download-printf (when download-printf
(download-printf "Downloading ~a\n" (url->string url))) (download-printf "Downloading ~a\n" (url->string url)))
(call-with-output-file* (call-with-network-retries
file (lambda ()
#:exists 'truncate/replace (call-with-output-file*
(λ (op) file
(call/input-url+200 #:exists 'truncate/replace
url (λ (op)
(λ (ip) (copy-port ip op)) (call/input-url+200
#:failure url
(lambda (reply-s) (λ (ip) (copy-port ip op))
(pkg-error (~a "error downloading package\n" #:auto-retry? #f
" URL: ~a\n" #:failure
" server response: ~a") (lambda (reply-s)
(url->string url) (pkg-error (~a "error downloading package\n"
(read-line (open-input-string reply-s)))))))) " 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!))) (do-cache-file file url checksum use-cache? download-printf download!)))
(define (clean-cache pkg-url checksum) (define (clean-cache pkg-url checksum)
@ -109,14 +99,16 @@
(define (download!) (define (download!)
(when download-printf (when download-printf
(download-printf "Downloading repository ~a\n" (url->string url))) (download-printf "Downloading repository ~a\n" (url->string url)))
(git-checkout host #:port port repo (call-with-network-retries
#:dest-dir dest-dir (lambda ()
#:ref checksum (git-checkout host #:port port repo
#:status-printf (lambda (fmt . args) #:dest-dir dest-dir
(define (strip-ending-newline s) #:ref checksum
(regexp-replace #rx"\n$" s "")) #:status-printf (lambda (fmt . args)
(log-pkg-debug (strip-ending-newline (apply format fmt args)))) (define (strip-ending-newline s)
#:transport transport) (regexp-replace #rx"\n$" s ""))
(log-pkg-debug (strip-ending-newline (apply format fmt args))))
#:transport transport)))
(set! unpacked? #t) (set! unpacked? #t)
;; package directory as ".tgz" so it can be cached: ;; package directory as ".tgz" so it can be cached:
(parameterize ([current-directory dest-dir]) (parameterize ([current-directory dest-dir])

51
racket/collects/pkg/private/network.rkt Normal file
View 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)))))

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

@ -29,7 +29,8 @@
"repo-path.rkt" "repo-path.rkt"
"orig-pkg.rkt" "orig-pkg.rkt"
"git.rkt" "git.rkt"
"prefetch.rkt") "prefetch.rkt"
"network.rkt")
(provide (struct-out install-info) (provide (struct-out install-info)
remote-package-checksum remote-package-checksum
@ -732,21 +733,23 @@
(define-values (transport host port repo branch path) (define-values (transport host port repo branch path)
(split-git-or-hub-url pkg-url #:type type)) (split-git-or-hub-url pkg-url #:type type))
(download-printf "Querying Git references for ~a at ~a\n" pkg-name pkg-url-str) (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` (call-with-network-retries
;; to an ID: (lambda ()
(git-checkout host #:port port repo ;; Supplying `#:dest-dir #f` means that we just resolve `branch`
#:dest-dir #f ;; to an ID:
#:ref branch (git-checkout host #:port port repo
#:status-printf (lambda (fmt . args) #:dest-dir #f
(define (strip-ending-newline s) #:ref branch
(regexp-replace #rx"\n$" s "")) #:status-printf (lambda (fmt . args)
(log-pkg-debug (strip-ending-newline (apply format fmt args)))) (define (strip-ending-newline s)
#:initial-error (lambda () (regexp-replace #rx"\n$" s ""))
(pkg-error (~a "Git checkout initial protocol failed;\n" (log-pkg-debug (strip-ending-newline (apply format fmt args))))
" the given URL might not refer to a Git repository\n" #:initial-error (lambda ()
" given URL: ~a") (pkg-error (~a "Git checkout initial protocol failed;\n"
pkg-url-str)) " the given URL might not refer to a Git repository\n"
#:transport transport)] " given URL: ~a")
pkg-url-str))
#:transport transport)))]
[(github) [(github)
(match-define (list* user repo branch path) (match-define (list* user repo branch path)
(split-github-url pkg-url)) (split-github-url pkg-url))