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

Last change on this file since 8427 was 8427, checked in by elf, 12 years ago

fix for single-char-packets being constantly emitted, reported by glogic

File size: 12.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(declare (uses extras srfi-1 srfi-13 srfi-18 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 (close-connection! id)
92  (ensure-local-connections)
93  (let ((con (hash-table-ref (connections) id)))
94    (hash-table-delete! (connections) id)
95    (close-input-port (car con))
96    (close-output-port (cadr con))))
97
98(define (http:close-all-connections!)
99  (ensure-local-connections)
100  (hash-table-walk
101   (connections)
102   (lambda (id con)
103     (hash-table-delete! (connections) id)
104     (close-input-port (car con))
105     (close-output-port (cadr con)))))
106
107(define (is-keep-alive? status as)
108  (or (and (substring-ci=? status "http/1.0")
109           (string-ci=? (alist-ref "connection" as string=? "") "keep-alive"))
110      (and (substring-ci=? status "http/1.1")
111           (not (string-ci=? (alist-ref "connection" as string=? "") "close")))))
112
113(define (port-closed? p)
114  (##sys#check-port p 'port-closed?)
115  (##sys#slot p 8))
116
117;; Proxy
118
119(define proxy-map '())
120
121(define (http:add-proxy! host port . pattern-list)
122  (set! proxy-map (cons (list pattern-list host port) proxy-map)))
123
124(define (http:remove-all-proxies!)
125  (set! proxy-map '()))
126
127(define (get-proxy serv host port path)
128
129  (define (match-func pattern str)
130    (or (eq? pattern #t)
131        (and (string? pattern) (substring=? pattern str))
132        (and (regexp? pattern) (string-match pattern str))))
133
134  (define (match-func-list pattern-list str-list)
135    (cond ((null? pattern-list)
136           #t)
137          ((null? str-list)
138           'should-not-happen)
139          ((match-func (car pattern-list) (car str-list))
140           (match-func-list (cdr pattern-list) (cdr str-list)))
141          (else
142           #f)))
143
144  (let loop ([pmap proxy-map])
145    (cond ((null? pmap)
146           (values #f #f))
147          ((match-func-list (caar pmap) (list serv host (->string port) path))
148           (apply values (cdar pmap)))
149          (else
150           (loop (cdr pmap))))))
151
152;; Client API:
153
154(define url-rx
155  (if (feature? 'pregexp)
156      "([A-Za-z]+\\://)?([\\-_a-zA-Z0-9.]+)(\\:[0-9]+)?(/.*)?"
157      "([A-Za-z]+\\://)?([-_a-zA-Z0-9.]+)(\\:[0-9]+)?(/.*)?") )
158
159(define (parse-url-host-and-port url)
160  (match (string-match url-rx url)
161    [(_ serv host port path)
162     (let ((servs (and serv (substring serv 0 (- (string-length serv) 3)))))
163       (values
164        (or servs "http")
165        host
166        (cond [port (string->number (substring port 1 (string-length port)))]
167              [serv (let ((port (getservbyname servs)))
168                      (if (> port 0)
169                          port
170                          (error "invalid service" serv)))]
171              [else 80] )
172        (or path "/") ) ) ]
173    [else (values "http" url 80 "/")] ) )
174
175(define getservbyname 
176  (foreign-lambda* int ([c-string serv])
177    "struct servent *se = getservbyname(serv, \"tcp\");"
178    "if(se == NULL) return(0);"
179    "else return(NET_CONV(se->s_port));") )
180
181(define (http:send-request req . more)
182  (let-optionals more ([in #f]
183                       [out #f] )
184    (let* ([req (if (string? req) 
185                    (http:make-request 'GET req '(("Connection" . "close")))
186                    req) ] 
187           [as (remove (lambda (a) (string-ci=? (car a) "content-length"))
188                       (http:request-attributes req))]
189           [url (http:request-url req)]
190           [b (http:request-body req)] )
191      (let*-values ([(serv host port path) (parse-url-host-and-port url)]
192                    [(id) (connection-id host port)]
193                    [(proxy-host proxy-port) (get-proxy serv host port path)])
194        (let retry ()
195          (condition-case
196           (let-values
197             ([(i o) (cond ((and in out) (values in out))
198                           ((get-connection id) => (lambda (inout) (apply values inout)))
199                           ((string=? serv "https") (ssl-connect host port (http:request-sslctx req)))
200                           (proxy-host (tcp-connect proxy-host proxy-port))
201                           (else (tcp-connect host port)))])
202             (let ([method (string-upcase (symbol->string (http:request-method req)))]
203                   [proto (string-upcase (symbol->string (http:request-protocol req)))]
204                   [result ""])
205               (if (and proxy-host (not (string=? serv "https")))
206                   (set! result (string-append method " " serv "://" host
207                                           (if (= port 80) "" (conc ":" port))
208                                           path " " proto "\r\n"))
209                   (set! result (string-append method " " path " " proto
210                                           "\r\nHost: " host ":"
211                                           (->string port) "\r\n") o)))
212             (for-each
213              (lambda (a)
214                (set! result (sprintf "~A~A: ~A\r\n" result (car a) (cdr a)) ))
215              as)
216             (if (string? b)
217                 (set! result (sprintf "~AContent-Length: ~A\r\n\r\n~A" result (string-length b) b))
218                 (set! result (sprintf "~AContent-Length: 0\r\n\r\n" result) ))
219             (display result o)
220             (flush-output o)
221             (let* ([header (read-line i (http:read-line-limit))]
222                    [a (http:read-request-attributes i)])
223               (cond ((and in out))
224                     ((and (string? header)
225                           (is-keep-alive? header a))
226                      (or (is-connected? id) (add-connection! id i o)))
227                     (else
228                      (set-finalizer! i close-input-port)
229                      (set-finalizer! o close-output-port) ) )
230               (values header a i o)))
231           (exn (exn i/o net)
232                (cond ((and in out) (set! in #f) (set! out #f) (retry))
233                      ((is-connected? id) (close-connection! id) (retry))
234                      (else (signal exn))))))))))
235
236(define (http:read-body a i)
237  (cond ((string-ci=? (alist-ref "transfer-encoding" a string=? "") "chunked")
238         (let ([limit (http:read-line-limit)])
239           (let loop ([body ""])
240             (let* ([size-line (read-line i limit)]
241                    [size (string->number size-line 16)])
242               (cond ((not (fixnum? size))
243                      (error "http" "read-body" "failed to parse chunk size."))
244                     ((> size 0)
245                      (let ([b (read-string size i)])
246                        (read-line i limit) ; to drop CRLF
247                        (loop (string-append body b))))
248                     (else
249                      (http:read-request-attributes i) ; to drop footer+CRLF
250                      body))))))
251        (else
252         (read-string
253          (cond ((alist-ref "content-length" a string=?)
254                 => string->number)
255                (else
256                 #f))
257          i))))
258
259;; cookie hack
260;; VERY LIMITED: only cares NAME=VALUE, ignoring anything else such as;
261;;               "expires", "path", "domain", "secure" and so on.
262(define (http:extract-cookies req as)
263  (let* ([header (alist-ref "cookie" (http:request-attributes req) string-ci=? "")]
264         [cookies (map (lambda (x) (string-split x "=")) (string-split header ";"))]
265         [update-cookie
266          (lambda (name value)
267            (set! cookies (alist-update! name value cookies string=?)))])
268    (for-each
269     (lambda (x)
270       (if (string=? (car x) "set-cookie")
271           (let* ([s (string-split (cdr x) ";")]
272                  [ss (string-split (car s) "=")])
273             (if (>= (length ss) 2)
274                 (update-cookie (car ss) (cdr ss))))))
275     as)
276    (http:request-attributes-set!
277     req
278     (if (null? cookies)
279         (remove (lambda (a) (string-ci=? (car a) "cookie"))
280                 (http:request-attributes req))
281         ;;else
282         (alist-update! "Cookie"
283                        (string-intersperse
284                         (map (lambda (x) (string-intersperse x "=")) cookies)
285                         ";")
286                        (http:request-attributes req)
287                        string-ci=?)))))
288
289(define (http:GET req)
290  (let ([req (cond ((http:request? req)
291                    req)
292                   ((string? req)
293                    (http:make-request 
294                     'GET req '(("Connection" . "close"))))
295                   (else
296                    (error "http:GET" "unknown http request" req)))])
297    (let-values ([(header a i o) (http:send-request req)])
298      (if a (http:extract-cookies req a))
299      (http:read-body a i))))
300
301(define (http:form-url-encode arg)
302  (url-encode arg (list #\_ #\- #\* #\. #\@)))
303
304(define (http:POST req #!optional (args '()) (delim1 "") (delim2 "") (encoder values))
305  (let* ([req (cond ((http:request? req)
306                     req)
307                    ((string? req)
308                     (http:make-request 
309                      'POST req '(("Connection" . "close") ("Content-Type" . "application/x-www-form-urlencoded"))))
310                    (else
311                     (error "http:POST" "unknown http request" req)))]
312         [ctype (alist-ref "content-type" (http:request-attributes req) string-ci=?)])
313    (cond ((equal? ctype "application/x-www-form-urlencoded")
314           (set! delim1 "=")
315           (set! delim2 "&")
316           (set! encoder http:form-url-encode))
317          ;...
318          )
319    (http:request-body-set!
320     req
321     (string-intersperse
322      (map (lambda (x) (if (pair? x)
323                           (string-append (encoder (car x)) delim1 (encoder (cdr x)))
324                           x))
325           args)
326      delim2))
327    (let-values ([(header a i o) (http:send-request req)])
328      (if a (http:extract-cookies req a))
329      (http:read-body a i))))
330
Note: See TracBrowser for help on using the repository browser.