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

protect against errors from early-eof, protect against url objects with no path, ensure method is always passed correctly

Browse Source
This commit is contained in:
Jay McCarthy 2015-10-30 13:49:40 -04:00
parent 342198625e
commit fddd85fa18
2 changed files with 73 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
racket/collects/net/http-client.rkt
View File

@ -184,27 +184,34 @@
(define (http-conn-response-port/chunked! hc #:close? [close? #f]) (define (http-conn-response-port/chunked! hc #:close? [close? #f])
(define (http-pipe-chunk ip op) (define (http-pipe-chunk ip op)
(define (done)
(flush-output op)
(close-output-port op))
(define crlf-bytes (make-bytes 2)) (define crlf-bytes (make-bytes 2))
(let loop ([last-bytes #f]) (let loop ([last-bytes #f])
(define size-str (string-trim (read-line ip eol-type))) (define in-v (read-line ip eol-type))
(define chunk-size (string->number size-str 16)) (cond
(unless chunk-size [(eof-object? in-v)
(error 'http-conn-response/chunked (done)]
"Could not parse ~S as hexadecimal number" [else
size-str)) (define size-str (string-trim in-v))
(define use-last-bytes? (define chunk-size (string->number size-str 16))
(and last-bytes (<= chunk-size (bytes-length last-bytes)))) (unless chunk-size
(if (zero? chunk-size) (error 'http-conn-response/chunked
(begin (flush-output op) "Could not parse ~S as hexadecimal number"
(close-output-port op)) size-str))
(let* ([bs (if use-last-bytes? (define use-last-bytes?
(begin (and last-bytes (<= chunk-size (bytes-length last-bytes))))
(read-bytes! last-bytes ip 0 chunk-size) (if (zero? chunk-size)
last-bytes) (done)
(read-bytes chunk-size ip))] (let* ([bs (if use-last-bytes?
[crlf (read-bytes! crlf-bytes ip 0 2)]) (begin
(write-bytes bs op 0 chunk-size) (read-bytes! last-bytes ip 0 chunk-size)
(loop bs))))) last-bytes)
(read-bytes chunk-size ip))]
[crlf (read-bytes! crlf-bytes ip 0 2)])
(write-bytes bs op 0 chunk-size)
(loop bs)))])))
(define-values (in out) (make-pipe PIPE-SIZE)) (define-values (in out) (make-pipe PIPE-SIZE))
(define chunk-t (define chunk-t

80
racket/collects/net/url.rkt
View File

@ -79,20 +79,21 @@
(define proxy (assoc (url-scheme url) (current-proxy-servers))) (define proxy (assoc (url-scheme url) (current-proxy-servers)))
(define hc (make-ports url proxy)) (define hc (make-ports url proxy))
(define access-string (define access-string
(url->string (ensure-non-empty
(if proxy (url->string
url (if proxy
;; RFCs 1945 and 2616 say: url
;; Note that the absolute path cannot be empty; if none is present in ;; RFCs 1945 and 2616 say:
;; the original URI, it must be given as "/" (the server root). ;; Note that the absolute path cannot be empty; if none is present in
(let-values ([(abs? path) ;; the original URI, it must be given as "/" (the server root).
(if (null? (url-path url)) (let-values ([(abs? path)
(values #t (list (make-path/param "" '()))) (if (null? (url-path url))
(values (url-path-absolute? url) (url-path url)))]) (values #t (list (make-path/param "" '())))
(make-url #f #f #f #f abs? path (url-query url) (url-fragment url)))))) (values (url-path-absolute? url) (url-path url)))])
(make-url #f #f #f #f abs? path (url-query url) (url-fragment url)))))))
(hc:http-conn-send! hc access-string (hc:http-conn-send! hc access-string
#:method (if get? "GET" "POST") #:method (if get? #"GET" #"POST")
#:headers strings #:headers strings
#:content-decode '() #:content-decode '()
#:data post-data) #:data post-data)
@ -111,16 +112,19 @@
(cond [(not scheme) (cond [(not scheme)
(schemeless-url url)] (schemeless-url url)]
[(or (string=? scheme "http") (string=? scheme "https")) [(or (string=? scheme "http") (string=? scheme "https"))
(define hc (http://getpost-impure-port get? url post-data strings make-ports #f)) (define hc
(http-conn-impure-port hc)] (http://getpost-impure-port get? url post-data strings make-ports #f))
(http-conn-impure-port hc
#:method (if get? "GET" "POST"))]
[(string=? scheme "file") [(string=? scheme "file")
(url-error "There are no impure file: ports")] (url-error "There are no impure file: ports")]
[else (url-error "Scheme ~a unsupported" scheme)]))) [else (url-error "Scheme ~a unsupported" scheme)])))
(define (http-conn-impure-port hc) (define (http-conn-impure-port hc
#:method [method-bss #"GET"])
(define-values (in out) (make-pipe 4096)) (define-values (in out) (make-pipe 4096))
(define-values (status headers response-port) (define-values (status headers response-port)
(hc:http-conn-recv! hc #:close? #t #:content-decode '())) (hc:http-conn-recv! hc #:method method-bss #:close? #t #:content-decode '()))
(fprintf out "~a\r\n" status) (fprintf out "~a\r\n" status)
(for ([h (in-list headers)]) (for ([h (in-list headers)])
(fprintf out "~a\r\n" h)) (fprintf out "~a\r\n" h))
@ -155,7 +159,8 @@
(http://getpost-impure-port (http://getpost-impure-port
get? url post-data strings get? url post-data strings
make-ports #f) make-ports #f)
#:content-decode '() #:method (if get? #"GET" #"POST")
#:content-decode '()
#:close? #t)) #:close? #t))
response-port] response-port]
[else [else
@ -187,7 +192,7 @@
make-ports) make-ports)
(and conn #t))) (and conn #t)))
(define-values (status headers response-port) (define-values (status headers response-port)
(hc:http-conn-recv! hc #:close? (not conn) #:content-decode '())) (hc:http-conn-recv! hc #:method #"GET" #:close? (not conn) #:content-decode '()))
(define new-url (define new-url
(ormap (λ (h) (ormap (λ (h)
@ -323,20 +328,28 @@
[else (url-error "unsupported method: ~a" method)])] [else (url-error "unsupported method: ~a" method)])]
[proxy (assoc (url-scheme url) (current-proxy-servers))] [proxy (assoc (url-scheme url) (current-proxy-servers))]
[hc (make-ports url proxy)] [hc (make-ports url proxy)]
[access-string (url->string [access-string
(if proxy (ensure-non-empty
url (url->string
(make-url #f #f #f #f (if proxy
(url-path-absolute? url) url
(url-path url) (make-url #f #f #f #f
(url-query url) (url-path-absolute? url)
(url-fragment url))))]) (url-path url)
(url-query url)
(url-fragment url)))))])
(hc:http-conn-send! hc access-string (hc:http-conn-send! hc access-string
#:method method #:method method
#:headers strings #:headers strings
#:content-decode '() #:content-decode '()
#:data data) #:data data)
(http-conn-impure-port hc))) (http-conn-impure-port hc
#:method method)))
(define (ensure-non-empty s)
(if (string=? "" s)
"/"
s))
(provide (all-from-out "url-string.rkt")) (provide (all-from-out "url-string.rkt"))
@ -394,12 +407,13 @@
(error 'http-sendrecv/url "Host required: ~e" u)) (error 'http-sendrecv/url "Host required: ~e" u))
(hc:http-sendrecv (hc:http-sendrecv
(url-host u) (url-host u)
(url->string (ensure-non-empty
(make-url #f #f #f #f (url->string
(url-path-absolute? u) (make-url #f #f #f #f
(url-path u) (url-path-absolute? u)
(url-query u) (url-path u)
(url-fragment u))) (url-query u)
(url-fragment u))))
#:ssl? #:ssl?
(if (equal? "https" (url-scheme u)) (if (equal? "https" (url-scheme u))
(current-https-protocol) (current-https-protocol)