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

raco pkg: refine handling of HTTP status codes

Browse Source 
Treat only 404 and 410 as "not found" errors, retry on 5xx
errors, and treat anything else as an error insteda of "not found".
This commit is contained in:
Matthew Flatt 2015-10-06 16:40:00 -06:00
parent 4d3852ae69
commit a5f6bf34dc
6 changed files with 82 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
pkgs/racket-test/tests/pkg/basic-index.rkt
View File

@ -9,20 +9,39 @@
#"text/s-expr" empty
(λ (op) (write v op))))
(define error-count (random 25))
(printf "Server error error generator starts as ~s\n" error-count)
(define (pkg-index/basic pkg-name->info all-pkgs)
(define (write-info req pkg-name)
(response/sexpr (pkg-name->info pkg-name)))
(define i (pkg-name->info pkg-name))
;; Every 25 reseponses or so, generate a 5xx server error;
;; retries should mask the error:
(set! error-count (add1 error-count))
(cond
[(zero? (modulo error-count 5))
(response 500 #"Oops" (current-seconds) #f empty void)]
[i (response/sexpr i)]
[else
;; "Randomly" return #f or a 404, either of which should be
;; treated as not-found failure:
(if (odd? error-count)
(response 404 #"Not Found" (current-seconds) #f empty void)
(response/sexpr #f))]))
(define-values (dispatch get-url)
(dispatch-rules
[("pkgs-all") (lambda (req)
(response/sexpr (all-pkgs)))]
[("pkgs") (lambda (req)
(response/sexpr (hash-keys (all-pkgs))))]
[("pkg" "broken")
(lambda (req)
(response 401 #"Broken" (current-seconds) #f empty void))]
[("pkg" (string-arg)) write-info]))
dispatch)
(provide/contract
[pkg-index/basic
(-> (-> string? (hash/c symbol? any/c))
(-> (-> string? (or/c #f (hash/c symbol? any/c)))
(-> hash?)
(-> request? response?))])

3
pkgs/racket-test/tests/pkg/tests-install.rkt
View File

@ -69,6 +69,9 @@
(shelly-case
"fails due to unrecognized scheme"
$ "raco pkg install magic://download" =exit> 1)
(shelly-case
"fails due to 401 status result"
$ "raco pkg install broken" =exit> 1 =stderr> #rx"401")
(shelly-case
"local directory name fails because not inferred as such (inferred as package name)"
$ "raco pkg install test-pkgs" =exit> 1)

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

@ -224,7 +224,7 @@
" response: ~v")
(url->string url)
s))])
(define bytes (call-with-url url port->bytes))
(define bytes (call/input-url+200 url port->bytes #:who who))
((if bytes
(with-handlers ([exn:fail:read? (lambda (exn)
(lambda () (failure bytes)))])
@ -235,17 +235,6 @@
(failure bytes))))
(lambda () (failure #f)))))
;; uses a custodian to avoid leaks:
(define (call-with-url url handler)
(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?
(let ([tags (db:get-pkg-tags (db:pkg-name pkg)
@ -281,7 +270,7 @@
(add-version-query
(combine-url/relative i "pkgs"))
(lambda (l) (and (list? l)
(andmap string? l)))))
(andmap string? l)))))
;; Local database:
(lambda ()
(map db:pkg-name (db:get-pkgs)))

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

@ -69,7 +69,8 @@
url
(λ (ip) (copy-port ip op))
#:auto-retry? #f
#:failure
#:who 'download
#:not-found-handler
(lambda (reply-s)
(pkg-error (~a "error downloading package\n"
" URL: ~a\n"

72
racket/collects/pkg/private/network.rkt
View File

@ -1,10 +1,14 @@
#lang racket/base
(require net/url
racket/format
"print.rkt"
"config.rkt")
(provide call-with-network-retries
call/input-url+200)
call/input-url+200
exn:fail:can-retry)
(struct exn:fail:can-retry exn:fail ())
(define NETWORK-INITIAL-PAUSE 0.1)
@ -15,16 +19,18 @@
(define (call-with-network-retries thunk)
(define retry-count (get-network-retries))
(let loop ([retries 0] [pause-time NETWORK-INITIAL-PAUSE])
(with-handlers* ([exn:fail:network? (lambda (exn)
(cond
[(retries . >= . retry-count)
(raise exn)]
[else
;; Pause, then try again
(log-pkg-info "Network error; retrying after ~as"
pause-time)
(sleep pause-time)
(loop (add1 retries) (* 2 pause-time))]))])
(define (maybe-retry exn)
(cond
[(retries . >= . retry-count)
(raise exn)]
[else
;; Pause, then try again
(log-pkg-info "Network error; retrying after ~as"
pause-time)
(sleep pause-time)
(loop (add1 retries) (* 2 pause-time))]))
(with-handlers* ([exn:fail:network? maybe-retry]
[exn:fail:can-retry? maybe-retry])
(define c (make-custodian))
(parameterize ([current-custodian c])
(dynamic-wind
@ -33,20 +39,42 @@
(lambda ()
(custodian-shutdown-all c)))))))
(define (call/input-url+200 u fun
(define success-codes '(200))
(define not-found-codes '(404 410))
(define other-retry-codes '(408)) ; not counting 5xx
(define (retry-code? c)
(or (and (integer? c) (<= 500 c 599))
(memv c other-retry-codes)))
(define (call/input-url+200 url handler
#:who [who 'download]
#:auto-retry? [auto-retry? #t]
#:headers [headers '()]
#:failure [fail-k (lambda (s) #f)])
#:not-found-handler [not-found-handler (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)))))
(define-values (p hs)
(get-pure-port/headers url headers
#:redirections 25
#:status? #t))
(define status (string->number (substring hs 9 12)))
(cond
[(memv status success-codes)
(begin0
(handler p)
(close-input-port p))]
[(memv status not-found-codes)
(close-input-port p)
(not-found-handler hs)]
[else
(raise ((if (retry-code? status) exn:fail:can-retry exn:fail)
(format (~a "~a: error from server\n"
" URL: ~a\n"
" status code: ~a")
who
(url->string url)
status)
(current-continuation-marks)))]))))

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

@ -434,6 +434,7 @@
(make-directory* package-path)
(define manifest
(call/input-url+200
#:who 'download-manifest
(url-like "MANIFEST")
port->lines))
(unless manifest
@ -773,6 +774,7 @@
(define api-bs
(call/input-url+200
api-u port->bytes
#:who 'query-github
#:headers (list (format "User-Agent: raco-pkg/~a" (version)))))
(unless api-bs
(error 'package-url->checksum
@ -801,7 +803,8 @@
(download-printf "Downloading checksum for ~a\n" pkg-name)
(log-pkg-debug "Downloading checksum as ~a" u)
(call/input-url+200 (string->url u)
port->string)]))
port->string
#:who 'download-checksum)]))
(define (check-checksum given-checksum checksum what pkg-src cached-url)
(when (and given-checksum