Changeset 15112 in project

Timestamp:

06/29/09 23:41:59 (12 years ago)

Author:

sjamaan

Message:

Add POST regular formdata support

File:

• release/4/http-client/trunk/http-client.scm (modified) (2 diffs)

release/4/http-client/trunk/http-client.scm

@@ -147 +147 @@
 (define (add-headers req)
   (let* ((uri (request-uri req))
-         (h `((cookie . ,(get-cookies-for-uri (request-uri req)))
+         (cookies (get-cookies-for-uri (request-uri req)))
+         (h `(,@(if (not (null? cookies)) `((cookie . ,cookies)) '())
               (host ,(cons (uri-host uri) (uri-port uri)))
               (user-agent ,(client-software)))))
@@ -255 +256 @@
               (header-contents 'set-cookie2 (response-headers r) '()))))
 
-(define (call-with-response uri-or-request proc1 #!optional proc2)
-  (let* ((writer (if proc2 proc1 (lambda x (void))))
-         (reader (if proc2 proc2 proc1))
+(define (call-with-response req writer reader)
+  (let loop ((attempts 0)
+             (redirects 0)
+             (uri (request-uri req)))
+    (condition-case
+     (let* ((con (ensure-connection! uri))
+            (req (add-headers (update-request
+                               req port: (http-connection-outport con)
+                               uri: uri)))
+            (request (write-request req))
+            ;; Writer should be prepared to be called several times
+            ;; Maybe try and figure out a good way to use the
+            ;; "Expect: 100-continue" header to prevent too much writing?
+            ;; Unfortunately RFC2616 says it's unreliable (8.2.3)...
+            (_ (writer request))
+            (response (read-response (http-connection-inport con)))
+            (cleanup! (lambda ()
+                        (unless (and (keep-alive? request)
+                                     (keep-alive? response))
+                          (close-connection! con)))))
+       (process-set-cookie! con uri response)
+       (cond
+        ;; TODO: According to spec, we should provide the user with a choice
+        ;; when it's not a GET or HEAD request...
+        ((member (response-code response) '(301 302 303 307))
+         ;; Clear out data, throwing it away
+         (read-response-data response)
+         (cleanup!)
+         ;; Maybe we should switch to GET on 302 too?  It's not compliant,
+         ;; but very widespread and there's enough software that depends
+         ;; on that behaviour, which might break horribly otherwise...
+         (when (= (response-code response) 303)
+           (request-method-set! request 'GET)) ; Switch to GET
+         (let ((new-uri (header-value 'location (response-headers response))))
+           (if (or (not (max-redirect-depth)) ; unlimited?
+                   (<= redirects (max-redirect-depth)))
+               (loop attempts
+                     (add1 redirects)
+                     (uri-relative-to new-uri uri))
+               (http-client-error 'send-request
+                                  "Maximum number of redirects exceeded"
+                                  'redirect-depth-exceeded
+                                  'uri new-uri))))
+        (else (let ((data (reader response)))
+                (cleanup!)
+                (values data (request-uri req) response)))))
+     (exn (exn i/o net)
+          (close-connection! uri)
+          (if (and (or (not (max-retry-attempts)) ; unlimited?
+                       (<= attempts (max-retry-attempts)))
+                   ((retry-request?) req))
+              (loop (add1 attempts) redirects uri)
+              (signal exn)))
+     (exn ()
+          ;; Never leave the port in an unknown/inconsistent state
+          ;; (the error could have occurred while reading, so there
+          ;;  might be data left in the buffer)
+          (close-connection! uri)
+          (raise exn)))))
+
+(define (call-with-input-request uri-or-request writer reader)
+  ;; "writer" is an alist to be encoded as form?
+  (let* ((postdata (and (list? writer) (form-urlencode writer separator: "&")))
+         (writer (if writer
+                     (if postdata
+                         (lambda (p)
+                           (display postdata p)
+                           (close-output-port p))
+                         writer)
+                     (lambda x (void))))
          (uri (cond ((uri? uri-or-request) uri-or-request)
                     ((string? uri-or-request) (uri-reference uri-or-request))
                     (else (request-uri uri-or-request))))
-         (req (if (request? uri-or-request) uri-or-request (make-request))))
-    (let loop ((attempts 0)
-               (redirects 0)
-               (uri uri))
-      (condition-case
-       (let* ((con (ensure-connection! uri))
-              (req (add-headers (update-request
-                                 req port: (http-connection-outport con)
-                                 uri: uri)))
-              (request (write-request req))
-              ;; Writer should be prepared to be called several times
-              ;; Maybe try and figure out a good way to use the
-              ;; "Expect: 100-continue" header to prevent too much writing?
-              ;; Unfortunately RFC2616 says it's unreliable (8.2.3)...
-              (_ (writer request))
-              (response (read-response (http-connection-inport con)))
-              (cleanup! (lambda ()
-                          (unless (and (keep-alive? request)
-                                       (keep-alive? response))
-                            (close-connection! con)))))
-         (process-set-cookie! con uri response)
-         (cond
-          ;; TODO: According to spec, we should provide the user with a choice
-          ;; when it's not a GET or HEAD request...
-          ((member (response-code response) '(301 302 303 307))
-           ;; Clear out data, throwing it away
-           (read-response-data response)
-           (cleanup!)
-           ;; Maybe we should switch to GET on 302 too?  It's not compliant,
-           ;; but very widespread and there's enough software that depends
-           ;; on that behaviour, which might break horribly otherwise...
-           (when (= (response-code response) 303)
-             (request-method-set! request 'GET))  ; Switch to GET
-           (let ((new-uri (header-value 'location (response-headers response))))
-             (if (or (not (max-redirect-depth)) ; unlimited?
-                     (<= redirects (max-redirect-depth)))
-                 (loop attempts
-                       (add1 redirects)
-                       (uri-relative-to new-uri uri))
-                 (http-client-error 'send-request
-                                    "Maximum number of redirects exceeded"
-                                    'redirect-depth-exceeded
-                                    'uri new-uri))))
-          (else (let ((data (reader response)))
-                  (cleanup!)
-                  (values data (request-uri req) response)))))
-       (exn (exn i/o net)
-            (close-connection! uri)
-            (if (and (or (not (max-retry-attempts)) ; unlimited?
-                         (<= attempts (max-retry-attempts)))
-                     ((retry-request?) req))
-                (loop (add1 attempts) redirects uri)
-                (signal exn)))
-       (exn ()
-            ;; Never leave the port in an unknown/inconsistent state
-            ;; (the error could have occurred while reading, so there
-            ;;  might be data left in the buffer)
-            (close-connection! uri)
-            (raise exn))))))
-
-(define (call-with-input-request uri-or-request reader)
-  (call-with-response
-   uri-or-request
-   (lambda (response)
-     (let ((port (make-delimited-input-port
-                  (response-port response)
-                  (header-value 'content-length (response-headers response)))))
-      (if (= 200 (response-class response)) ; Everything cool?
-          (reader port)
-          (http-client-error
-           'call-with-input-request
-           ;; Message
-           (sprintf (case (response-class response)
-                      ((400) "Client error: ~A ~A")
-                      ((500) "Server error: ~A ~A")
-                      (else "Unexpected server response: ~A ~A"))
-                    (response-code response) (response-reason response))
-           ;; Specific type
-           (case (response-class response)
-             ((400) 'client-error)
-             ((500) 'server-error)
-             (else 'unexpected-server-response))
-           'response response
-           'body (read-string #f port)))))))
-
-(define (with-input-from-request uri-or-request thunk)
+         (req (if (request? uri-or-request) uri-or-request (make-request)))
+         (req (if postdata
+                  (update-request
+                   req
+                   headers: (headers
+                             `((content-length ,(string-length postdata)))
+                             (request-headers req)))
+                  req)))
+    (call-with-response
+     req
+     (lambda (request)
+       (let ((port (request-port request)))
+         (writer port)))
+     (lambda (response)
+       (let ((port (make-delimited-input-port
+                    (response-port response)
+                    (header-value 'content-length (response-headers response)))))
+         (if (= 200 (response-class response)) ; Everything cool?
+             (reader port)
+             (http-client-error
+              'call-with-input-request
+              ;; Message
+              (sprintf (case (response-class response)
+                         ((400) "Client error: ~A ~A")
+                         ((500) "Server error: ~A ~A")
+                         (else "Unexpected server response: ~A ~A"))
+                       (response-code response) (response-reason response))
+              ;; Specific type
+              (case (response-class response)
+                ((400) 'client-error)
+                ((500) 'server-error)
+                (else 'unexpected-server-response))
+              'response response
+              'body (read-string #f port))))))))
+
+(define (with-input-from-request uri-or-request writer reader)
   (call-with-input-request uri-or-request
-                           (lambda (p) (with-input-from-port p thunk))))
+                           (if (procedure? writer)
+                               (lambda (p) (with-output-to-port p writer))
+                               writer) ;; Assume it's an alist
+                           (lambda (p) (with-input-from-port p reader))))
 
 )