From 29223aaed7fef92fda52f8c6da9a55d8750dbf5e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 11 Sep 2015 13:53:41 -0600 Subject: [PATCH] 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. --- racket/collects/pkg/private/catalog.rkt | 24 ++++----- racket/collects/pkg/private/download.rkt | 68 +++++++++++------------- racket/collects/pkg/private/network.rkt | 51 ++++++++++++++++++ racket/collects/pkg/private/stage.rkt | 35 ++++++------ 4 files changed, 110 insertions(+), 68 deletions(-) create mode 100644 racket/collects/pkg/private/network.rkt diff --git a/racket/collects/pkg/private/catalog.rkt b/racket/collects/pkg/private/catalog.rkt index d95228212c..2b0ea8d838 100644 --- a/racket/collects/pkg/private/catalog.rkt +++ b/racket/collects/pkg/private/catalog.rkt @@ -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? diff --git a/racket/collects/pkg/private/download.rkt b/racket/collects/pkg/private/download.rkt index 93325312c2..8199c822ff 100644 --- a/racket/collects/pkg/private/download.rkt +++ b/racket/collects/pkg/private/download.rkt @@ -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]) diff --git a/racket/collects/pkg/private/network.rkt b/racket/collects/pkg/private/network.rkt new file mode 100644 index 0000000000..2415f5cbe1 --- /dev/null +++ b/racket/collects/pkg/private/network.rkt @@ -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))))) diff --git a/racket/collects/pkg/private/stage.rkt b/racket/collects/pkg/private/stage.rkt index d8c86a731a..8f3fd17975 100644 --- a/racket/collects/pkg/private/stage.rkt +++ b/racket/collects/pkg/private/stage.rkt @@ -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))