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

Last change on this file since 15141 was 15141, checked in by sjamaan, 11 years ago

Version is accepted in cookie params too!

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