Remove custom version and update racket

src/http-utils.rkt

@@ -6,7 +6,7 @@
          http-interpret-response
          http-simple-interpret-response
          http-follow-redirects
-         http-sendrecv/url
+         custom-http-sendrecv/url
 
          http/interpret-response
          http/simple-interpret-response
@@ -17,7 +17,7 @@
 (require racket/match)
 (require net/http-client)
 (require net/head)
-(require (except-in net/url http-sendrecv/url))
+(require net/url)
 
 ;; (Parameterof Number)
 ;; Number of redirections to automatically follow when retrieving via GET or HEAD.
@@ -64,9 +64,9 @@
           reason-phrase
           (parse-headers response-headers downcase-header-names?)
           (if read-body?
-              (begin0 (port->bytes response-body-port)
+            (begin0 (port->bytes response-body-port)
-                (close-input-port response-body-port))
+              (close-input-port response-body-port))
-              response-body-port)))
+            response-body-port)))
 
 (define (http-simple-interpret-response status-line response-headers response-body-port)
   (define-values (_http-version
@@ -79,64 +79,39 @@
           headers
           body))
 
-(define ((http-follow-redirects method
+(define ((check-response method remaining-redirect-count)
-                                #:version [version #"1.1"])
          status-line
          response-headers
          response-body-port)
-  (define ((check-response remaining-redirect-count)
+  (log-debug "http-follow-redirects: Checking request result: ~a\n" status-line)
-           status-line
+  (define-values (http-version status-code reason-phrase)
-           response-headers
+    (parse-status-line status-line))
-           response-body-port)
+  (if (and (positive? remaining-redirect-count)
-    (log-debug "http-follow-redirects: Checking request result: ~a\n" status-line)
+           (eq? (http-classify-status-code status-code) 'redirection))
-    (define-values (http-version status-code reason-phrase) (parse-status-line status-line))
+    (match (assq 'location (parse-headers response-headers))
-    (if (and (positive? remaining-redirect-count)
+      [#f (values status-line response-headers response-body-port)]
-             (eq? (http-classify-status-code status-code) 'redirection))
+      [(cons _location-header-label location-urlbytes)
-        (match (assq 'location (parse-headers response-headers))
+       (define location (string->url (bytes->string/latin-1 location-urlbytes)))
-          [#f (values status-line response-headers response-body-port)]
+       (void (port->bytes response-body-port)) ;; consume and discard input
-          [(cons _location-header-label location-urlbytes)
+       (close-input-port response-body-port)
-           (define location (string->url (bytes->string/latin-1 location-urlbytes)))
+       (log-debug "http-follow-redirects: Following redirection to ~a\n"
-           (void (port->bytes response-body-port)) ;; consume and discard input
+                  location-urlbytes)
-           (close-input-port response-body-port)
+       (call-with-values (lambda () (custom-http-sendrecv/url location
-           (log-debug "http-follow-redirects: Following redirection to ~a\n" location-urlbytes)
+                                                              #:method method))
-           (call-with-values (lambda () (http-sendrecv/url location
+                         (check-response method (- remaining-redirect-count 1)))])
-                                                           #:version version
+    (values status-line response-headers response-body-port)))
-                                                           #:method method))
+
-                             (check-response (- remaining-redirect-count 1)))])
+(define ((http-follow-redirects method)
-        (values status-line response-headers response-body-port)))
+         status-line
-  ((check-response (http-redirection-limit))
+         response-headers
+         response-body-port)
+  ((check-response method (http-redirection-limit))
    status-line
    response-headers
    response-body-port))
 
-;; Already present in net/url, but that variant doesn't take #:version
+(define (custom-http-sendrecv/url u #:method method)
-;; or allow overriding of #:ssl? and #:port.
+  (http-sendrecv/url u #:method method))
-;;
-;; Furthermore, currently 2016-08-14 there is a fd leak when using
-;; method HEAD with `http-sendrecv` [1], so we implement our own crude
-;; connection management here.
-;;
-;; [1] https://github.com/racket/racket/issues/1414
-;;
-(define (http-sendrecv/url u
-                           #:ssl? [ssl? (equal? (url-scheme u) "https")]
-                           #:port [port (or (url-port u) (if ssl? 443 80))]
-                           #:version [version #"1.1"]
-                           #:method [method #"GET"]
-                           #:headers [headers '()]
-                           #:data [data #f]
-                           #:content-decode [decodes '(gzip)])
-  (define hc (http-conn-open (url-host u) #:ssl? ssl? #:port port))
-  (http-conn-send! hc (url->string u)
-                   #:version version
-                   #:method method
-                   #:headers headers
-                   #:data data
-                   #:content-decode decodes
-                   #:close? #t)
-  (begin0 (http-conn-recv! hc #:method method #:content-decode decodes #:close? #t)
-    (when (member method (list #"HEAD" "HEAD" 'HEAD))
-      (http-conn-close! hc))))
 
 (define-syntax-rule (http/interpret-response customization ... req-expr)
   (call-with-values (lambda () req-expr)
@@ -151,10 +126,15 @@
                     (http-follow-redirects customization ...)))
 
 (module+ test
-  (require rackunit)
+  (define parent-cust (current-custodian))
-
+  (define this-cust (make-custodian))
-  (http/simple-interpret-response
+  (parameterize ([current-custodian this-cust])
-   (http/follow-redirects
+    (for ([i (in-range 100)])
-    #"HEAD"
+      (http/simple-interpret-response
-    (http-sendrecv/url (string->url "http://google.com/") #:method #"HEAD")))
+       (http/follow-redirects
-  )
+        #"HEAD"
+        (custom-http-sendrecv/url (string->url "http://google.com/")
+                                  #:method #"HEAD")))))
+  (require racket/pretty)
+  (pretty-print
+   (custodian-managed-list this-cust parent-cust)))

src/site.rkt

@@ -14,9 +14,9 @@
 (require racket/port)
 (require (only-in racket/list filter-map drop-right))
 (require (only-in racket/exn exn->string))
-(require (except-in net/url http-sendrecv/url))
+(require net/url)
 (require net/uri-codec)
-(require (except-in web-server/servlet http-sendrecv/url))
+(require web-server/servlet)
 (require json)
 (require "gravatar.rkt")
 (require "bootstrap.rkt")
@@ -1513,7 +1513,7 @@
      (match/values (http/simple-interpret-response
                     (http/follow-redirects
                      #"HEAD"
-                     (http-sendrecv/url readme-u #:method #"HEAD")))
+                     (custom-http-sendrecv/url readme-u #:method #"HEAD")))
        [('success _headers _body) (url->string readme-u)]
        [(_ _ _) #f])))
 
@@ -1527,7 +1527,7 @@
      (match/values (http/simple-interpret-response
                     (http/follow-redirects
                      #"GET"
-                     (http-sendrecv/url u #:method #"GET")))
+                     (custom-http-sendrecv/url u #:method #"GET")))
        [('success _headers body)
         (and (regexp-match? #px"(?i:id=.readme.)" body)
              (string-append (url->string u) "#readme"))]