source: project/release/4/http-client/trunk/http-client.scm @ 32036

Last change on this file since 32036 was 32036, checked in by sjamaan, 6 years ago

http-client: Add call-with-input-request* for situations where more information from the response is needed than just the port, as suggested by Mario Goulart

File size: 37.0 KB
Line 
1;;
2;; Convenient HTTP client library
3;;
4; Copyright (c) 2008-2014, Peter Bex
5; Parts copyright (c) 2000-2004, Felix L. Winkelmann
6; All rights reserved.
7;
8; Redistribution and use in source and binary forms, with or without
9; modification, are permitted provided that the following conditions
10; are met:
11;
12; 1. Redistributions of source code must retain the above copyright
13;    notice, this list of conditions and the following disclaimer.
14; 2. Redistributions in binary form must reproduce the above copyright
15;    notice, this list of conditions and the following disclaimer in the
16;    documentation and/or other materials provided with the distribution.
17; 3. Neither the name of the author nor the names of its
18;    contributors may be used to endorse or promote products derived
19;    from this software without specific prior written permission.
20;
21; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
24; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
25; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
26; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
27; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
28; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
29; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
30; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
31; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
32; OF THE POSSIBILITY OF SUCH DAMAGE.
33
34(module http-client
35  (max-retry-attempts max-redirect-depth retry-request? client-software
36   close-connection! close-all-connections!
37   call-with-input-request call-with-input-request*
38   with-input-from-request call-with-response
39   store-cookie! delete-cookie! get-cookies-for-uri
40   http-authenticators get-username/password
41   basic-authenticator digest-authenticator
42   determine-username/password determine-proxy
43   determine-proxy-from-environment determine-proxy-username/password)
44
45(import chicken scheme lolevel)
46(use srfi-1 srfi-13 srfi-18 srfi-69
47     ports files extras tcp data-structures posix
48     intarweb uri-common message-digest md5 string-utils sendfile)
49
50;; Major TODOs:
51;; * Find a better approach for storing cookies and server connections,
52;;    which will scale to applications with hundreds of connections
53;; * Implement md5-sess handling for digest auth
54;; * Use nonce count in digest auth (is this even needed? I think it's only
55;;    needed if there are webservers out there that send the same nonce
56;;    repeatedly. This client doesn't do request pipelining so we don't
57;;    generate requests with the same nonce if the server doesn't)
58;; * Find a way to do automated testing to increase robustness & reliability
59;; * Test and document SSL support
60;; * The authenticators stuff is really really ugly.  It's intentionally
61;;    undocumented so nobody is going to rely on it too much yet, and
62;;    we have the freedom to change it later.
63
64(define-record http-connection base-uri inport outport proxy)
65
66(define max-retry-attempts (make-parameter 1))
67(define max-redirect-depth (make-parameter 5))
68
69(define retry-request? (make-parameter idempotent?))
70
71(define (determine-proxy-from-environment uri)
72  (let* ((proxy-variable (conc (uri-scheme uri) "_proxy"))
73         (no-proxy (or (get-environment-variable "no_proxy")
74                       (get-environment-variable "NO_PROXY")))
75         (no-proxy (and no-proxy (map (lambda (s)
76                                        (string-split s ":"))
77                                      (string-split no-proxy ","))))
78         (host-excluded? (lambda (entry)
79                           (let ((host (car entry))
80                                 (port (and (pair? (cdr entry))
81                                            (string->number (cadr entry)))))
82                             (and (or (string=? host "*")
83                                      (string-ci=? host (uri-host uri)))
84                                  (or (not port)
85                                      (= (uri-port uri) port)))))))
86    (cond
87     ((and no-proxy (any host-excluded? no-proxy)) #f)
88     ((or (get-environment-variable proxy-variable)
89          (get-environment-variable (string-upcase proxy-variable))
90          (get-environment-variable "all_proxy")
91          (get-environment-variable "ALL_PROXY")) =>
92          (lambda (proxy)               ; TODO: make this just absolute-uri
93            (and-let* ((proxy-uri (uri-reference proxy))
94                       ((absolute-uri? proxy-uri)))
95              proxy-uri)))
96     (else #f))))
97
98(define determine-proxy (make-parameter determine-proxy-from-environment))
99
100(define determine-proxy-username/password
101  (make-parameter (lambda (uri realm)
102                    (values (uri-username uri) (uri-password uri)))))
103
104;; Maybe only pass uri and realm to this?
105(define determine-username/password
106  (make-parameter (lambda (uri realm)
107                    (values (uri-username uri) (uri-password uri)))))
108
109(define client-software
110  (make-parameter (list (list "Chicken Scheme HTTP-client" "0.7.1" #f))))
111
112;; TODO: find a smarter storage mechanism
113(define cookie-jar (list))
114
115(define connections
116  (make-parameter (make-hash-table
117                   (lambda (a b)
118                     (and (equal? (uri-port a) (uri-port b))
119                          (equal? (uri-host a) (uri-host b))))
120                   (lambda (uri . maybe-bound)
121                     (apply string-hash
122                            (sprintf "~S ~S" (uri-host uri) (uri-port uri))
123                            maybe-bound)))))
124
125(define connections-owner
126  (make-parameter (current-thread)))
127
128(define (ensure-local-connections)
129  (unless (eq? (connections-owner) (current-thread))
130    (connections (make-hash-table equal?))
131    (connections-owner (current-thread))))
132
133(cond-expand
134  ((not has-port-closed)
135   (define (port-closed? p)
136     (##sys#check-port p 'port-closed?)
137     (##sys#slot p 8)))
138  (else))
139
140(define (connection-dropped? con)
141  (or (port-closed? (http-connection-inport con))
142      (port-closed? (http-connection-outport con))
143      (condition-case
144          (and (char-ready? (http-connection-inport con))
145               (eof-object? (peek-char (http-connection-inport con))))
146        ;; Assume connection got reset when we get this exception
147        ((exn i/o net) #t))))
148
149(define (get-connection uri)
150  (ensure-local-connections)
151  (and-let* ((con (hash-table-ref/default (connections) uri #f)))
152    (if (connection-dropped? con)
153        (begin (close-connection! uri) #f)
154        con)))
155
156(define (add-connection! uri con)
157  (ensure-local-connections)
158  (hash-table-set! (connections) uri con))
159
160(define (close-connection! uri-or-con)
161  (ensure-local-connections)
162  (and-let* ((con (if (http-connection? uri-or-con)
163                      uri-or-con
164                      (hash-table-ref/default (connections) uri-or-con #f))))
165    (close-input-port (http-connection-inport con))
166    (close-output-port (http-connection-outport con))
167    (hash-table-delete! (connections) (http-connection-base-uri con))))
168
169(define (close-all-connections!)
170  (ensure-local-connections)
171  (hash-table-walk
172   (connections)
173   (lambda (uri con)
174     (hash-table-delete! (connections) uri)
175     (close-input-port (http-connection-inport con))
176     (close-output-port (http-connection-outport con)))))
177
178;; Imports from the openssl egg, if available
179(define (dynamic-import module symbol default)
180  (handle-exceptions _ default (eval `(let () (use ,module) ,symbol))))
181
182(define ssl-connect
183  (dynamic-import 'openssl 'ssl-connect (lambda (h p) (values #f #f))))
184
185(define (ensure-connection! uri)
186  (or (get-connection uri)
187      (let* ((proxy ((determine-proxy) uri))
188             (remote-end (or proxy uri)))
189       (receive (in out)
190         (case (uri-scheme remote-end)
191           ((#f http) (tcp-connect (uri-host remote-end) (uri-port remote-end)))
192           ((https) (receive (in out)
193                        (ssl-connect (uri-host remote-end)
194                                     (uri-port remote-end))
195                      (if (and in out)  ; Ugly, but necessary
196                          (values in out)
197                          (http-client-error
198                           'ssl-connect
199                           (conc "Unable to connect over HTTPS. To fix this, "
200                                 "install the openssl egg and try again")
201                           (list (uri->string uri))
202                           'missing-openssl-egg
203                           'request-uri uri 'proxy proxy))))
204           (else (http-client-error 'ensure-connection!
205                                    "Unknown URI scheme"
206                                    (list (uri-scheme remote-end))
207                                    'unsupported-uri-scheme
208                                    'uri-scheme (uri-scheme remote-end)
209                                    'request-uri uri 'proxy proxy)))
210         (let ((con (make-http-connection uri in out proxy)))
211           (add-connection! uri con)
212           con)))))
213
214(define (make-delimited-input-port port len)
215  (if (not len)
216      port ;; no need to delimit anything
217      (let ((pos 0))
218        (make-input-port
219         (lambda ()                     ; read-char
220           (if (= pos len)
221               #!eof
222               (let ((char (read-char port)))
223                 (set! pos (add1 pos))
224                 char)))
225         (lambda ()                     ; char-ready?
226           (or (= pos len) (char-ready? port)))
227         (lambda ()                     ; close
228           (close-input-port port))
229         (lambda ()                     ; peek-char
230           (if (= pos len)
231               #!eof
232               (peek-char port)))
233         (lambda (p bytes buf off)      ; read-string!
234           (let* ((bytes (min bytes (- len pos)))
235                  (bytes-read (read-string! bytes buf port off)))
236             (set! pos (+ pos bytes-read))
237             bytes-read))
238         (lambda (p limit)              ; read-line
239           (if (= pos len)
240               #!eof
241               (let* ((bytes-left (- len pos))
242                      (limit (min (or limit bytes-left) bytes-left))
243                      (line (read-line port limit)))
244                 (unless (eof-object? line)
245                         (set! pos (+ pos (string-length line))))
246                 line)))))))
247
248(define discard-remaining-data!
249  (let ((buf (make-string 1024)))       ; Doesn't matter, discarded anyway
250    (lambda (response port)
251      ;; If header not available or no response object passed, this reads until EOF
252      (let loop ((len (and response
253                           (header-value
254                            'content-length (response-headers response)))))
255        (if len
256            (when (> len 0)
257              (loop (- len (read-string! len buf port))))
258            (when (> (read-string! (string-length buf) buf port) 0)
259              (loop #f)))))))
260
261(define (add-headers req)
262  (let* ((uri (request-uri req))
263         (cookies (get-cookies-for-uri (request-uri req)))
264         (h `(,@(if (not (null? cookies)) `((cookie . ,cookies)) '())
265              (host ,(cons (uri-host uri) (and (not (uri-default-port? uri))
266                                               (uri-port uri))))
267              ,@(if (and (client-software) (not (null? (client-software))))
268                    `((user-agent ,(client-software)))
269                    '()))))
270    (update-request req
271                    headers: (headers h (request-headers req)))))
272
273(define (http-client-error loc msg args specific . rest)
274  (raise (make-composite-condition
275          (make-property-condition 'exn 'location loc 'message msg 'arguments args)
276          (make-property-condition 'http)
277          (apply make-property-condition specific rest))))
278
279;; RFC 2965, section 3.3.3
280(define (cookie-eq? a-name a-info b-name b-info)
281  (and (string-ci=? a-name b-name)
282       (string-ci=? (alist-ref 'domain a-info) (alist-ref 'domain b-info))
283       (equal?      (alist-ref 'path a-info)   (alist-ref 'path b-info))))
284
285(define (store-cookie! cookie-info set-cookie)
286  (let loop ((cookie (set-cookie->cookie set-cookie))
287             (jar cookie-jar))
288    (cond
289     ((null? jar)
290      (set! cookie-jar (cons (cons cookie-info cookie) cookie-jar))
291      cookie-jar)
292     ((cookie-eq? (car (get-value set-cookie)) cookie-info
293                  (car (get-value (cdar jar))) (caar jar))
294      (set-car! jar (cons cookie-info cookie))
295      cookie-jar)
296     (else (loop cookie (cdr jar))))))
297
298(define (delete-cookie! cookie-name cookie-info)
299  (set! cookie-jar (remove! (lambda (c)
300                              (cookie-eq? (car (get-value (cdr c))) (car c)
301                                          cookie-name cookie-info))
302                            cookie-jar)))
303
304(define (domain-match? uri pattern)
305  (let ((target (uri-host uri)))
306    (or (string-ci=? target pattern)
307        (and (string-prefix? "." pattern)
308             (string-suffix-ci? pattern target)))))
309
310(define (path-match? uri path)
311  (and (uri-path-absolute? uri)
312       (let loop ((path (cdr (uri-path path)))
313                  (uri-path (cdr (uri-path uri))))
314         (or (null? path)               ; done
315             (and (not (null? uri-path))
316                  (or (and (string-null? (car path)) (null? (cdr path)))
317
318                      (and (string=? (car path) (car uri-path))
319                           (loop (cdr path) (cdr uri-path)))))))))
320
321;; Set-cookie provides some info we don't need to store; strip the
322;; nonessential info
323(define (set-cookie->cookie info)
324  (vector (get-value info)
325          (filter (lambda (p)
326                    (member (car p) '(domain path version)))
327                  (get-params info))))
328
329(define (get-cookies-for-uri uri)
330  (let ((uri (if (string? uri) (uri-reference uri) uri)))
331    (map cdr
332         (sort!
333          (filter (lambda (c)
334                    (let ((info (car c)))
335                     (and (domain-match? uri (alist-ref 'domain info))
336                          (member (uri-port uri)
337                                  (alist-ref 'port info eq?
338                                             (list (uri-port uri))))
339                          (path-match? uri (alist-ref 'path info))
340                          (if (alist-ref 'secure info)
341                              (member (uri-scheme uri) '(https shttp))
342                              #t))))
343                  cookie-jar)
344          (lambda (a b)
345            (< (length (uri-path (alist-ref 'path (car a))))
346               (length (uri-path (alist-ref 'path (car b))))))))))
347
348(define (process-set-cookie! con uri r)
349  (let ((prefix-contains-dots?
350         (lambda (host pattern)
351           (string-index host #\. 0 (string-contains-ci host pattern)))))
352    (for-each (lambda (c)
353                (and-let* ((path (or (get-param 'path c) uri))
354                           ((path-match? uri path))
355                           ;; domain must start with dot. Add to intarweb!
356                           (dn (get-param 'domain c (uri-host uri)))
357                           (idx (string-index dn #\.))
358                           ((domain-match? uri dn))
359                           ((not (prefix-contains-dots? (uri-host uri) dn))))
360                  (store-cookie! `((path . ,path)
361                                   (domain . ,dn)
362                                   (secure . ,(get-param 'secure c))) c)))
363              (header-contents 'set-cookie (response-headers r) '()))
364    (for-each (lambda (c)
365                (and-let* (((get-param 'version c)) ; required for set-cookie2
366                           (path (or (get-param 'path c) uri))
367                           ((path-match? uri path))
368                           (dn (get-param 'domain c (uri-host uri)))
369                           ((or (string-ci=? dn ".local")
370                                (and (not (string-null? dn))
371                                     (string-index dn #\. 1))))
372                           ((domain-match? uri dn))
373                           ((not (prefix-contains-dots? (uri-host uri) dn)))
374                           ;; This is a little bit too messy for my tastes...
375                           ;; Can't use #f because that would shortcut and-let*
376                           (ports-value (get-param 'port c 'any))
377                           (ports (if (eq? ports-value #t)
378                                      (list (uri-port uri))
379                                      ports-value))
380                           ((or (eq? ports 'any)
381                                (member (uri-port uri) ports))))
382                  (store-cookie! `((path . ,path)
383                                   (domain . ,dn)
384                                   (port . ,(if (eq? ports 'any) #f ports))
385                                   (secure . ,(get-param 'secure c))) c)))
386              (header-contents 'set-cookie2 (response-headers r) '()))))
387
388(define (call-with-output-digest primitive proc)
389  (let* ((ctx-info (message-digest-primitive-context-info primitive))
390         (ctx (if (procedure? ctx-info) (ctx-info) (allocate ctx-info)))
391         (update-digest (message-digest-primitive-update primitive))
392         (update (lambda (str) (update-digest ctx str (string-length str))))
393         (outport (make-output-port update void)))
394    (handle-exceptions exn
395      (unless (procedure? ctx-info) (free ctx))
396      (let ((result (make-string
397                     (message-digest-primitive-digest-length primitive))))
398        ((message-digest-primitive-init primitive) ctx)
399        (proc outport)
400        ((message-digest-primitive-final primitive) ctx result)
401        (unless (procedure? ctx-info) (free ctx))
402        (string->hex result)))))
403
404(define (get-username/password for-request-header for-uri for-realm)
405  (if (eq? for-request-header 'authorization)
406      ((determine-username/password) for-uri for-realm)
407      ((determine-proxy-username/password) for-uri for-realm)))
408
409;;; TODO: We really, really should get rid of "writer" here.  Some kind of
410;;; generalized way to get the digest is required.  Jeez, HTTP sucks :(
411(define (basic-authenticator response response-header
412                             new-request request-header uri realm writer)
413  (receive (username password)
414    (get-username/password request-header uri realm)
415    (and username
416         (update-request
417          new-request
418          headers: (headers `((,request-header
419                               #(basic ((username . ,username)
420                                        (password . ,(or password ""))))))
421                            (request-headers new-request))))))
422
423(define (digest-authenticator response response-header
424                              new-request request-header uri realm writer)
425  (receive (username password)
426    (get-username/password request-header uri realm)
427    (and username
428         (let* ((hashconc
429                 (lambda args
430                   (message-digest-string
431                    (md5-primitive) (string-join (map ->string args) ":"))))
432                (authless-uri (update-uri (request-uri new-request)
433                                          username: #f password: #f))
434                ;; TODO: domain handling
435                (h (response-headers response))
436                (nonce (header-param 'nonce response-header h))
437                (opaque (header-param 'opaque response-header h))
438                (stale (header-param 'stale response-header h))
439                ;; TODO: "md5-sess" algorithm handling
440                (algorithm (header-param 'algorithm response-header h))
441                (qops (header-param 'qop response-header h '()))
442                (qop (cond ; Pick the strongest of the offered options
443                      ((member 'auth-int qops) 'auth-int)
444                      ((member 'auth qops) 'auth)
445                      (else #f)))
446                (cnonce (and qop (hashconc (current-seconds) realm)))
447                (nc (and qop 1)) ;; TODO
448                (ha1 (hashconc username realm (or password "")))
449                (ha2 (if (eq? qop 'auth-int)
450                         (hashconc (request-method new-request)
451                                   (uri->string authless-uri)
452                                   ;; Generate digest from writer's output
453                                   (call-with-output-digest
454                                    (md5-primitive)
455                                    (lambda (p)
456                                      (writer
457                                       (update-request new-request port: p)))))
458                         (hashconc (request-method new-request)
459                                   (uri->string authless-uri))))
460                (digest
461                 (case qop
462                   ((auth-int auth)
463                    (let ((hex-nc (string-pad (number->string nc 16) 8 #\0)))
464                      (hashconc ha1 nonce hex-nc cnonce qop ha2)))
465                   (else
466                    (hashconc ha1 nonce ha2)))))
467           (update-request new-request
468                           headers: (headers
469                                     `((,request-header
470                                        #(digest ((username . ,username)
471                                                  (uri . ,authless-uri)
472                                                  (realm . ,realm)
473                                                  (nonce . ,nonce)
474                                                  (cnonce . ,cnonce)
475                                                  (qop . ,qop)
476                                                  (nc . ,nc)
477                                                  (response . ,digest)
478                                                  (opaque . ,opaque)))))
479                                     (request-headers new-request)))))))
480
481(define http-authenticators
482  (make-parameter `((basic . ,basic-authenticator)
483                    (digest . ,digest-authenticator))))
484
485(define (authenticate-request request response writer proxy-uri)
486  (and-let* ((type (if (= (response-code response) 401) 'auth 'proxy))
487             (resp-header (if (eq? type 'auth)
488                              'www-authenticate
489                              'proxy-authenticate))
490             (req-header (if (eq? type 'auth)
491                             'authorization
492                             'proxy-authorization))
493             (authtype (header-value resp-header (response-headers response)))
494             (realm (header-param 'realm resp-header (response-headers response)))
495             (auth-uri (if (eq? type 'auth) (request-uri request) proxy-uri))
496             (authenticator (or (alist-ref authtype (http-authenticators))
497                                ;; Should we really raise an error?
498                                (http-client-error 'authenticate-request
499                                                   "Unknown authentication type"
500                                                   (list authtype)
501                                                   'unknown-authtype
502                                                   'authtype authtype
503                                                   'request request))))
504    (authenticator response resp-header request req-header
505                   auth-uri realm writer)))
506
507(define (call-with-response req writer reader)
508  (let loop ((attempts 0)
509             (redirects 0)
510             (req req))
511    (condition-case
512        (let* ((con (ensure-connection! (request-uri req)))
513               (req (add-headers (update-request
514                                  req port: (http-connection-outport con))))
515               ;; No outgoing URIs should ever contain credentials or fragments
516               (req-uri (update-uri (request-uri req)
517                                    fragment: #f username: #f password: #f))
518               ;; RFC1945, 5.1.2: "The absoluteURI form is only allowed
519               ;; when the request is being made to a proxy."
520               ;; RFC2616 is a little more regular (hosts MUST accept
521               ;; absoluteURI), but it says "HTTP/1.1 clients will only
522               ;; generate them in requests to proxies." (also 5.1.2)
523               (req-uri (if (http-connection-proxy con)
524                            req-uri
525                            (update-uri req-uri host: #f port: #f scheme: #f
526                                        path: (or (uri-path req-uri) '(/ "")))))
527               (request (write-request (update-request req uri: req-uri)))
528               ;; Writer should be prepared to be called several times
529               ;; Maybe try and figure out a good way to use the
530               ;; "Expect: 100-continue" header to prevent too much writing?
531               ;; Unfortunately RFC2616 says it's unreliable (8.2.3)...
532               (_ (begin (writer request) (flush-output (request-port req))))
533               (response (read-response (http-connection-inport con)))
534               (cleanup! (lambda (clear-response-data?)
535                           (when clear-response-data?
536                             (discard-remaining-data! response
537                                                      (response-port response)))
538                           (unless (and (keep-alive? request)
539                                        (keep-alive? response))
540                             (close-connection! con)))))
541          (when response (process-set-cookie! con (request-uri req) response))
542          (case (and response (response-code response))
543            ((#f)
544             ;; If the connection is closed prematurely, we SHOULD
545             ;; retry, according to RFC2616, section 8.2.4.  Currently
546             ;; don't do "binary exponential backoff", which we MAY do.
547             (if (or (not (max-retry-attempts)) ; unlimited?
548                     (<= attempts (max-retry-attempts)))
549                 (loop (add1 attempts) redirects req)
550                 (http-client-error 'send-request
551                                    "Server closed connection before sending response"
552                                    (list (uri->string (request-uri req)))
553                                    'premature-disconnection
554                                    'uri (request-uri req) 'request req)))
555            ;; TODO: According to spec, we should provide the user
556            ;; with a choice when it's not a GET or HEAD request...
557            ((301 302 303 307)
558             (cleanup! #t)
559             ;; Maybe we should switch to GET on 302 too?  It's not compliant,
560             ;; but very widespread and there's enough software that depends
561             ;; on that behaviour, which might break horribly otherwise...
562             (when (= (response-code response) 303)
563               (request-method-set! req 'GET)) ; Switch to GET
564             (let* ((loc-uri (header-value 'location
565                                           (response-headers response)))
566                    (new-uri (uri-relative-to loc-uri (request-uri req))))
567               (if (or (not (max-redirect-depth)) ; unlimited?
568                       (< redirects (max-redirect-depth)))
569                   (loop attempts
570                         (add1 redirects)
571                         (update-request req uri: new-uri))
572                   (http-client-error 'send-request
573                                      "Maximum number of redirects exceeded"
574                                      (list (uri->string (request-uri request)))
575                                      'redirect-depth-exceeded
576                                      'uri (request-uri req)
577                                      'new-uri new-uri 'request req))))
578            ;; TODO: Test this
579            ((305)                 ; Use proxy (for this request only)
580             (cleanup! #t)
581             (let ((old-determine-proxy (determine-proxy))
582                   (proxy-uri (header-value 'location (response-headers response))))
583               (parameterize ((determine-proxy
584                               (lambda _
585                                 ;; Reset determine-proxy so the proxy is really
586                                 ;; used for only this one request.
587                                 ;; Yes, this is a bit of a hack :)
588                                 (determine-proxy old-determine-proxy)
589                                 proxy-uri)))
590                 (loop attempts redirects req))))
591            ((401 407)   ; Unauthorized, Proxy Authentication Required
592             (cond ((and (or (not (max-retry-attempts)) ; unlimited?
593                             (<= attempts (max-retry-attempts)))
594                         (authenticate-request req response writer
595                                               (http-connection-proxy con)))
596                    => (lambda (new-req)
597                         (cleanup! #t)
598                         (loop (add1 attempts) redirects new-req)))
599                   (else ;; pass it on, we can't throw an error here
600                    (let ((data (reader response)))
601                      (values data (request-uri request) response)))))
602            (else (let ((data (reader response)))
603                    (cleanup! #f)
604                    (values data (request-uri req) response)))))
605      (exn (exn i/o net)
606           (close-connection! (request-uri req))
607           (if (and (or (not (max-retry-attempts)) ; unlimited?
608                        (<= attempts (max-retry-attempts)))
609                    ((retry-request?) req))
610               (loop (add1 attempts) redirects req)
611               (raise exn)))
612      (exn ()
613           ;; Never leave the port in an unknown/inconsistent state
614           ;; (the error could have occurred while reading, so there
615           ;;  might be data left in the buffer)
616           (close-connection! (request-uri req))
617           (raise exn)))))
618
619(define (kv-ref l k #!optional default)
620  (let ((rest (memq k l)))
621    (if (and rest (pair? (cdr rest))) (cadr rest) default)))
622
623;; This really, really sucks
624;; TODO: This crap probably belongs in its own egg?  Perhaps later when
625;; we have server-side handling for this too.
626(define (prepare-multipart-chunks boundary entries)
627  (append
628   (map (lambda (entry)
629          (if (not (cdr entry))         ; discard #f values
630              '()
631              (let* ((keys (cdr entry))
632                     (file (kv-ref keys file:))
633                     (filename (or (kv-ref keys filename:)
634                                   (and (port? file) (port-name file))
635                                   (and (string? file) file)))
636                     (filename (and filename
637                                    (pathname-strip-directory filename)))
638                     (h (headers `((content-disposition
639                                    #(form-data ((name . ,(car entry))
640                                                 (filename . ,filename))))
641                                   ,@(if filename
642                                         '((content-type application/octet-stream))
643                                         '()))))
644                     (hs (call-with-output-string
645                           (lambda (s)
646                             (unparse-headers
647                              ;; Allow user headers to override ours
648                              (headers (kv-ref keys headers: '()) h) s)))))
649                (list "--" boundary "\r\n" hs "\r\n"
650                      (cond ((string? file) (cons 'file file))
651                            ((port? file) (cons 'port file))
652                            ((eq? keys #t) "")
653                            (else (->string keys)))
654                  ;; The next boundary must always start on a new line
655                  "\r\n"))))
656        entries)
657   (list (list "--" boundary "--\r\n"))))
658
659(define (write-chunks output-port entries)
660  (for-each (lambda (entry)
661              (for-each (lambda (chunk)
662                          (if (pair? chunk)
663                              (let ((p (if (eq? 'file (car chunk))
664                                           (open-input-file (cdr chunk))
665                                           ;; Should be a port otherwise
666                                           (cdr chunk))))
667                                (handle-exceptions exn
668                                  (begin (close-input-port p) (raise exn))
669                                  (sendfile p output-port))
670                                (close-input-port p))
671                              (display chunk output-port)))
672                        entry))
673            entries))
674
675(define (calculate-chunk-size entries)
676  (call/cc
677   (lambda (return)
678     (fold (lambda (chunks total-size)
679             (fold (lambda (chunk total-size)
680                     (if (pair? chunk)
681                         (if (eq? 'port (car chunk))
682                             ;; Should be a file otherwise.
683                             ;; We can't calculate port lengths.
684                             ;; Let's just punt and hope the server
685                             ;; won't return "411 Length Required"...
686                             ;; (TODO: maybe try seeking it?)
687                             (return #f)
688                             (+ total-size (file-size (cdr chunk))))
689                         (+ total-size (string-length chunk))))
690                   total-size
691                   chunks))
692           0 entries))))
693
694(define (call-with-input-request* uri-or-request writer reader)
695  (let* ((type #f)
696         (uri (cond ((uri? uri-or-request) uri-or-request)
697                    ((string? uri-or-request) (uri-reference uri-or-request))
698                    (else (request-uri uri-or-request))))
699         (req (if (request? uri-or-request)
700                  uri-or-request
701                  (make-request uri: uri method: (if writer 'POST 'GET))))
702         (chunks (cond
703                  ((string? writer) (list (list writer)))
704                  ((and (list? writer)
705                        (any (lambda (x)
706                               (and (pair? x) (pair? (cdr x))
707                                    (eq? (cadr x) file:)))
708                             writer))
709                   (let ((bd (conc "----------------Multipart-=_"
710                                   (gensym 'boundary) "=_=" (current-process-id)
711                                   "=-=" (current-seconds))))
712                     (set! type `#(multipart/form-data ((boundary . ,bd))))
713                     (prepare-multipart-chunks bd writer)))
714                  ;; Default to "&" because some servers choke on ";"
715                  ((list? writer)
716                   (set! type 'application/x-www-form-urlencoded)
717                   (list (list (or (form-urlencode writer separator: "&")
718                                   (http-client-error
719                                    'call-with-input-request
720                                    "Invalid form data!"
721                                    (list (uri->string uri) writer reader)
722                                    'form-data-error
723                                    'request req
724                                    'form-data writer)))))
725                  (else #f)))
726         (req (update-request
727               req
728               headers: (headers
729                         `(,@(if chunks
730                                 `((content-length
731                                    ,(calculate-chunk-size chunks)))
732                                 '())
733                           ,@(if type `((content-type ,type)) '()))
734                         (request-headers req)))))
735    (call-with-response
736     req
737     (cond (chunks (lambda (r)
738                     (write-chunks (request-port r) chunks)
739                     (finish-request-body r)))
740           ((procedure? writer)
741            (lambda (r)
742              (writer (request-port r))
743              (finish-request-body r)))
744           (else (lambda x (void))))
745     (lambda (response)
746       (let ((port (make-delimited-input-port
747                    (response-port response)
748                    (header-value 'content-length (response-headers response))))
749             (body? ((response-has-message-body-for-request?) response req)))
750         (if (= 200 (response-class response)) ; Everything cool?
751             (let ((result (and body? reader (reader port response))))
752               (when body? (discard-remaining-data! #f port))
753               result)
754             (http-client-error
755              'call-with-input-request
756              ;; Message
757              (sprintf (case (response-class response)
758                         ((400) "Client error: ~A ~A")
759                         ((500) "Server error: ~A ~A")
760                         (else "Unexpected server response: ~A ~A"))
761                       (response-code response) (response-reason response))
762              ;; arguments
763              (list (uri->string uri))
764              ;; Specific type
765              (case (response-class response)
766                ((400) 'client-error)
767                ((500) 'server-error)
768                (else 'unexpected-server-response))
769              'response response
770              'body (and body? (read-string #f port)))))))))
771
772(define (call-with-input-request uri-or-request writer reader)
773  (call-with-input-request* uri-or-request writer (lambda (p r) (reader p))))
774
775(define (with-input-from-request uri-or-request writer reader)
776  (call-with-input-request uri-or-request
777                           (if (procedure? writer)
778                               (lambda (p) (with-output-to-port p writer))
779                               writer) ;; Assume it's an alist or #f
780                           (lambda (p) (with-input-from-port p reader))))
781
782)
Note: See TracBrowser for help on using the repository browser.