Changeset 15112 in project


Ignore:
Timestamp:
06/29/09 23:41:59 (10 years ago)
Author:
sjamaan
Message:

Add POST regular formdata support

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/4/http-client/trunk/http-client.scm

    r15111 r15112  
    147147(define (add-headers req)
    148148  (let* ((uri (request-uri req))
    149          (h `((cookie . ,(get-cookies-for-uri (request-uri req)))
     149         (cookies (get-cookies-for-uri (request-uri req)))
     150         (h `(,@(if (not (null? cookies)) `((cookie . ,cookies)) '())
    150151              (host ,(cons (uri-host uri) (uri-port uri)))
    151152              (user-agent ,(client-software)))))
     
    255256              (header-contents 'set-cookie2 (response-headers r) '()))))
    256257
    257 (define (call-with-response uri-or-request proc1 #!optional proc2)
    258   (let* ((writer (if proc2 proc1 (lambda x (void))))
    259          (reader (if proc2 proc2 proc1))
     258(define (call-with-response req writer reader)
     259  (let loop ((attempts 0)
     260             (redirects 0)
     261             (uri (request-uri req)))
     262    (condition-case
     263     (let* ((con (ensure-connection! uri))
     264            (req (add-headers (update-request
     265                               req port: (http-connection-outport con)
     266                               uri: uri)))
     267            (request (write-request req))
     268            ;; Writer should be prepared to be called several times
     269            ;; Maybe try and figure out a good way to use the
     270            ;; "Expect: 100-continue" header to prevent too much writing?
     271            ;; Unfortunately RFC2616 says it's unreliable (8.2.3)...
     272            (_ (writer request))
     273            (response (read-response (http-connection-inport con)))
     274            (cleanup! (lambda ()
     275                        (unless (and (keep-alive? request)
     276                                     (keep-alive? response))
     277                          (close-connection! con)))))
     278       (process-set-cookie! con uri response)
     279       (cond
     280        ;; TODO: According to spec, we should provide the user with a choice
     281        ;; when it's not a GET or HEAD request...
     282        ((member (response-code response) '(301 302 303 307))
     283         ;; Clear out data, throwing it away
     284         (read-response-data response)
     285         (cleanup!)
     286         ;; Maybe we should switch to GET on 302 too?  It's not compliant,
     287         ;; but very widespread and there's enough software that depends
     288         ;; on that behaviour, which might break horribly otherwise...
     289         (when (= (response-code response) 303)
     290           (request-method-set! request 'GET)) ; Switch to GET
     291         (let ((new-uri (header-value 'location (response-headers response))))
     292           (if (or (not (max-redirect-depth)) ; unlimited?
     293                   (<= redirects (max-redirect-depth)))
     294               (loop attempts
     295                     (add1 redirects)
     296                     (uri-relative-to new-uri uri))
     297               (http-client-error 'send-request
     298                                  "Maximum number of redirects exceeded"
     299                                  'redirect-depth-exceeded
     300                                  'uri new-uri))))
     301        (else (let ((data (reader response)))
     302                (cleanup!)
     303                (values data (request-uri req) response)))))
     304     (exn (exn i/o net)
     305          (close-connection! uri)
     306          (if (and (or (not (max-retry-attempts)) ; unlimited?
     307                       (<= attempts (max-retry-attempts)))
     308                   ((retry-request?) req))
     309              (loop (add1 attempts) redirects uri)
     310              (signal exn)))
     311     (exn ()
     312          ;; Never leave the port in an unknown/inconsistent state
     313          ;; (the error could have occurred while reading, so there
     314          ;;  might be data left in the buffer)
     315          (close-connection! uri)
     316          (raise exn)))))
     317
     318(define (call-with-input-request uri-or-request writer reader)
     319  ;; "writer" is an alist to be encoded as form?
     320  (let* ((postdata (and (list? writer) (form-urlencode writer separator: "&")))
     321         (writer (if writer
     322                     (if postdata
     323                         (lambda (p)
     324                           (display postdata p)
     325                           (close-output-port p))
     326                         writer)
     327                     (lambda x (void))))
    260328         (uri (cond ((uri? uri-or-request) uri-or-request)
    261329                    ((string? uri-or-request) (uri-reference uri-or-request))
    262330                    (else (request-uri uri-or-request))))
    263          (req (if (request? uri-or-request) uri-or-request (make-request))))
    264     (let loop ((attempts 0)
    265                (redirects 0)
    266                (uri uri))
    267       (condition-case
    268        (let* ((con (ensure-connection! uri))
    269               (req (add-headers (update-request
    270                                  req port: (http-connection-outport con)
    271                                  uri: uri)))
    272               (request (write-request req))
    273               ;; Writer should be prepared to be called several times
    274               ;; Maybe try and figure out a good way to use the
    275               ;; "Expect: 100-continue" header to prevent too much writing?
    276               ;; Unfortunately RFC2616 says it's unreliable (8.2.3)...
    277               (_ (writer request))
    278               (response (read-response (http-connection-inport con)))
    279               (cleanup! (lambda ()
    280                           (unless (and (keep-alive? request)
    281                                        (keep-alive? response))
    282                             (close-connection! con)))))
    283          (process-set-cookie! con uri response)
    284          (cond
    285           ;; TODO: According to spec, we should provide the user with a choice
    286           ;; when it's not a GET or HEAD request...
    287           ((member (response-code response) '(301 302 303 307))
    288            ;; Clear out data, throwing it away
    289            (read-response-data response)
    290            (cleanup!)
    291            ;; Maybe we should switch to GET on 302 too?  It's not compliant,
    292            ;; but very widespread and there's enough software that depends
    293            ;; on that behaviour, which might break horribly otherwise...
    294            (when (= (response-code response) 303)
    295              (request-method-set! request 'GET))  ; Switch to GET
    296            (let ((new-uri (header-value 'location (response-headers response))))
    297              (if (or (not (max-redirect-depth)) ; unlimited?
    298                      (<= redirects (max-redirect-depth)))
    299                  (loop attempts
    300                        (add1 redirects)
    301                        (uri-relative-to new-uri uri))
    302                  (http-client-error 'send-request
    303                                     "Maximum number of redirects exceeded"
    304                                     'redirect-depth-exceeded
    305                                     'uri new-uri))))
    306           (else (let ((data (reader response)))
    307                   (cleanup!)
    308                   (values data (request-uri req) response)))))
    309        (exn (exn i/o net)
    310             (close-connection! uri)
    311             (if (and (or (not (max-retry-attempts)) ; unlimited?
    312                          (<= attempts (max-retry-attempts)))
    313                      ((retry-request?) req))
    314                 (loop (add1 attempts) redirects uri)
    315                 (signal exn)))
    316        (exn ()
    317             ;; Never leave the port in an unknown/inconsistent state
    318             ;; (the error could have occurred while reading, so there
    319             ;;  might be data left in the buffer)
    320             (close-connection! uri)
    321             (raise exn))))))
    322 
    323 (define (call-with-input-request uri-or-request reader)
    324   (call-with-response
    325    uri-or-request
    326    (lambda (response)
    327      (let ((port (make-delimited-input-port
    328                   (response-port response)
    329                   (header-value 'content-length (response-headers response)))))
    330       (if (= 200 (response-class response)) ; Everything cool?
    331           (reader port)
    332           (http-client-error
    333            'call-with-input-request
    334            ;; Message
    335            (sprintf (case (response-class response)
    336                       ((400) "Client error: ~A ~A")
    337                       ((500) "Server error: ~A ~A")
    338                       (else "Unexpected server response: ~A ~A"))
    339                     (response-code response) (response-reason response))
    340            ;; Specific type
    341            (case (response-class response)
    342              ((400) 'client-error)
    343              ((500) 'server-error)
    344              (else 'unexpected-server-response))
    345            'response response
    346            'body (read-string #f port)))))))
    347 
    348 (define (with-input-from-request uri-or-request thunk)
     331         (req (if (request? uri-or-request) uri-or-request (make-request)))
     332         (req (if postdata
     333                  (update-request
     334                   req
     335                   headers: (headers
     336                             `((content-length ,(string-length postdata)))
     337                             (request-headers req)))
     338                  req)))
     339    (call-with-response
     340     req
     341     (lambda (request)
     342       (let ((port (request-port request)))
     343         (writer port)))
     344     (lambda (response)
     345       (let ((port (make-delimited-input-port
     346                    (response-port response)
     347                    (header-value 'content-length (response-headers response)))))
     348         (if (= 200 (response-class response)) ; Everything cool?
     349             (reader port)
     350             (http-client-error
     351              'call-with-input-request
     352              ;; Message
     353              (sprintf (case (response-class response)
     354                         ((400) "Client error: ~A ~A")
     355                         ((500) "Server error: ~A ~A")
     356                         (else "Unexpected server response: ~A ~A"))
     357                       (response-code response) (response-reason response))
     358              ;; Specific type
     359              (case (response-class response)
     360                ((400) 'client-error)
     361                ((500) 'server-error)
     362                (else 'unexpected-server-response))
     363              'response response
     364              'body (read-string #f port))))))))
     365
     366(define (with-input-from-request uri-or-request writer reader)
    349367  (call-with-input-request uri-or-request
    350                            (lambda (p) (with-input-from-port p thunk))))
     368                           (if (procedure? writer)
     369                               (lambda (p) (with-output-to-port p writer))
     370                               writer) ;; Assume it's an alist
     371                           (lambda (p) (with-input-from-port p reader))))
    351372
    352373)
Note: See TracChangeset for help on using the changeset viewer.