diff --git a/pkgs/racket-pkgs/racket-doc/net/scribblings/http-client.scrbl b/pkgs/racket-pkgs/racket-doc/net/scribblings/http-client.scrbl new file mode 100644 index 0000000000..2334093cb3 --- /dev/null +++ b/pkgs/racket-pkgs/racket-doc/net/scribblings/http-client.scrbl @@ -0,0 +1,120 @@ +#lang scribble/doc +@(require "common.rkt" scribble/bnf + (for-label net/http-client + racket/list + openssl)) + +@title[#:tag "http-client"]{HTTP Client} + +@defmodule[net/http-client]{The @racketmodname[net/http-client] library provides +utilities to use the HTTP protocol.} + +@defproc[(http-conn? [x any/c]) + boolean?]{ + +Identifies an HTTP connection. + +} + +@defproc[(http-conn-live? [x any/c]) + boolean?]{ + +Identifies an HTTP connection that is "live", i.e. one for which +@racket[http-conn-send!] is valid. + +} + +@defproc[(http-conn) + http-conn?]{ + +Returns a fresh HTTP connection. + +} + +@defproc[(http-conn-open! [hc http-conn?] [host (or/c bytes? string?)] + [#:ssl? ssl? (or/c boolean? ssl-client-context? symbol?) #f] + [#:port port (between/c 1 65535) (if ssl? 443 80)]) + void?]{ + +Uses @racket[hc] to connect to @racket[host] on port @racket[port] +using SSL if @racket[ssl?] is not @racket[#f] (using @racket[ssl?] as +an argument to @racket[ssl-connect] to, for example, check +certificates.) + +If @racket[hc] is live, the connection is closed. + +} + +@defproc[(http-conn-open [host (or/c bytes? string?)] + [#:ssl? ssl? (or/c boolean? ssl-client-context? symbol?) #f] + [#:port port (between/c 1 65535) (if ssl? 443 80)]) + http-conn?]{ + +Calls @racket[http-conn-open!] with a fresh connection, which is returned. + +} + +@defproc[(http-conn-close! [hc http-conn?]) + void?]{ + +Closes @racket[hc] if it is live. + +} + +@defproc[(http-conn-send! [hc http-conn-live?] [uri (or/c bytes? string?)] + [#:method method (or/c bytes? string? symbol?) #"GET"] + [#:headers headers (listof (or/c bytes? string?)) empty] + [#:data data (or/c false/c bytes? string?) #f]) + void?]{ + +Sends an HTTP request to @racket[hc] to the URI @racket[uri] using the +method @racket[method] and the additional headers given in +@racket[headers] and the additional data @racket[data]. + +} + +@defproc[(http-conn-recv! [hc http-conn-live?] + [#:close? close? boolean? #f]) + (values bytes? (listof bytes?) input-port?)]{ + +Parses an HTTP response from @racket[hc]. + +Returns the status line, a list of headers, and an port which contains +the contents of the response. + +If @racket[close?] is @racket[#t], then the connection will be closed +following the response parsing. If @racket[close?] is @racket[#f], +then the connection is only closed if the server instructs the client +to do so. + +} + +@defproc[(http-conn-sendrecv! [hc http-conn-live?] [uri (or/c bytes? string?)] + [#:method method (or/c bytes? string? symbol?) #"GET"] + [#:headers headers (listof (or/c bytes? string?)) empty] + [#:data data (or/c false/c bytes? string?) #f] + [#:close? close? boolean? #f]) + (values bytes? (listof bytes?) input-port?)]{ + +Calls @racket[http-conn-send!] and @racket[http-conn-recv!] in sequence. + +} + +@defproc[(http-sendrecv [host (or/c bytes? string?)] [uri (or/c bytes? string?)] + [#:ssl? ssl? (or/c boolean? ssl-client-context? symbol?) #f] + [#:port port (between/c 1 65535) (if ssl? 443 80)] + [#:method method (or/c bytes? string? symbol?) #"GET"] + [#:headers headers (listof (or/c bytes? string?)) empty] + [#:data data (or/c false/c bytes? string?) #f]) + (values bytes? (listof bytes?) input-port?)]{ + +Calls @racket[http-conn-send!] and @racket[http-conn-recv!] in +sequence on a fresh HTTP connection produced by +@racket[http-conn-open]. + +The HTTP connection is not returned, so it is always closed after one +response, which is why there is no @racket[#:closed?] argument like +@racket[http-conn-recv!]. + +} + diff --git a/pkgs/racket-pkgs/racket-doc/net/scribblings/net.scrbl b/pkgs/racket-pkgs/racket-doc/net/scribblings/net.scrbl index c6e5d86566..dca5945502 100644 --- a/pkgs/racket-pkgs/racket-doc/net/scribblings/net.scrbl +++ b/pkgs/racket-pkgs/racket-doc/net/scribblings/net.scrbl @@ -5,6 +5,7 @@ @table-of-contents[] +@include-section["http-client.scrbl"] @include-section["url.scrbl"] @include-section["uri-codec.scrbl"] @include-section["websocket.scrbl"] diff --git a/pkgs/racket-pkgs/racket-doc/net/scribblings/url.scrbl b/pkgs/racket-pkgs/racket-doc/net/scribblings/url.scrbl index 9fe0a99c67..f6346d4b83 100644 --- a/pkgs/racket-pkgs/racket-doc/net/scribblings/url.scrbl +++ b/pkgs/racket-pkgs/racket-doc/net/scribblings/url.scrbl @@ -1,7 +1,9 @@ #lang scribble/doc @(require "common.rkt" scribble/bnf (for-label net/url net/url-unit net/url-sig + racket/list net/head net/uri-codec net/tcp-sig + net/http-client (only-in net/url-connect current-https-protocol) openssl)) @@ -428,6 +430,18 @@ mapping is the empty list (i.e., no proxies).} Identifies an error thrown by URL functions. } +@defproc[(http-sendrecv/url [u url?] + [#:method method (or/c bytes? string? symbol?) #"GET"] + [#:headers headers (listof (or/c bytes? string?)) empty] + [#:data data (or/c false/c bytes? string?) #f]) + (values bytes? (listof bytes?) input-port?)]{ + +Calls @racket[http-sendrecv] using @racket[u] to populate the host, URI, port, and SSL parameters. + +This function does not support proxies. + +} + @section{URL HTTPS mode} @defmodule[net/url-connect] diff --git a/pkgs/racket-pkgs/racket-test/tests/net/http-client.rkt b/pkgs/racket-pkgs/racket-test/tests/net/http-client.rkt new file mode 100644 index 0000000000..38778baab2 --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/net/http-client.rkt @@ -0,0 +1,146 @@ +#lang racket/base +(module+ test + (require rackunit + racket/tcp + racket/port + racket/list + (prefix-in hc: net/http-client) + (prefix-in u: net/url)) + + (define (port->bytes* in) + (define ob (open-output-bytes)) + (let loop () + (sleep) + (when (byte-ready? in) + (define b (read-byte in)) + (unless (eof-object? b) + (write-byte b ob) + (loop)))) + (get-output-bytes ob)) + + (define-syntax-rule (tests [t ...] ...) + (begin (test t ...) ...)) + + (define-syntax-rule (test-e the-port e raw ereq estatus eheaders econtent) + (let () + (define l (tcp-listen 0 40 #t "127.0.0.1")) + (define-values (_1 the-port _2 _3) + (tcp-addresses l #t)) + (define req #f) + (define lt + (thread + (λ () + (define-values (in out) (tcp-accept l)) + (tcp-close l) + (display raw out) + (flush-output out) + (tcp-abandon-port out) + (close-output-port out) + (set! req (port->bytes* in)) + (tcp-abandon-port in) + (close-input-port in)))) + (define-values (status headers content-port) + e) + (thread-wait lt) + (check-equal? req ereq) + (check-equal? status estatus) + (check-equal? headers eheaders) + (check-equal? (port->bytes content-port) econtent))) + + (define-syntax-rule (test raw ereq estatus eheaders econtent) + (begin + (test-e the-port + (hc:http-sendrecv "localhost" "/" + #:ssl? #f + #:port the-port + #:method "GET" + #:headers empty + #:data #f) + raw ereq estatus eheaders econtent) + (test-e the-port + (u:http-sendrecv/url + (u:make-url "http" #f "localhost" the-port #t (list (u:path/param "" empty)) empty #f) + #:method "GET" + #:headers empty + #:data #f) + raw ereq estatus eheaders econtent))) + + (tests + ["HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\nTransfer-Encoding: chunked\r\n\r\n24\r\nThis is the data in the first chunk \r\n1A\r\nand this is the second one\r\n0\r\n" + #"GET / HTTP/1.1\r\nHost: localhost\r\n\r\n" + #"HTTP/1.1 200 OK" + '(#"Content-Type: text/plain" #"Transfer-Encoding: chunked") + #"This is the data in the first chunk and this is the second one"] + + ["HTTP/1.0 200 OK\r\nContent-Type: text/plain\r\n\r\nThis is the data in the first chunk and this is the second one" + #"GET / HTTP/1.1\r\nHost: localhost\r\n\r\n" + #"HTTP/1.0 200 OK" + '(#"Content-Type: text/plain") + #"This is the data in the first chunk and this is the second one"] + + ["HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\nTransfer-Encoding: chunked\r\n\r\n20\r\nThis is the data in the first ch\r\n21\r\nand this is the second oneXXXXXXX\r\n0\r\n" + + #"GET / HTTP/1.1\r\nHost: localhost\r\n\r\n" + #"HTTP/1.1 200 OK" + '(#"Content-Type: text/plain" #"Transfer-Encoding: chunked") + #"This is the data in the first chand this is the second oneXXXXXXX"] + + ["HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\nTransfer-Encoding: chunked\r\n\r\n24\r\nThis is the data in the first chunk \r\n1A\r\nand this is the second one\r\n0\r\n" + #"GET / HTTP/1.1\r\nHost: localhost\r\n\r\n" + #"HTTP/1.1 200 OK" + '(#"Content-Type: text/plain" #"Transfer-Encoding: chunked") + #"This is the data in the first chunk and this is the second one"] + + ["HTTP/1.0 200 OK\r\nContent-Type: text/plain\r\n\r\nThis is the data in the first chunk and this is the second one" + #"GET / HTTP/1.1\r\nHost: localhost\r\n\r\n" + #"HTTP/1.0 200 OK" + '(#"Content-Type: text/plain") + #"This is the data in the first chunk and this is the second one"] + + ["HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\nTransfer-Encoding: chunked\r\n\r\n20\r\nThis is the data in the first ch\r\n21\r\nand this is the second oneXXXXXXX\r\n0\r\n" + #"GET / HTTP/1.1\r\nHost: localhost\r\n\r\n" + #"HTTP/1.1 200 OK" + '(#"Content-Type: text/plain" #"Transfer-Encoding: chunked") + #"This is the data in the first chand this is the second oneXXXXXXX"] + + ["HTTP/1.0 200 OK\r\nContent-Type: text/plain\r\n\r\nThis is the data in the first chunk and this is the second one\r\n" + #"GET / HTTP/1.1\r\nHost: localhost\r\n\r\n" + #"HTTP/1.0 200 OK" + '(#"Content-Type: text/plain") + #"This is the data in the first chunk and this is the second one\r\n"] + + ["HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\nTransfer-Encoding: chunked\r\n\r\n24\r\nThis is the data in the first chunk \r\n1A\r\nand this is the second one\r\n0\r\n" + #"GET / HTTP/1.1\r\nHost: localhost\r\n\r\n" + #"HTTP/1.1 200 OK" + '(#"Content-Type: text/plain" #"Transfer-Encoding: chunked") + #"This is the data in the first chunk and this is the second one"] + + ["HTTP/1.0 200 OK\r\nContent-Type: text/plain\r\n\r\nThis is the data in the first chunk and this is the second one" + #"GET / HTTP/1.1\r\nHost: localhost\r\n\r\n" + #"HTTP/1.0 200 OK" + '(#"Content-Type: text/plain") + #"This is the data in the first chunk and this is the second one"] + + ["HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\nTransfer-Encoding: chunked\r\n\r\n20\r\nThis is the data in the first ch\r\n21\r\nand this is the second oneXXXXXXX\r\n0\r\n" + #"GET / HTTP/1.1\r\nHost: localhost\r\n\r\n" + #"HTTP/1.1 200 OK" + '(#"Content-Type: text/plain" #"Transfer-Encoding: chunked") + #"This is the data in the first chand this is the second oneXXXXXXX"] + + ["HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\nTransfer-Encoding: chunked\r\nAnother-Header: ta-daa\r\n\r\n20\r\nThis is the data in the first ch\r\n21\r\nand this is the second oneXXXXXXX\r\n0\r\n" + #"GET / HTTP/1.1\r\nHost: localhost\r\n\r\n" + #"HTTP/1.1 200 OK" + '(#"Content-Type: text/plain" #"Transfer-Encoding: chunked" #"Another-Header: ta-daa") + #"This is the data in the first chand this is the second oneXXXXXXX"] + + ["HTTP/1.1 301 Moved Permanently\r\nLocation: http://localhost:9002/whatever\r\n\r\nstuff" + #"GET / HTTP/1.1\r\nHost: localhost\r\n\r\n" + #"HTTP/1.1 301 Moved Permanently" + '(#"Location: http://localhost:9002/whatever") + #"stuff"] + + ["HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\nTransfer-Encoding: chunked\r\nAnother-Header: ta-daa\r\n\r\n20\r\nThis is the data in the first ch\r\n21\r\nand this is the second oneXXXXXXX\r\n0\r\n" + #"GET / HTTP/1.1\r\nHost: localhost\r\n\r\n" + #"HTTP/1.1 200 OK" + '(#"Content-Type: text/plain" #"Transfer-Encoding: chunked" #"Another-Header: ta-daa") + #"This is the data in the first chand this is the second oneXXXXXXX"])) diff --git a/racket/collects/net/http-client.rkt b/racket/collects/net/http-client.rkt new file mode 100644 index 0000000000..a81dcfa2bc --- /dev/null +++ b/racket/collects/net/http-client.rkt @@ -0,0 +1,255 @@ +#lang racket/base +(require racket/contract/base + racket/match + racket/list + racket/port + (rename-in racket/tcp + [tcp-connect plain-tcp-connect] + [tcp-abandon-port plain-tcp-abandon-port]) + openssl + "win32-ssl.rkt") + +;; Lib + +(define (->string bs) + (if (bytes? bs) + (bytes->string/utf-8 bs) + bs)) + +(define (read-bytes-line/not-eof ip kind) + (define bs (read-bytes-line ip kind)) + (when (eof-object? bs) + (error 'http-client "Connection ended early")) + bs) + +;; Core + +(struct http-conn (host to from abandon-p) #:mutable) + +(define (make-http-conn) + (http-conn #f #f #f #f)) + +(define (http-conn-live? hc) + (and (http-conn-to hc) + (http-conn-from hc))) + +(define (http-conn-open! hc host-bs #:ssl? [ssl? #f] #:port [port (if ssl? 443 80)]) + (http-conn-close! hc) + (define host (->string host-bs)) + (define ssl-version (if (boolean? ssl?) 'sslv2-or-v3 ssl?)) + + (define-values (from to) + (cond [ssl? + (cond + [(or ssl-available? (not win32-ssl-available?)) + (set-http-conn-abandon-p! hc ssl-abandon-port) + (ssl-connect host port ssl-version)] + [else + (set-http-conn-abandon-p! hc win32-ssl-abandon-port) + (win32-ssl-connect host port ssl-version)])] + [else + (set-http-conn-abandon-p! hc plain-tcp-abandon-port) + (plain-tcp-connect host port)])) + + (set-http-conn-host! hc host) + (set-http-conn-to! hc to) + (set-http-conn-from! hc from)) + +(define (http-conn-close! hc) + (match-define (http-conn host to from abandon) hc) + (set-http-conn-host! hc #f) + (when to + (abandon to) + (set-http-conn-to! hc #f)) + (when from + ;; (abandon from) + (set-http-conn-from! hc #f)) + (set-http-conn-abandon-p! hc #f)) + +(define (http-conn-send! hc url-bs + #:method [method-bss #"GET"] + #:headers [headers-bs empty] + #:data [data-bsf #f]) + (match-define (http-conn host to from _) hc) + (fprintf to "~a ~a HTTP/1.1\r\n" method-bss url-bs) + (fprintf to "Host: ~a\r\n" host) + (define data + (if (string? data-bsf) + (string->bytes/utf-8 data-bsf) + data-bsf)) + (when data + (fprintf to "Content-Length: ~a\r\n" (bytes-length data))) + (for ([h (in-list headers-bs)]) + (fprintf to "~a\r\n" h)) + (fprintf to "\r\n") + (when data + (display data to)) + (flush-output to)) + +(define (http-conn-status! hc) + (read-bytes-line/not-eof (http-conn-from hc) 'return-linefeed)) + +(define (http-conn-headers! hc) + (define top (read-bytes-line/not-eof (http-conn-from hc) 'return-linefeed)) + (if (bytes=? top #"") + empty + (cons top (http-conn-headers! hc)))) + +;; xxx read more at a time +(define (copy-bytes in out count) + (unless (zero? count) + (define b (read-byte in)) + (unless (eof-object? b) + (write-byte b out) + (copy-bytes in out (sub1 count))))) + +(define (http-conn-response-port/rest! hc) + (http-conn-response-port/length! hc +inf.0 #:close? #t)) + +(define (http-conn-response-port/length! hc count #:close? [close? #f]) + (define-values (in out) (make-pipe)) + (thread + (λ () + (copy-bytes (http-conn-from hc) out count) + (when close? + (http-conn-close! hc)) + (close-output-port out))) + in) + +(define (http-conn-response-port/chunked! hc #:close? [close? #f]) + (define (http-pipe-chunk ip op) + (define crlf-bytes (make-bytes 2)) + (let loop ([last-bytes #f]) + (define size-str (read-line ip 'return-linefeed)) + (define chunk-size (string->number size-str 16)) + (unless chunk-size + (error 'http-conn-response/chunked "Could not parse ~S as hexadecimal number" size-str)) + (define use-last-bytes? + (and last-bytes (<= chunk-size (bytes-length last-bytes)))) + (if (zero? chunk-size) + (begin (flush-output op) + (close-output-port op)) + (let* ([bs (if use-last-bytes? + (begin + (read-bytes! last-bytes ip 0 chunk-size) + 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)) + (thread + (λ () + (http-pipe-chunk (http-conn-from hc) out) + (when close? + (http-conn-close! hc)) + (close-output-port out))) + in) + +;; Derived + +(define (http-conn-open host-bs #:ssl? [ssl? #f] #:port [port (if ssl? 443 80)]) + (define hc (make-http-conn)) + (http-conn-open! hc host-bs #:ssl? ssl? #:port port) + hc) + +(define (http-conn-recv! hc + #:close? [iclose? #f]) + (define status (http-conn-status! hc)) + (define headers (http-conn-headers! hc)) + (define close? + (or iclose? + (member #"Connection: close" headers))) + (define response-port + (cond + [(member #"Transfer-Encoding: chunked" headers) + (http-conn-response-port/chunked! hc #:close? #t)] + [(ormap (λ (h) + (match (regexp-match #rx#"^Content-Length: (.+)$" h) + [#f #f] + [(list _ cl-bs) + (string->number + (bytes->string/utf-8 cl-bs))])) + headers) + => + (λ (count) + (http-conn-response-port/length! hc count #:close? close?))] + [else + (http-conn-response-port/rest! hc)])) + (values status headers response-port)) + +(define (http-conn-sendrecv! hc url-bs + #:method [method-bss #"GET"] + #:headers [headers-bs empty] + #:data [data-bsf #f] + #:close? [close? #f]) + (http-conn-send! hc url-bs + #:method method-bss + #:headers headers-bs + #:data data-bsf) + (http-conn-recv! hc #:close? close?)) + +(define (http-sendrecv host-bs url-bs + #:ssl? [ssl? #f] + #:port [port (if ssl? 443 80)] + #:method [method-bss #"GET"] + #:headers [headers-bs empty] + #:data [data-bsf #f]) + (define hc (http-conn-open host-bs #:ssl? ssl? #:port port)) + (http-conn-sendrecv! hc url-bs + #:method method-bss + #:headers headers-bs + #:data data-bsf + #:close? #t)) + +(provide + (contract-out + [http-conn? + (-> any/c + boolean?)] + [http-conn-live? + (-> any/c + boolean?)] + [rename + make-http-conn http-conn + (-> http-conn?)] + [http-conn-open! + (->* (http-conn? (or/c bytes? string?)) + (#:ssl? (or/c boolean? ssl-client-context? symbol?) + #:port (between/c 1 65535)) + void?)] + [http-conn-close! + (-> http-conn? void?)] + [http-conn-send! + (->* + (http-conn-live? (or/c bytes? string?)) + (#:method (or/c bytes? string? symbol?) + #:headers (listof (or/c bytes? string?)) + #:data (or/c false/c bytes? string?)) + void)] + ;; Derived + [http-conn-open + (->* ((or/c bytes? string?)) + (#:ssl? (or/c boolean? ssl-client-context? symbol?) + #:port (between/c 1 65535)) + http-conn?)] + [http-conn-recv! + (->* (http-conn-live?) + (#:close? boolean?) + (values bytes? (listof bytes?) input-port?))] + [http-conn-sendrecv! + (->* (http-conn-live? (or/c bytes? string?)) + (#:method (or/c bytes? string? symbol?) + #:headers (listof (or/c bytes? string?)) + #:data (or/c false/c bytes? string?) + #:close? boolean?) + (values bytes? (listof bytes?) input-port?))] + [http-sendrecv + (->* ((or/c bytes? string?) (or/c bytes? string?)) + (#:ssl? (or/c boolean? ssl-client-context? symbol?) + #:port (between/c 1 65535) + #:method (or/c bytes? string? symbol?) + #:headers (listof (or/c bytes? string?)) + #:data (or/c false/c bytes? string?)) + (values bytes? (listof bytes?) input-port?))])) diff --git a/racket/collects/net/url.rkt b/racket/collects/net/url.rkt index cf2a318535..cf262ff2bd 100644 --- a/racket/collects/net/url.rkt +++ b/racket/collects/net/url.rkt @@ -1,7 +1,11 @@ #lang racket/base -(require racket/port racket/string racket/contract/base +(require racket/port + racket/string + racket/contract/base racket/list - "url-connect.rkt" + racket/match + (prefix-in hc: "http-client.rkt") + (only-in "url-connect.rkt" current-https-protocol) "url-structs.rkt" "uri-codec.rkt") @@ -21,7 +25,7 @@ (define-struct (url-exception exn:fail) ()) (define (-url-exception? x) (or (url-exception? x) - + ;; two of the errors that string->url can raise are ;; now contract violations instead of url-expcetion ;; structs. since only the url-exception? predicate @@ -34,25 +38,25 @@ (define current-proxy-servers (make-parameter null - (lambda (v) - (unless (and (list? v) - (andmap (lambda (v) - (and (list? v) - (= 3 (length v)) - (equal? (car v) "http") - (string? (car v)) - (exact-integer? (caddr v)) - (<= 1 (caddr v) 65535))) - v)) - (raise-type-error - 'current-proxy-servers - "list of list of scheme, string, and exact integer in [1,65535]" - v)) - (map (lambda (v) - (list (string->immutable-string (car v)) - (string->immutable-string (cadr v)) - (caddr v))) - v)))) + (lambda (v) + (unless (and (list? v) + (andmap (lambda (v) + (and (list? v) + (= 3 (length v)) + (equal? (car v) "http") + (string? (car v)) + (exact-integer? (caddr v)) + (<= 1 (caddr v) 65535))) + v)) + (raise-type-error + 'current-proxy-servers + "list of list of scheme, string, and exact integer in [1,65535]" + v)) + (map (lambda (v) + (list (string->immutable-string (car v)) + (string->immutable-string (cadr v)) + (caddr v))) + v)))) (define (url-error fmt . args) (raise (make-url-exception @@ -74,12 +78,12 @@ (apply string-append (let loop ([l l]) (cond - [(null? l) l] - [(pair? (car l)) - (append (loop (car l)) - (loop (cdr l)))] - [(null? (car l)) (loop (cdr l))] - [else (cons (car l) (loop (cdr l)))]))))]) + [(null? l) l] + [(pair? (car l)) + (append (loop (car l)) + (loop (cdr l)))] + [(null? (car l)) (loop (cdr l))] + [else (cons (car l) (loop (cdr l)))]))))]) (when (and (equal? scheme "file") (not (url-path-absolute? url))) (raise-mismatch-error 'url->string @@ -89,13 +93,13 @@ (append (if scheme (sa scheme ":") null) (if (or user host port) - (sa "//" - (if user (sa (uri-userinfo-encode user) "@") null) - (if host host null) - (if port (sa ":" (number->string port)) null)) - (if (equal? "file" scheme) ; always need "//" for "file" URLs - '("//") - null)) + (sa "//" + (if user (sa (uri-userinfo-encode user) "@") null) + (if host host null) + (if port (sa ":" (number->string port)) null)) + (if (equal? "file" scheme) ; always need "//" for "file" URLs + '("//") + null)) (combine-path-strings (url-path-absolute? url) path) ;; (if query (sa "?" (uri-encode query)) "") (if (null? query) null (sa "?" (alist->form-urlencoded query))) @@ -109,21 +113,24 @@ [(string=? scheme "https") 443] [else (url-error "URL scheme ~s not supported" scheme)]))) -;; make-ports : url -> in-port x out-port +;; make-ports : url -> hc (define (make-ports url proxy) (let ([port-number (if proxy (caddr proxy) (or (url-port url) (url->default-port url)))] [host (if proxy (cadr proxy) (url-host url))]) - (parameterize ([current-connect-scheme (url-scheme url)]) - (tcp-connect host port-number)))) + (hc:http-conn-open host + #:port port-number + #:ssl? (if (equal? "https" (url-scheme url)) + (current-https-protocol) + #f)))) ;; http://getpost-impure-port : bool x url x union (str, #f) x list (str) -; -> (values in-port out-port) + ; -> hc (define (http://getpost-impure-port get? url post-data strings make-ports 1.1?) (define proxy (assoc (url-scheme url) (current-proxy-servers))) - (define-values (server->client client->server) (make-ports url proxy)) + (define hc (make-ports url proxy)) (define access-string (url->string (if proxy @@ -136,20 +143,12 @@ (values #t (list (make-path/param "" '()))) (values (url-path-absolute? url) (url-path url)))]) (make-url #f #f #f #f abs? path (url-query url) (url-fragment url)))))) - (define (println . xs) - (for-each (lambda (x) (display x client->server)) xs) - (display "\r\n" client->server)) - (println (if get? "GET " "POST ") access-string " HTTP/1." (if 1.1? "1" "0")) - (println "Host: " (url-host url) - (let ([p (url-port url)]) (if p (format ":~a" p) ""))) - (when post-data (println "Content-Length: " (bytes-length post-data))) - (for-each println strings) - (println) - (when post-data (display post-data client->server)) - (flush-output client->server) - (unless 1.1? - (tcp-abandon-port client->server)) - (values server->client client->server)) + + (hc:http-conn-send! hc access-string + #:method (if get? "GET" "POST") + #:headers strings + #:data post-data) + hc) (define (file://->path url [kind (system-path-convention-type)]) (let ([strs (map path/param-path (url-path url))] @@ -196,12 +195,25 @@ (cond [(not scheme) (schemeless-url url)] [(or (string=? scheme "http") (string=? scheme "https")) - (define-values (s->c c->s) (http://getpost-impure-port get? url post-data strings make-ports #f)) - s->c] + (define hc (http://getpost-impure-port get? url post-data strings make-ports #f)) + (http-conn-impure-port hc)] [(string=? scheme "file") (url-error "There are no impure file: ports")] [else (url-error "Scheme ~a unsupported" scheme)]))) +(define (http-conn-impure-port hc) + (define-values (in out) (make-pipe)) + (define-values (status headers response-port) (hc:http-conn-recv! hc)) + (fprintf out "~a\r\n" status) + (for ([h (in-list headers)]) + (fprintf out "~a\r\n" h)) + (fprintf out "\r\n") + (thread + (λ () + (copy-port response-port out) + (close-output-port out))) + in) + ;; get-impure-port : url [x list (str)] -> in-port (define (get-impure-port url [strings '()]) (getpost-impure-port #t url #f strings)) @@ -218,108 +230,77 @@ [(or (string=? scheme "http") (string=? scheme "https")) (cond - [(or (not get?) + [(or (not get?) ;; do not follow redirections for POST (zero? redirections)) - (let-values ([(s->c c->s) (http://getpost-impure-port - get? url post-data strings - make-ports #f)]) - (purify-http-port s->c))] + (define-values (status headers response-port) + (hc:http-conn-recv! + (http://getpost-impure-port + get? url post-data strings + make-ports #f))) + response-port] [else - (define-values (port header) + (define-values (port header) (get-pure-port/headers url strings #:redirections redirections)) port])] [(string=? scheme "file") (file://get-pure-port url)] [else (url-error "Scheme ~a unsupported" scheme)]))) -(struct http-connection (s->c c->s) - #:mutable) +(define (make-http-connection) + (hc:http-conn)) -(define (make-http-connection) (http-connection #f #f)) +(define (http-connection-close hc) + (hc:http-conn-close! hc)) -(define (http-connection-close conn) - (when (http-connection-c->s conn) - (tcp-abandon-port (http-connection-c->s conn)) - (set-http-connection-c->s! conn #f) - (close-input-port (http-connection-s->c conn)) - (set-http-connection-s->c! conn #f))) - -(define (get-pure-port/headers url [strings '()] +(define (get-pure-port/headers url [strings '()] #:redirections [redirections 0] #:status? [status? #f] #:connection [conn #f]) (let redirection-loop ([redirections redirections] [url url] [use-conn conn]) - (define-values (ip op) - (http://getpost-impure-port #t url #f strings + (define hc + (http://getpost-impure-port #t url #f strings (if (and use-conn - (http-connection-s->c use-conn)) - (lambda (url proxy) - (log-net/url-debug "reusing connection") - (values (http-connection-s->c use-conn) - (http-connection-c->s use-conn))) - make-ports) + (hc:http-conn-live? use-conn)) + (lambda (url proxy) + (log-net/url-debug "reusing connection") + use-conn) + make-ports) (and conn #t))) - (define status (read-line ip 'return-linefeed)) - (define-values (new-url chunked? close? headers) - (let loop ([new-url #f] [chunked? #f] [close? #f] [headers '()]) - (define line (read-line ip 'return-linefeed)) - (when (eof-object? line) - (error 'getpost-pure-port - "connection ended before headers ended")) - (cond - [(equal? line "") (values new-url chunked? close? headers)] - [(equal? chunked-header-line line) (loop new-url #t close? (cons line headers))] - [(equal? close-header-line line) (loop new-url chunked? #t (cons line headers))] - [(regexp-match #rx"^Location: (.*)$" line) - => - (λ (m) - (define m1 (list-ref m 1)) - (define next-url - (with-handlers ((exn:fail? (λ (x) #f))) - (define next-url (string->url m1)) - (make-url - (or (url-scheme next-url) (url-scheme url)) - (or (url-user next-url) (url-user url)) - (or (url-host next-url) (url-host url)) - (or (url-port next-url) (url-port url)) - (url-path-absolute? next-url) - (url-path next-url) - (url-query next-url) - (url-fragment next-url)))) - (loop (or next-url new-url) chunked? close? (cons line headers)))] - [else (loop new-url chunked? close? (cons line headers))]))) + (define-values (status headers response-port) + (hc:http-conn-recv! hc)) + + (define new-url + (ormap (λ (h) + (match (regexp-match #rx#"^Location: (.*)$" h) + [#f #f] + [(list _ m1b) + (define m1 (bytes->string/utf-8 m1b)) + (with-handlers ((exn:fail? (λ (x) #f))) + (define next-url (string->url m1)) + (make-url + (or (url-scheme next-url) (url-scheme url)) + (or (url-user next-url) (url-user url)) + (or (url-host next-url) (url-host url)) + (or (url-port next-url) (url-port url)) + (url-path-absolute? next-url) + (url-path next-url) + (url-query next-url) + (url-fragment next-url)))])) + headers)) (define redirection-status-line? - (regexp-match #rx"^HTTP/[0-9]+[.][0-9]+ 3[0-9][0-9]" status)) - (define (close-ip) - (unless (and use-conn (not close?)) - (close-input-port ip))) - (when use-conn - (if close? - (begin - (log-net/url-info "connection closed by server") - (tcp-abandon-port op) - (set-http-connection-s->c! use-conn #f) - (set-http-connection-c->s! use-conn #f)) - (begin - (set-http-connection-s->c! use-conn ip) - (set-http-connection-c->s! use-conn op)))) + (regexp-match #rx#"^HTTP/[0-9]+[.][0-9]+ 3[0-9][0-9]" status)) (cond - [(and redirection-status-line? new-url (not (zero? redirections))) - (close-ip) + [(and redirection-status-line? new-url (not (zero? redirections))) (log-net/url-info "redirection: ~a" (url->string new-url)) (redirection-loop (- redirections 1) new-url #f)] [else - (define-values (in-pipe out-pipe) (make-pipe)) - (thread - (λ () - (http-pipe-data chunked? ip out-pipe) - (close-ip))) - (values in-pipe - (apply string-append (map (λ (x) (string-append x "\r\n")) - (if status? - (cons status (reverse headers)) - (reverse headers)))))]))) + (values response-port + (apply string-append + (map (λ (x) (format "~a\r\n" x)) + (if status? + (cons status headers) + headers))))]))) ;; get-pure-port : url [x list (str)] -> in-port (define (get-pure-port url [strings '()] #:redirections [redirections 0]) @@ -423,8 +404,8 @@ (let ([handle-port (lambda (server->client handler) (dynamic-wind (lambda () 'do-nothing) - (lambda () (handler server->client)) - (lambda () (close-input-port server->client))))]) + (lambda () (handler server->client)) + (lambda () (close-input-port server->client))))]) (case-lambda [(url getter handler) (handle-port (getter url) handler)] @@ -457,11 +438,11 @@ (when (eof-object? l) (error 'purify-http-port "Connection ended before headers ended")) (if (string=? l "") - #f - (if (string=? l chunked-header-line) - (begin (http-read-headers ip) - #t) - (http-read-headers ip)))) + #f + (if (string=? l chunked-header-line) + (begin (http-read-headers ip) + #t) + (http-read-headers ip)))) (define chunked-header-line "Transfer-Encoding: chunked") (define close-header-line "Connection: close") @@ -470,11 +451,11 @@ (with-handlers ([exn:fail? (lambda (exn) (log-net/url-error (exn-message exn)))]) (if chunked? - (http-pipe-chunk ip op) - (begin - (copy-port ip op) - (flush-output op) - (close-output-port op))))) + (http-pipe-chunk ip op) + (begin + (copy-port ip op) + (flush-output op) + (close-output-port op))))) (define (http-pipe-chunk ip op) (define crlf-bytes (make-bytes 2)) @@ -486,16 +467,16 @@ (define use-last-bytes? (and last-bytes (<= chunk-size (bytes-length last-bytes)))) (if (zero? chunk-size) - (begin (flush-output op) - (close-output-port op)) - (let* ([bs (if use-last-bytes? - (begin - (read-bytes! last-bytes ip 0 chunk-size) - last-bytes) - (read-bytes chunk-size ip))] - [crlf (read-bytes! crlf-bytes ip 0 2)]) - (write-bytes bs op 0 chunk-size) - (loop bs))))) + (begin (flush-output op) + (close-output-port op)) + (let* ([bs (if use-last-bytes? + (begin + (read-bytes! last-bytes ip 0 chunk-size) + 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 character-set-size 256) @@ -506,7 +487,7 @@ [(string=? string "") (url-error "Can't resolve empty string as URL")] [else (set-url-scheme! url - (if (char=? (string-ref string 0) #\/) "file" "http")) + (if (char=? (string-ref string 0) #\/) "file" "http")) url]))) ;; URL parsing regexp @@ -610,10 +591,10 @@ (define (join-params s) (if (null? (path/param-param s)) - (path-segment-encode (path/param-path s)) - (string-join (map path-segment-encode - (cons (path/param-path s) (path/param-param s))) - ";"))) + (path-segment-encode (path/param-path s)) + (string-join (map path-segment-encode + (cons (path/param-path s) (path/param-param s))) + ";"))) (define (path->url path) (let* ([spath (simplify-path path #f)] @@ -627,41 +608,41 @@ (cond [(not base) (if (eq? (path-convention-type path) 'windows) - ;; For Windows, massage the root: - (append (map - (lambda (s) - (make-path/param s null)) - (let ([s (regexp-replace - #rx"[/\\\\]$" - (bytes->string/utf-8 (path->bytes name)) - "")]) - (cond - [(regexp-match? #rx"^\\\\\\\\[?]\\\\[a-zA-Z]:" s) - ;; \\?\: path: - (regexp-split #rx"[/\\]+" (substring s 4))] - [(regexp-match? #rx"^\\\\\\\\[?]\\\\UNC" s) - ;; \\?\ UNC path: - (regexp-split #rx"[/\\]+" (substring s 7))] - [(regexp-match? #rx"^[/\\]" s) - ;; UNC path: - (regexp-split #rx"[/\\]+" s)] - [else - (list s)]))) - accum) - ;; On other platforms, we drop the root: - accum)] + ;; For Windows, massage the root: + (append (map + (lambda (s) + (make-path/param s null)) + (let ([s (regexp-replace + #rx"[/\\\\]$" + (bytes->string/utf-8 (path->bytes name)) + "")]) + (cond + [(regexp-match? #rx"^\\\\\\\\[?]\\\\[a-zA-Z]:" s) + ;; \\?\: path: + (regexp-split #rx"[/\\]+" (substring s 4))] + [(regexp-match? #rx"^\\\\\\\\[?]\\\\UNC" s) + ;; \\?\ UNC path: + (regexp-split #rx"[/\\]+" (substring s 7))] + [(regexp-match? #rx"^[/\\]" s) + ;; UNC path: + (regexp-split #rx"[/\\]+" s)] + [else + (list s)]))) + accum) + ;; On other platforms, we drop the root: + accum)] [else (let ([accum (cons (make-path/param (if (symbol? name) - name - (bytes->string/utf-8 - (path-element->bytes name))) + name + (bytes->string/utf-8 + (path-element->bytes name))) null) accum)]) (if (eq? base 'relative) - accum - (loop base accum)))])))]) - (make-url "file" #f "" #f (absolute-path? path) + accum + (loop base accum)))])))]) + (make-url "file" #f "" #f (absolute-path? path) (if (null? url-tail) url-path (append url-path url-tail)) '() #f))) @@ -719,14 +700,13 @@ ;; http://metod-impure-port : symbol x url x union (str, #f) x list (str) -> in-port (define (http://method-impure-port method url data strings) - (let*-values - ([(method) (case method + (let* ([method (case method [(get) "GET"] [(post) "POST"] [(head) "HEAD"] [(put) "PUT"] [(delete) "DELETE"] [else (url-error "unsupported method: ~a" method)])] - [(proxy) (assoc (url-scheme url) (current-proxy-servers))] - [(server->client client->server) (make-ports url proxy)] - [(access-string) (url->string + [proxy (assoc (url-scheme url) (current-proxy-servers))] + [hc (make-ports url proxy)] + [access-string (url->string (if proxy url (make-url #f #f #f #f @@ -734,19 +714,11 @@ (url-path url) (url-query url) (url-fragment url))))]) - (define (println . xs) - (for-each (lambda (x) (display x client->server)) xs) - (display "\r\n" client->server)) - (println method " " access-string " HTTP/1.0") - (println "Host: " (url-host url) - (let ([p (url-port url)]) (if p (format ":~a" p) ""))) - (when data (println "Content-Length: " (bytes-length data))) - (for-each println strings) - (println) - (when data (display data client->server)) - (flush-output client->server) - (tcp-abandon-port client->server) - server->client)) + (hc:http-conn-send! hc access-string + #:method method + #:headers strings + #:data data) + hc)) (define current-url-encode-mode (make-parameter 'recommended)) @@ -783,15 +755,15 @@ (put-impure-port (->* (url? bytes?) ((listof string?)) input-port?)) (display-pure-port (input-port? . -> . void?)) (purify-port (input-port? . -> . string?)) - (get-pure-port/headers (->* (url?) - ((listof string?) - #:redirections exact-nonnegative-integer? + (get-pure-port/headers (->* (url?) + ((listof string?) + #:redirections exact-nonnegative-integer? #:status? boolean? - #:connection (or/c #f http-connection?)) + #:connection (or/c #f hc:http-conn?)) (values input-port? string?))) - (http-connection? (any/c . -> . boolean?)) - (make-http-connection (-> http-connection?)) - (http-connection-close (http-connection? . -> . void?)) + (rename hc:http-conn? http-connection? (any/c . -> . boolean?)) + (make-http-connection (-> hc:http-conn?)) + (http-connection-close (hc:http-conn? . -> . void?)) (netscape/string->url (string? . -> . url?)) (call/input-url (case-> (-> url? (-> url? input-port?) @@ -809,3 +781,44 @@ (file-url-path-convention-type (parameter/c (one-of/c 'unix 'windows))) (current-url-encode-mode (parameter/c (one-of/c 'recommended 'unreserved)))) + +(define (http-sendrecv/url u + #:method [method-bss #"GET"] + #:headers [headers-bs empty] + #:data [data-bsf #f]) + (unless (member (url-scheme u) '(#f "http" "https")) + (error 'http-sendrecv/url "URL scheme ~e not supported" (url-scheme u))) + (define ssl? + (equal? (url-scheme u) "https")) + (define port + (or (url-port u) + (if ssl? + 443 + 80))) + (unless (url-host u) + (error 'http-sendrecv/url "Host required: ~e" u)) + (hc:http-sendrecv + (url-host u) + (url->string + (make-url #f #f #f #f + (url-path-absolute? u) + (url-path u) + (url-query u) + (url-fragment u))) + #:ssl? + (if (equal? "https" (url-scheme u)) + (current-https-protocol) + #f) + #:port port + #:method method-bss + #:headers headers-bs + #:data data-bsf)) + +(provide + (contract-out + [http-sendrecv/url + (->* (url?) + (#:method (or/c bytes? string? symbol?) + #:headers (listof (or/c bytes? string?)) + #:data (or/c false/c bytes? string?)) + (values bytes? (listof bytes?) input-port?))]))