Changeset 15112 in project
- Timestamp:
- 06/29/09 23:41:59 (12 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
release/4/http-client/trunk/http-client.scm
r15111 r15112 147 147 (define (add-headers req) 148 148 (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)) '()) 150 151 (host ,(cons (uri-host uri) (uri-port uri))) 151 152 (user-agent ,(client-software))))) … … 255 256 (header-contents 'set-cookie2 (response-headers r) '())))) 256 257 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)))) 260 328 (uri (cond ((uri? uri-or-request) uri-or-request) 261 329 ((string? uri-or-request) (uri-reference uri-or-request)) 262 330 (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) 349 367 (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)))) 351 372 352 373 )
Note: See TracChangeset
for help on using the changeset viewer.