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

Last change on this file since 15931 was 15931, checked in by sjamaan, 10 years ago

http-client should not close the output port when the content-length header is present

File size: 21.8 KB
Line 
1;;
2;; Convenient HTTP client library
3;;
4; Copyright (c) 2009, 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 with-input-from-request call-with-response)
38
39(import chicken scheme)
40(use srfi-1 srfi-13 srfi-18 srfi-69
41     ports extras tcp data-structures
42     openssl intarweb uri-common)
43
44;; TODO: Add cookie management API to export list
45
46(define-record http-connection base-uri inport outport)
47
48(define max-retry-attempts (make-parameter 1))
49(define max-redirect-depth (make-parameter 5))
50
51(define retry-request? (make-parameter idempotent?))
52
53;; Maybe only pass uri and realm to this?
54(define determine-username/password
55  (make-parameter (lambda (uri realm)
56                    (values (uri-username uri) (uri-password uri)))))
57
58(define client-software
59  (make-parameter (list (list "Chicken Scheme HTTP-client" "0.1" #f))))
60
61;; TODO: find a smarter storage mechanism
62(define cookie-jar (list))
63
64(define connections
65  (make-parameter (make-hash-table
66                   (lambda (a b)
67                     (and (equal? (uri-port a) (uri-port b))
68                          (equal? (uri-host a) (uri-host b))))
69                   (lambda (uri . maybe-bound)
70                     (apply string-hash
71                            (sprintf "~S ~S" (uri-host uri) (uri-port uri))
72                            maybe-bound)))))
73
74(define connections-owner
75  (make-parameter (current-thread)))
76
77(define (ensure-local-connections)
78  (unless (eq? (connections-owner) (current-thread))
79    (connections (make-hash-table equal?))
80    (connections-owner (current-thread))))
81
82(define (port-closed? p)
83  (##sys#check-port p 'port-closed?)
84  (##sys#slot p 8))
85
86(define (get-connection uri)
87  (ensure-local-connections)
88  (and-let* ((con (hash-table-ref/default (connections) uri #f)))
89    (if (or (port-closed? (http-connection-inport con))
90            (port-closed? (http-connection-outport con)))
91        (begin (close-connection! uri) #f)
92        con)))
93
94(define (add-connection! uri con)
95  (ensure-local-connections)
96  (hash-table-set! (connections) uri con))
97
98(define (close-connection! uri-or-con)
99  (ensure-local-connections)
100  (and-let* ((con (if (http-connection? uri-or-con)
101                      uri-or-con
102                      (hash-table-ref/default (connections) uri-or-con #f))))
103    (close-input-port (http-connection-inport con))
104    (close-output-port (http-connection-outport con))
105    (hash-table-delete! (connections) (http-connection-base-uri con))))
106
107(define (close-all-connections!)
108  (ensure-local-connections)
109  (hash-table-walk
110   (connections)
111   (lambda (uri con)
112     (hash-table-delete! (connections) uri)
113     (close-input-port (http-connection-inport con))
114     (close-output-port (http-connection-outport con)))))
115
116(define (ensure-connection! uri)
117  (or (get-connection uri)
118      (receive (in out)
119        (case (uri-scheme uri)
120          ((#f http) (tcp-connect (uri-host uri) (uri-port uri)))
121          ((https) (ssl-connect (uri-host uri) (uri-port uri)))
122          (else (error "Unknown URI scheme" (uri-scheme uri))))
123        (let ((con (make-http-connection uri in out)))
124          (add-connection! uri con)
125          con))))
126
127(define (make-delimited-input-port port len)
128  (if (not len)
129      port ;; no need to delimit anything
130      (let ((pos 0))
131        (make-input-port (lambda () ; read
132                           (if (= pos len)
133                               #!eof
134                               (let ((char (read-char port)))
135                                 (set! pos (add1 pos))
136                                 char)))
137                         (lambda () ; char-ready?
138                           (if (= pos len)
139                               #f
140                               (char-ready? port)))
141                         (lambda () ; close
142                           (close-input-port port))))))
143
144(define (read-response-data response)
145  (let ((len (header-value 'content-length (response-headers response))))
146    ;; If the header is not available, this will read until EOF
147    (read-string len (response-port response))))
148
149(define (add-headers req)
150  (let* ((uri (request-uri req))
151         (cookies (get-cookies-for-uri (request-uri req)))
152         (h `(,@(if (not (null? cookies)) `((cookie . ,cookies)) '())
153              (host ,(cons (uri-host uri) (uri-port uri)))
154              (user-agent ,(client-software)))))
155    (update-request req
156                    headers: (headers h (request-headers req)))))
157
158(define (http-client-error loc msg specific . rest)
159  (raise (make-composite-condition
160          (make-property-condition 'exn 'location loc 'message msg)
161          (make-property-condition 'http)
162          (apply make-property-condition specific rest))))
163
164;; RFC 2965, section 3.3.3
165(define (cookie-eq? a b)
166  (let ((ref (lambda (cookie attr) (get-param attr cookie ""))))
167    (and (eq?         (car (get-value a)) (car (get-value b)))
168         (string-ci=? (ref a 'domain)     (ref b 'domain))
169         (string=?    (ref a 'path)       (ref b 'path)))))
170
171(define (store-cookie! cookie)
172  (let loop ((jar cookie-jar))
173    (cond
174     ((null? jar) (set! cookie-jar (cons cookie cookie-jar)) cookie-jar)
175     ((cookie-eq? cookie (car jar))
176      (set-car! jar cookie)
177      cookie-jar)
178     (else (loop (cdr jar))))))
179
180(define (domain-match? uri pattern)
181  (let ((target (uri-host uri)))
182    (or (string-ci=? target pattern)
183        (and (string-prefix? "." pattern)
184             (string-suffix-ci? pattern target)))))
185
186;; Things might be simpler if we used path list representation...
187(define (path-match? uri path)
188  (and (uri-path-absolute? uri)
189       (let loop ((path (cdr (string-split path "/" #t)))
190                  (uri-path (cdr (uri-path uri))))
191         (or (null? path)               ; done
192             (and (not (null? uri-path))
193                  (or (and (string-null? (car path)) (null? (cdr path)))
194
195                      (and (string=? (car path) (car uri-path))
196                           (loop (cdr path) (cdr uri-path)))))))))
197
198;; We store slightly more info about a cookie than a cookie header
199;; accepts, so filter it.
200(define (cookie-info->cookie info)
201  (vector (get-value info)
202          (filter (lambda (p)
203                    (member (car p) '(domain path version)))
204                  (get-params info))))
205
206(define (get-cookies-for-uri uri)
207  (map cookie-info->cookie
208       (sort!
209        (filter (lambda (c)
210                  (and (domain-match? uri (get-param 'domain c))
211                       (member (uri-port uri)
212                               (get-param 'port c (list (uri-port uri))))
213                       (path-match? uri (get-param 'path c))
214                       (if (get-param 'secure c)
215                           (member (uri-scheme uri) '(https shttp))
216                           #t)))
217                cookie-jar)
218        (lambda (a b)
219          (< (string-length (get-param 'path a))
220             (string-length (get-param 'path b)))))))
221
222(define (process-set-cookie! con uri r)
223  (let ((prefix-contains-dots?
224         (lambda (host pattern)
225           (string-index host #\. 0 (string-contains-ci host pattern)))))
226    (for-each (lambda (c)
227                (and-let* (((path-match? uri (get-param 'path c)))
228                           ;; really, path should be in separated form!
229                           (path (get-param 'path c (string-join (cdr (uri-path uri)) "/")))
230                           ;; domain must start with dot. Add to intarweb!
231                           (dn (get-param 'domain c (uri-host uri)))
232                           (idx (string-index dn #\.))
233                           ((domain-match? uri dn))
234                           ((not (prefix-contains-dots? (uri-host uri) dn))))
235                  ;; Store only the cookie values we understand and need
236                  (store-cookie! (vector (get-value c)
237                                         `((version . ,(get-param 'version c))
238                                           (path . ,path)
239                                           (domain . ,dn)
240                                           (secure . ,(get-param 'secure c)))))))
241              (header-contents 'set-cookie (response-headers r) '()))
242    (for-each (lambda (c)
243                (and-let* (((get-param 'version c)) ; required for set-cookie2
244                           (path (get-param 'path c (string-join (cdr (uri-path uri)) "/")))
245                           ((path-match? uri (get-param 'path c)))
246                           (dn (get-param 'domain c (uri-host uri)))
247                           ((or (string-ci=? dn ".local")
248                                (and (not (string-null? dn))
249                                     (string-index dn #\. 1))))
250                           ((domain-match? uri dn))
251                           ((not (prefix-contains-dots? (uri-host uri) dn)))
252                           ;; This is a little bit too messy for my tastes...
253                           ;; Can't use #f because that would shortcut and-let*
254                           (ports-value (get-param 'port c 'any))
255                           (ports (if (eq? ports-value #t)
256                                      (list (uri-port uri))
257                                      ports-value))
258                           ((or (eq? ports 'any)
259                                (member (uri-port uri) ports))))
260                  ;; Store only the cookie values we understand and need
261                  (store-cookie! (vector (get-value c)
262                                         `((version . ,(get-param 'version c))
263                                           (path . ,path)
264                                           (domain . ,dn)
265                                           (port . ,(if (eq? ports 'any)
266                                                        #f
267                                                        ports))
268                                           (secure . ,(get-param 'secure c)))))))
269              (header-contents 'set-cookie2 (response-headers r) '()))))
270
271(define (call-with-response req writer reader)
272  (let loop ((attempts 0)
273             (redirects 0)
274             (req req))
275    (condition-case
276     (let* ((con (ensure-connection! (request-uri req)))
277            (req (add-headers (update-request
278                               req port: (http-connection-outport con))))
279            (request (write-request
280                      (update-request
281                       req
282                       ;; only do this if not using a proxy
283                       uri: (update-uri (uri-reference "")
284                                        path: (uri-path (request-uri req))
285                                        query: (uri-query (request-uri req))))))
286            ;; Writer should be prepared to be called several times
287            ;; Maybe try and figure out a good way to use the
288            ;; "Expect: 100-continue" header to prevent too much writing?
289            ;; Unfortunately RFC2616 says it's unreliable (8.2.3)...
290            (_ (writer request))
291            (response (read-response (http-connection-inport con)))
292            (cleanup! (lambda ()
293                        (unless (and (keep-alive? request)
294                                     (keep-alive? response))
295                          (close-connection! con)))))
296       (process-set-cookie! con (request-uri req) response)
297       (case (response-code response)
298        ;; TODO: According to spec, we should provide the user with a choice
299        ;; when it's not a GET or HEAD request...
300        ((301 302 303 307)
301         ;; Clear out data, throwing it away
302         (read-response-data response)
303         (cleanup!)
304         ;; Maybe we should switch to GET on 302 too?  It's not compliant,
305         ;; but very widespread and there's enough software that depends
306         ;; on that behaviour, which might break horribly otherwise...
307         (when (= (response-code response) 303)
308           (request-method-set! request 'GET)) ; Switch to GET
309         (let ((new-uri (header-value 'location (response-headers response))))
310           (if (or (not (max-redirect-depth)) ; unlimited?
311                   (<= redirects (max-redirect-depth)))
312               (loop attempts
313                     (add1 redirects)
314                     (update-request req uri: (uri-relative-to
315                                               new-uri (request-uri req))))
316               (http-client-error 'send-request
317                                  "Maximum number of redirects exceeded"
318                                  'redirect-depth-exceeded
319                                  'uri new-uri))))
320        ((401)
321         ;; Clear out data, throwing it away
322         (read-response-data response)
323         (cleanup!)
324         (let ((authtype (header-value 'www-authenticate
325                                        (response-headers response))))
326           (if (and (or (not (max-retry-attempts)) ; unlimited?
327                        (<= attempts (max-retry-attempts)))
328                    (and (member authtype '(basic digest))))
329               (receive (username password)
330                 ((determine-username/password)
331                  (request-uri req)
332                  (header-param 'www-authenticate 'realm
333                                (response-headers response)))
334                 ;; TODO: Maybe we should implement a way to make it ask
335                 ;; the question only once. This would be faster, but
336                 ;; maybe less secure.
337                 (case authtype
338                   ((basic)
339                    (loop (add1 attempts)
340                          redirects
341                          (update-request
342                           req
343                           headers: (headers
344                                     `((authorization
345                                        #(basic ((username . ,username)
346                                                 (password . ,password)))))
347                                     (request-headers req)))))
348                   #;((digest)
349                    (let* ((params (header-params 'www-authenticate
350                                                  (response-headers response)))
351                           (qops (alist-ref 'qop header-params eq? '()))
352                           (qop (cond
353                                 ((member 'auth-int qops) 'auth-int)
354                                 ((member 'auth qops) 'auth)
355                                 (else #f)))
356                           (cnonce (and qop "client-nonce-TODO"))
357                           (nonce (header-param 'nonce header-params))
358                           (nc (and qop 1)) ;; TODO
359                           (hashconc (lambda args
360                                       (md5 (string-join
361                                             (map ->string args) ":"))))
362                           (realm (alist-ref 'realm header-params))
363                           (method (alist-ref 'method header-params))
364                           (h1 (hashconc username realm password))
365                           (h2 (if (eq? qop 'auth-int)
366                                   (hashconc method
367                                             (uri->string
368                                              (request-uri req)
369                                              (constantly ""))
370                                             "message-body") ; TODO
371                                   (hashconc method (uri->string
372                                                     (request-uri req)
373                                                     (constantly "")))))
374                           (response-digest
375                            (case qop
376                              ((auth-int) #f ; TODO
377                               )
378                              ((auth) #f ; TODO
379                               )
380                              (else
381                               (conc h1 nonce h2)))))
382                      (loop (add1 attempts)
383                            redirects
384                            (update-request
385                             req
386                             headers:
387                             (headers
388                              `((authorization
389                                 #(digest
390                                   ((username . ,username)
391                                    (uri . ,(request-uri req))
392                                    (realm . ,(alist-ref params 'realm))
393                                    (nonce . ,(alist-ref params 'nonce))
394                                    (cnonce . ,cnonce)
395                                    (nc . ,nc)
396                                    (response . ,response-digest)
397                                    (opaque . ,(alist-ref params 'opaque))))))
398                              (request-headers req))))))
399                   (else (error "Should never get here"))))
400               ;; pass it on, we can't throw an error here
401               (let ((data (reader response)))
402                 (cleanup!)
403                 (values data (request-uri req) response)))))
404        (else (let ((data (reader response)))
405           (cleanup!)
406           (values data (request-uri req) response)))))
407     (exn (exn i/o net)
408          (close-connection! (request-uri req))
409          (if (and (or (not (max-retry-attempts)) ; unlimited?
410                       (<= attempts (max-retry-attempts)))
411                   ((retry-request?) req))
412              (loop (add1 attempts) redirects req)
413              (raise exn)))
414     (exn ()
415          ;; Never leave the port in an unknown/inconsistent state
416          ;; (the error could have occurred while reading, so there
417          ;;  might be data left in the buffer)
418          (close-connection! (request-uri req))
419          (raise exn)))))
420
421(define (call-with-input-request uri-or-request writer reader)
422  ;; "writer" is an alist to be encoded as form?
423  (let* ((postdata (or (and (string? writer) writer)
424                       (and (list? writer)
425                            (form-urlencode writer separator: "&"))))
426         (write-data! (if writer
427                          (if postdata
428                              (lambda (p)
429                                (display postdata p))
430                              writer)
431                          (lambda x (void))))
432         (uri (cond ((uri? uri-or-request) uri-or-request)
433                    ((string? uri-or-request) (uri-reference uri-or-request))
434                    (else (request-uri uri-or-request))))
435         (req (if (request? uri-or-request)
436                  uri-or-request
437                  (make-request uri: uri)))
438         (req (if postdata
439                  (update-request req
440                   headers: (headers
441                             `((content-length ,(string-length postdata))
442                               ,@(if (list? writer)
443                                     `((content-type
444                                        application/x-www-form-urlencoded))
445                                     `()))
446                             (request-headers req)))
447                  req)))
448    (call-with-response
449     req
450     (lambda (request)
451       (let ((port (request-port request)))
452         (write-data! port)))
453     (lambda (response)
454       (let ((port (make-delimited-input-port
455                    (response-port response)
456                    (header-value 'content-length (response-headers response)))))
457         (if (= 200 (response-class response)) ; Everything cool?
458             (reader port)
459             (http-client-error
460              'call-with-input-request
461              ;; Message
462              (sprintf (case (response-class response)
463                         ((400) "Client error: ~A ~A")
464                         ((500) "Server error: ~A ~A")
465                         (else "Unexpected server response: ~A ~A"))
466                       (response-code response) (response-reason response))
467              ;; Specific type
468              (case (response-class response)
469                ((400) 'client-error)
470                ((500) 'server-error)
471                (else 'unexpected-server-response))
472              'response response
473              'body (read-string #f port))))))))
474
475(define (with-input-from-request uri-or-request writer reader)
476  (call-with-input-request uri-or-request
477                           (if (procedure? writer)
478                               (lambda (p) (with-output-to-port p writer))
479                               writer) ;; Assume it's an alist
480                           (lambda (p) (with-input-from-port p reader))))
481
482)
Note: See TracBrowser for help on using the repository browser.