source: project/release/3/http/trunk/http-client.scm @ 13417

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

Apply some more patches for keep-alive patches (thanks to Drew Hess)

File size: 17.1 KB
Line 
1;;;; http-client.scm - Client API - felix
2;
3; Copyright (c) 2000-2004, Felix L. Winkelmann
4; All rights reserved.
5;
6; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
7; conditions are met:
8;
9;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
10;     disclaimer.
11;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
12;     disclaimer in the documentation and/or other materials provided with the distribution.
13;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
14;     products derived from this software without specific prior written permission.
15;
16; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
17; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
18; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
19; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
20; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
21; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
22; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
23; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
24; POSSIBILITY OF SUCH DAMAGE.
25;
26; Send bugs, suggestions and ideas to:
27;
28; felix@call-with-current-continuation.org
29;
30; Felix L. Winkelmann
31; Unter den Gleichen 1
32; 37130 Gleichen
33; Germany
34
35
36(declare
37  (fixnum)
38  ;(no-bound-checks)
39  (export 
40   http:send-request http:GET http:POST
41   http:close-all-connections! http:read-body
42   http:add-proxy! http:remove-all-proxies!)
43  (foreign-declare #<<EOF
44#ifdef _WIN32
45#include "WINSOCK2.H"
46#else
47#include <netdb.h>
48#include <netinet/in.h>
49#endif
50#define NET_CONV(expr) ntohs((expr))
51EOF
52  ) )
53
54(use extras srfi-1 srfi-13 srfi-18 srfi-69 regex tcp utils)
55
56(use http-utils url openssl)
57(require-for-syntax 'regex-case)
58
59;; Connection pool
60
61(define connections
62  (make-parameter (make-hash-table equal?)))
63(define connections-owner
64  (make-parameter (current-thread)))
65
66(define (ensure-local-connections)
67  (unless (eq? (connections-owner) (current-thread))
68    (connections (make-hash-table equal?))
69    (connections-owner (current-thread))))
70
71(define (connection-id host port)
72  (cons port host))
73
74(define (is-connected? id)
75  (ensure-local-connections)
76  (hash-table-exists? (connections) id))
77
78(define (get-connection id)
79  (ensure-local-connections)
80  (let ((con (hash-table-ref/default (connections) id #f)))
81    (and con
82         (if (or (port-closed? (car con)) (port-closed? (cadr con)))
83             (begin (close-connection! id) #f)
84             #t)
85         con)))
86
87(define (add-connection! id in out)
88  (ensure-local-connections)
89  (hash-table-set! (connections) id (list in out)))
90
91(define (remove-connection! id)
92  (ensure-local-connections)
93  (let ((con (hash-table-ref (connections) id)))
94    (hash-table-delete! (connections) id)
95    con))
96
97(define (close-connection! id)
98  (let ((con (remove-connection! id)))
99    (close-input-port (car con))
100    (close-output-port (cadr con))))
101
102(define (http:close-all-connections!)
103  (ensure-local-connections)
104  (hash-table-walk
105   (connections)
106   (lambda (id con)
107     (hash-table-delete! (connections) id)
108     (close-input-port (car con))
109     (close-output-port (cadr con)))))
110
111(define (is-keep-alive? status as)
112  (or (and (substring-ci=? status "http/1.0")
113           (string-ci=? (alist-ref "connection" as string=? "") "keep-alive"))
114      (and (substring-ci=? status "http/1.1")
115           (not (string-ci=? (alist-ref "connection" as string=? "") "close")))))
116
117(define (port-closed? p)
118  (##sys#check-port p 'port-closed?)
119  (##sys#slot p 8))
120
121;; Proxy
122
123(define proxy-map '())
124
125(define (http:add-proxy! host port . pattern-list)
126  (set! proxy-map (cons (list pattern-list host port) proxy-map)))
127
128(define (http:remove-all-proxies!)
129  (set! proxy-map '()))
130
131(define (get-proxy serv host port path)
132
133  (define (match-func pattern str)
134    (or (eq? pattern #t)
135        (and (string? pattern) (substring=? pattern str))
136        (and (regexp? pattern) (string-match pattern str))))
137
138  (define (match-func-list pattern-list str-list)
139    (cond ((null? pattern-list)
140           #t)
141          ((null? str-list)
142           'should-not-happen)
143          ((match-func (car pattern-list) (car str-list))
144           (match-func-list (cdr pattern-list) (cdr str-list)))
145          (else
146           #f)))
147
148  (let loop ([pmap proxy-map])
149    (cond ((null? pmap)
150           (values #f #f))
151          ((match-func-list (caar pmap) (list serv host (->string port) path))
152           (apply values (cdar pmap)))
153          (else
154           (loop (cdr pmap))))))
155
156;; Client API:
157
158(define url-rx
159  (if (feature? 'pregexp)
160      "([A-Za-z]+\\://)?([\\-_a-zA-Z0-9.]+)(\\:[0-9]+)?(/.*)?"
161      "([A-Za-z]+\\://)?([-_a-zA-Z0-9.]+)(\\:[0-9]+)?(/.*)?") )
162
163(define (parse-url-host-and-port url)
164  (match (string-match url-rx url)
165    [(_ serv host port path)
166     (let ((servs (and serv (substring serv 0 (- (string-length serv) 3)))))
167       (values
168        (or servs "http")
169        host
170        (cond [port (string->number (substring port 1 (string-length port)))]
171              [serv (let ((port (getservbyname servs)))
172                      (if (> port 0)
173                          port
174                          (error "invalid service" serv)))]
175              [else 80] )
176        (or path "/") ) ) ]
177    [else (values "http" url 80 "/")] ) )
178
179(define getservbyname 
180  (foreign-lambda* int ([c-string serv])
181    "struct servent *se = getservbyname(serv, \"tcp\");"
182    "if(se == NULL) return(0);"
183    "else return(NET_CONV(se->s_port));") )
184
185;; based on SRV:send-reply by Oleg Kiselyov
186(define (http:send-body b)
187  (let loop ((fragments b) (result #f))
188    (cond
189      ((null? fragments) result)
190      ((not (car fragments)) (loop (cdr fragments) result))
191      ((null? (car fragments)) (loop (cdr fragments) result))
192      ((eq? #t (car fragments)) (loop (cdr fragments) #t))
193      ((pair? (car fragments))
194        (loop (cdr fragments) (loop (car fragments) result)))
195      ((procedure? (car fragments))
196        ((car fragments))
197        (loop (cdr fragments) #t))
198      (else
199       (display (car fragments))
200       (loop (cdr fragments) #t)))))
201
202(define (default-port? serv port)
203  (or (and (string=? serv "http") (= port 80))
204      (and (string=? serv "https") (= port 443))))
205
206(define (http:send-request req . more)
207  (let-optionals more ([in #f]
208                       [out #f] )
209    (let* ([req (if (string? req) 
210                    (http:make-request 'GET req '(("Connection" . "close")))
211                    req) ] 
212           [as (remove (lambda (a) (string-ci=? (car a) "content-length"))
213                       (http:request-attributes req))]
214           [url (http:request-url req)]
215           [b (http:request-body req)] )
216      (let*-values ([(serv host port path) (parse-url-host-and-port url)]
217                    [(id) (connection-id host port)]
218                    [(proxy-host proxy-port) (get-proxy serv host port path)])
219        (let retry ()
220          (condition-case
221           (let-values
222             ([(i o) (cond ((and in out) (values in out))
223                           ((get-connection id) => (lambda (inout) (apply values inout)))
224                           ((string=? serv "https") (ssl-connect host port (http:request-sslctx req)))
225                           (proxy-host (tcp-connect proxy-host proxy-port))
226                           (else (tcp-connect host port)))])
227             (let ([method (string-upcase (symbol->string (http:request-method req)))]
228                   [proto (string-upcase (symbol->string (http:request-protocol req)))]
229                   [result ""])
230               (if (and proxy-host (not (string=? serv "https")))
231                   (set! result (string-append method " " serv "://" host
232                                           (if (= port 80) "" (conc ":" port))
233                                           path " " proto "\r\n"))
234                   (set! result (string-append method " " path " " proto
235                                           "\r\nHost: " host
236                                           (if (default-port? serv port)
237                                               ""
238                                               (conc ":" port))
239                                           "\r\n")))
240             (for-each
241              (lambda (a)
242                (set! result (sprintf "~A~A: ~A\r\n" result (car a) (cdr a)) ))
243              as)
244             (cond ((string? b)
245                    (set! result (sprintf "~AContent-Length: ~A\r\n\r\n~A" result (string-length b) b)))
246                   ((list? b)
247                    (let ((b1 (with-output-to-string 
248                                (lambda () (http:send-body b)))))
249                      (set! result (sprintf "~AContent-Length: ~A\r\n\r\n~A" result (string-length b1) b1))))
250                   (else
251                    (set! result (sprintf "~AContent-Length: 0\r\n\r\n" result ))))
252             (display result o)
253             (flush-output o))
254             (let* ([header (read-line i (http:read-line-limit))]
255                    [a (http:read-request-attributes i)])
256               (cond ((eof-object? header)
257                      (signal (make-composite-condition
258                               (make-property-condition
259                                'exn
260                                'location 'http:send-request
261                                'message "Server closed connection unexpectedly")
262                               (make-property-condition 'i/o)
263                               (make-property-condition 'net))))
264                     ((and (is-keep-alive? header a)   ; server
265                           (is-keep-alive? header as)) ; client
266                      (unless (is-connected? id)
267                        (add-connection! id i o)))
268                     (else
269                      (when (is-connected? id)
270                        (remove-connection! id))
271                      (close-output-port o)
272                      (set-finalizer! i close-input-port)))
273               (values header a i o)))
274           (exn (exn i/o net)
275                (cond ((and in out) (set! in #f) (set! out #f) (retry))
276                      ((is-connected? id) (close-connection! id) (retry))
277                      (else (signal exn))))))))))
278
279(define (http:read-body a i)
280  (cond ((string-ci=? (alist-ref "transfer-encoding" a string=? "") "chunked")
281         (let ([limit (http:read-line-limit)])
282           (let loop ([body ""])
283             (let* ([size-line (read-line i limit)]
284                    [size (string->number size-line 16)])
285               (cond ((not (fixnum? size))
286                      (error "http" "read-body" "failed to parse chunk size."))
287                     ((> size 0)
288                      (let ([b (read-string size i)])
289                        (read-line i limit) ; to drop CRLF
290                        (loop (string-append body b))))
291                     (else
292                      (http:read-request-attributes i) ; to drop footer+CRLF
293                      body))))))
294        (else
295         (read-string
296          (cond ((alist-ref "content-length" a string=?)
297                 => string->number)
298                (else
299                 #f))
300          i))))
301
302;; cookie hack
303;; VERY LIMITED: only cares NAME=VALUE, ignoring anything else such as;
304;;               "expires", "path", "domain", "secure" and so on.
305(define (http:extract-cookies req as)
306  (let* ([header (alist-ref "cookie" (http:request-attributes req) string-ci=? "")]
307         [cookies (map (lambda (x) (string-split x "=")) (string-split header ";"))]
308         [update-cookie
309          (lambda (name value)
310            (set! cookies (alist-update! name value cookies string=?)))])
311    (for-each
312     (lambda (x)
313       (if (string=? (car x) "set-cookie")
314           (let* ([s (string-split (cdr x) ";")]
315                  [ss (string-split (car s) "=")])
316             (if (>= (length ss) 2)
317                 (update-cookie (car ss) (cdr ss))))))
318     as)
319    (http:request-attributes-set!
320     req
321     (if (null? cookies)
322         (remove (lambda (a) (string-ci=? (car a) "cookie"))
323                 (http:request-attributes req))
324         ;;else
325         (alist-update! "Cookie"
326                        (string-intersperse
327                         (map (lambda (x) (string-intersperse x "=")) cookies)
328                         ";")
329                        (http:request-attributes req)
330                        string-ci=?)))))
331
332(define (http:GET req)
333  (let ([req (cond ((http:request? req)
334                    req)
335                   ((string? req)
336                    (http:make-request 
337                     'GET req '(("Connection" . "close"))))
338                   (else
339                    (error "http:GET" "unknown http request" req)))])
340    (let-values ([(header a i o) (http:send-request req)])
341      (if a (http:extract-cookies req a))
342      (http:read-body a i))))
343
344(define (http:form-url-encode arg)
345  (url-encode arg (list #\_ #\- #\* #\. #\@)))
346
347(define (http:POST req #!optional (args '())
348                       #!key (type      "application/x-www-form-urlencoded")
349                             (headers   '())
350                             (delim     ""))
351    (let ((req   (cond ((http:request? req)
352                           req)
353                       ((string? req)
354                           (http:make-request 'POST req headers))
355                       (else
356                           (error 'http:POST "unknown http request" req))))
357          (typ   #f))
358        (or (http:request-attribute-get req "Connection")
359            (eq? 'HTTP/1.1 (http:request-protocol req))
360            (http:request-attribute-add! req "Connection" "close"))
361        (or (http:request-attribute-get req "Content-Type")
362            (http:request-attribute-add! req "Content-Type" type))
363        (set! typ (http:request-attribute-get req "Content-Type"))
364        (cond ((or (not (string? typ)) (string-null? typ))
365                  (error 'http:POST "invalid Content-Type header" typ))
366              ((not (list? args))
367                  (if (string? args)
368                      (http:request-body-set! req args)
369                      (error 'http:POST "invalid body args")))
370              ((string-ci=? "application/x-www-form-urlencoded" typ)
371                  (http:request-body-set! req
372                      (string-intersperse
373                          (map
374                              (lambda (x)
375                                  (if (pair? x)
376                                      (string-append
377                                          (http:form-url-encode (car x))
378                                          "="
379                                          (http:form-url-encode (cdr x)))
380                                      x))
381                              args)
382                          "&")))
383              ((string-ci=? "multipart/form-data" typ)
384                  (if (string-null? delim)
385                      (set! delim "----chicken-scheme---\r\n")
386                      (set! delim (conc "---" delim "\r\n")))
387                  (http:request-attribute-add! req "Content-Type"
388                      (string-append typ "; boundary=" delim))
389                  (http:request-body-set! req
390                      (string-append (fold-right
391                          (lambda (e r)
392                              (conc
393                                  "--" delim
394                                  "Content-disposition: form-data; name=\""
395                                  (if (pair? e) (car e) e) "\""
396                                  (cond ((not (pair? e))
397                                            (conc "\r\n\r\n"))
398                                        ((and (list? e) (pair? (cadr e)))
399                                            (fold-right
400                                                (lambda (a n)
401                                                    (if (pair? a)
402                                                        (if (string-suffix?
403                                                                ":" (car a))
404                                                            (conc "\r\n"
405                                                                  (car a) " "
406                                                                  (cdr a) n)
407                                                            (conc "; "
408                                                                  (car a) "=\""
409                                                                  (cdr a) "\""
410                                                                  n))
411                                                        (conc "\r\n\r\n" a n)))
412                                                ""
413                                                (cdr e)))
414                                        (else
415                                            "\r\n\r\n" (cdr e)))
416                                  "\r\n" r))
417                          ""
418                          args)
419                        "--" delim "--")))
420              (else
421                  (http:request-body-set! req
422                      (string-intersperse args delim))))
423        (call-with-values
424            (lambda ()
425                (http:send-request req))
426            (lambda (hdr a i o)
427                (and a
428                     (http:extract-cookies req a))
429                (http:read-body a i)))))
430
Note: See TracBrowser for help on using the repository browser.