diff --git a/collects/help/private/tcp-intercept.ss b/collects/help/private/tcp-intercept.ss index d1246f69a5..28657f4e0a 100644 --- a/collects/help/private/tcp-intercept.ss +++ b/collects/help/private/tcp-intercept.ss @@ -31,6 +31,12 @@ get-impure-port post-pure-port post-impure-port + head-pure-port + head-impure-port + put-pure-port + put-impure-port + delete-pure-port + delete-impure-port display-pure-port purify-port netscape/string->url diff --git a/collects/net/doc.txt b/collects/net/doc.txt index 3fff117a29..e64395718f 100644 --- a/collects/net/doc.txt +++ b/collects/net/doc.txt @@ -142,27 +142,49 @@ PROCEDURES ----------------------------------------------------------- decoded information. > (get-pure-port url [list-of-strings]) -> input-port +> (head-pure-port url [list-of-strings]) -> input-port +> (delete-pure-port url [list-of-strings]) -> input-port - Takes a URL and returns a pure port corresponding to it. Writes the - optional RFC 822 header-line strings to the server. For the "file" - scheme, uses open-input-file, does not handle exceptions, and + Takes a URL, initiates a GET/HEAD/DELETE request and returns a pure + port corresponding to the body of the response. The optional list of + strings can be used to send header-lines to the server. + + The GET method is used to retrieve whatever information is + identified by the url. + + The HEAD method is identical to GET, except the server must not + return a message body. The metainformation returned in a response to + a HEAD request should be identical to the information in a response + to a GET request. + + The DELETE method is used to delete the entity identified by the + url. + + The file:// scheme is handled only by get-pure-port, + which uses open-input-file, does not handle exceptions, and ignores the optional strings. +> (get-impure-port url [list-of-strings]) -> input-port +> (head-pure-port url [list-of-strings]) -> input-port +> (delete-pure-port url [list-of-strings]) -> input-port + + Like -pure-port above, but the port returned corresponds to + both the headers returned as well as the body. The file:// scheme is + handled by none of these functions. + > (post-pure-port url post-byte-string [list-of-strings]) -> input-port - - Like `get-pure-port', but issues a POST request (instead of a GET - request) to a web server using the given post data byte string. - -> (get-impure-port url [list-of-strings]) -> input-port - - Takes a URL and returns an impure port corresponding to it. Writes - the optional RFC 822 header-line strings to the server. There are - no impure ports with scheme "file". +> (put-pure-port url put-byte-string [list-of-strings]) -> input-port + + Takes a URL, initiates a POST/PUT request and sends the byte-string. + A pure port port corresponding to the body of the response is + returned. The optional list of strings can be used to send + header-lines to the server. > (post-impure-port url post-byte-string [list-of-strings]) -> input-port +> (put-impure-port url put-byte-string [list-of-strings]) -> input-port - Like `get-impure-port', but issues a POST request (instead of a GET - request) to a web server using the given post data string. + Like post-pure-port and put-pure-port above, but the port returned + corresponds to both the headers returned as well as the body. > (display-pure-port input-port) -> void diff --git a/collects/net/url-sig.ss b/collects/net/url-sig.ss index cf4269e316..3e61010307 100644 --- a/collects/net/url-sig.ss +++ b/collects/net/url-sig.ss @@ -3,6 +3,12 @@ get-impure-port post-pure-port post-impure-port + head-pure-port + head-impure-port + delete-pure-port + delete-impure-port + put-pure-port + put-impure-port display-pure-port purify-port netscape/string->url diff --git a/collects/net/url-unit.ss b/collects/net/url-unit.ss index 437ae4606f..8b3fc4d024 100644 --- a/collects/net/url-unit.ss +++ b/collects/net/url-unit.ss @@ -446,5 +446,105 @@ (if (null? strings) (apply string-append (reverse! r)) (loop (cdr strings) (list* (car strings) sep r))))])) + + ;; delete-pure-port : url [x list (str)] -> in-port + (define delete-pure-port + (case-lambda + [(url) (delete-pure-port url '())] + [(url strings) (method-pure-port 'delete url #f strings)])) + + ;; delete-impure-port : url [x list (str)] -> in-port + (define delete-impure-port + (case-lambda + [(url) (delete-impure-port url '())] + [(url strings) (method-impure-port 'delete url #f strings)])) + ;; head-pure-port : url [x list (str)] -> in-port + (define head-pure-port + (case-lambda + [(url) (head-pure-port url '())] + [(url strings) (method-pure-port 'head url #f strings)])) + + ;; head-impure-port : url [x list (str)] -> in-port + (define head-impure-port + (case-lambda + [(url) (head-impure-port url '())] + [(url strings) (method-impure-port 'head url #f strings)])) + + ;; put-pure-port : url bytes [x list (str)] -> in-port + (define put-pure-port + (case-lambda + [(url put-data) (put-pure-port url put-data '())] + [(url put-data strings) (method-pure-port 'put url put-data strings)])) + + ;; put-impure-port : url x bytes [x list (str)] -> in-port + (define put-impure-port + (case-lambda + [(url put-data) (put-impure-port url put-data '())] + [(url put-data strings) + (method-impure-port 'put url put-data strings)])) + + ;; method-impure-port : symbol x url x list (str) -> in-port + (define (method-impure-port method url data strings) + (let ([scheme (url-scheme url)]) + (cond [(not scheme) + (schemeless-url url)] + [(or (string=? scheme "http") + (string=? scheme "https")) + (http://method-impure-port method url data strings)] + [(string=? scheme "file") + (url-error "There are no impure file: ports")] + [else (url-error "Scheme ~a unsupported" scheme)]))) + + ;; method-pure-port : symbol x url x list (str) -> in-port + (define (method-pure-port method url data strings) + (let ([scheme (url-scheme url)]) + (cond [(not scheme) + (schemeless-url url)] + [(or (string=? scheme "http") + (string=? scheme "https")) + (let ([port (http://method-impure-port + method url data strings)]) + (with-handlers ([void (lambda (exn) + (close-input-port port) + (raise exn))]) + (purify-port port)) + port)] + [(string=? scheme "file") + (file://get-pure-port url)] + [else (url-error "Scheme ~a unsupported" scheme)]))) + + ;; 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) + (define (method->string method) + (case method + ((get) "GET") ((post) "POST") ((head) "HEAD") + ((put) "PUT") ((delete) "DELETE") + (else (url-error "unsupported method: ~a" method)))) + (let*-values + ([(proxy) (assoc (url-scheme url) (current-proxy-servers))] + [(server->client client->server) (make-ports url proxy)] + [(access-string) (url->string + (if proxy + url + (make-url #f #f #f #f + (url-path-absolute? url) + (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->string 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)) + + )) diff --git a/collects/net/url.ss b/collects/net/url.ss index cf26ac1af1..b0b311f0b4 100644 --- a/collects/net/url.ss +++ b/collects/net/url.ss @@ -32,6 +32,12 @@ (get-impure-port (opt-> (url?) ((listof string?)) input-port?)) (post-pure-port (opt-> (url? (or/c false/c bytes?)) ((listof string?)) input-port?)) (post-impure-port (opt-> (url? bytes?) ((listof string?)) input-port?)) + (head-pure-port (opt-> (url?) ((listof string?)) input-port?)) + (head-impure-port (opt-> (url?) ((listof string?)) input-port?)) + (delete-pure-port (opt-> (url?) ((listof string?)) input-port?)) + (delete-impure-port (opt-> (url?) ((listof string?)) input-port?)) + (put-pure-port (opt-> (url? (or/c false/c bytes?)) ((listof string?)) input-port?)) + (put-impure-port (opt-> (url? bytes?) ((listof string?)) input-port?)) (display-pure-port (input-port? . -> . void?)) (purify-port (input-port? . -> . string?)) (netscape/string->url (string? . -> . url?))