raco pkg: refine handling of HTTP status codes

Treat only 404 and 410 as "not found" errors, retry on 5xx
errors, and treat anything else as an error insteda of "not found".

pkgs/racket-test/tests/pkg/basic-index.rkt

@@ -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?))])

pkgs/racket-test/tests/pkg/tests-install.rkt

@@ -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)

racket/collects/pkg/private/catalog.rkt

@@ -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)))

racket/collects/pkg/private/download.rkt

@@ -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"

racket/collects/pkg/private/network.rkt

@@ -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)
+    (define (maybe-retry exn)
-                                          (cond
+      (cond
-                                           [(retries . >= . retry-count)
+       [(retries . >= . retry-count)
-                                            (raise exn)]
+        (raise exn)]
-                                           [else
+       [else
-                                            ;; Pause, then try again
+        ;; Pause, then try again
-                                            (log-pkg-info "Network error; retrying after ~as"
+        (log-pkg-info "Network error; retrying after ~as"
-                                                          pause-time)
+                      pause-time)
-                                            (sleep pause-time)
+        (sleep pause-time)
-                                            (loop (add1 retries) (* 2 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 (p hs)
-     (define-values (ip hs) (get-pure-port/headers u headers
+       (get-pure-port/headers url headers
-                                                   #:redirections 25
+                              #:redirections 25
-                                                   #:status? #t))
+                              #:status? #t))
-     (if (string=? "200" (substring hs 9 12))
+     (define status (string->number (substring hs 9 12)))
-         (begin0
+     (cond
-          (fun ip)
+      [(memv status success-codes)
-          (close-input-port ip))
+       (begin0
-         (fail-k hs)))))
+        (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)))]))))

racket/collects/pkg/private/stage.rkt

@@ -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