Added

head-pure-port,   delete-pure-port,   put-pure-port,
  head-impure-port, delete-impure-port, put-impure-port
to (lib "url.ss" "net").
Updated doc.txt.

  

svn: r5317

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

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
+  Takes a URL, initiates a GET/HEAD/DELETE request and returns a pure
-  optional RFC 822 header-line strings to the server.  For the "file"
+  port corresponding to the body of the response. The optional list of
-  scheme, uses open-input-file, does not handle exceptions, and
+  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 <method>-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
-
+> (put-pure-port  url put-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.
+  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
-> (get-impure-port url [list-of-strings]) -> input-port
+  returned.  The optional list of strings can be used to send
-
+  header-lines to the server.
-  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".
 
 > (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
+  Like post-pure-port and put-pure-port above, but the port returned
-  request) to a web server using the given post data string.
+  corresponds to both the headers returned as well as the body.
 
 > (display-pure-port input-port) -> void
 

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

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

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