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

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

Fix small mistake in condition creation

File size: 16.9 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 (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;; based on SRV:send-reply by Oleg Kiselyov
182(define (http:send-body b)
183  (let loop ((fragments b) (result #f))
184    (cond
185      ((null? fragments) result)
186      ((not (car fragments)) (loop (cdr fragments) result))
187      ((null? (car fragments)) (loop (cdr fragments) result))
188      ((eq? #t (car fragments)) (loop (cdr fragments) #t))
189      ((pair? (car fragments))
190        (loop (cdr fragments) (loop (car fragments) result)))
191      ((procedure? (car fragments))
192        ((car fragments))
193        (loop (cdr fragments) #t))
194      (else
195       (display (car fragments))
196       (loop (cdr fragments) #t)))))
197
198(define (default-port? serv port)
199  (or (and (string=? serv "http") (= port 80))
200      (and (string=? serv "https") (= port 443))))
201
202(define (http:send-request req . more)
203  (let-optionals more ([in #f]
204                       [out #f] )
205    (let* ([req (if (string? req) 
206                    (http:make-request 'GET req '(("Connection" . "close")))
207                    req) ] 
208           [as (remove (lambda (a) (string-ci=? (car a) "content-length"))
209                       (http:request-attributes req))]
210           [url (http:request-url req)]
211           [b (http:request-body req)] )
212      (let*-values ([(serv host port path) (parse-url-host-and-port url)]
213                    [(id) (connection-id host port)]
214                    [(proxy-host proxy-port) (get-proxy serv host port path)])
215        (let retry ()
216          (condition-case
217           (let-values
218             ([(i o) (cond ((and in out) (values in out))
219                           ((get-connection id) => (lambda (inout) (apply values inout)))
220                           ((string=? serv "https") (ssl-connect host port (http:request-sslctx req)))
221                           (proxy-host (tcp-connect proxy-host proxy-port))
222                           (else (tcp-connect host port)))])
223             (let ([method (string-upcase (symbol->string (http:request-method req)))]
224                   [proto (string-upcase (symbol->string (http:request-protocol req)))]
225                   [result ""])
226               (if (and proxy-host (not (string=? serv "https")))
227                   (set! result (string-append method " " serv "://" host
228                                           (if (= port 80) "" (conc ":" port))
229                                           path " " proto "\r\n"))
230                   (set! result (string-append method " " path " " proto
231                                           "\r\nHost: " host
232                                           (if (default-port? serv port)
233                                               ""
234                                               (conc ":" port))
235                                           "\r\n")))
236             (for-each
237              (lambda (a)
238                (set! result (sprintf "~A~A: ~A\r\n" result (car a) (cdr a)) ))
239              as)
240             (cond ((string? b)
241                    (set! result (sprintf "~AContent-Length: ~A\r\n\r\n~A" result (string-length b) b)))
242                   ((list? b)
243                    (let ((b1 (with-output-to-string 
244                                (lambda () (http:send-body b)))))
245                      (set! result (sprintf "~AContent-Length: ~A\r\n\r\n~A" result (string-length b1) b1))))
246                   (else
247                    (set! result (sprintf "~AContent-Length: 0\r\n\r\n" result ))))
248             (display result o)
249             (flush-output o))
250             (let* ([header (read-line i (http:read-line-limit))]
251                    [a (http:read-request-attributes i)])
252               (cond ((eof-object? header)
253                      (signal (make-composite-condition
254                               (make-property-condition
255                                'exn
256                                'location 'http:send-request
257                                'message "Server closed connection unexpectedly")
258                               (make-property-condition 'i/o)
259                               (make-property-condition 'net))))
260                     ((and in out))
261                     ((and (string? header)
262                           (is-keep-alive? header a))
263                      (or (is-connected? id) (add-connection! id i o)))
264                     (else
265                      (set-finalizer! i close-input-port)
266                      (set-finalizer! o close-output-port) ) )
267               (values header a i o)))
268           (exn (exn i/o net)
269                (cond ((and in out) (set! in #f) (set! out #f) (retry))
270                      ((is-connected? id) (close-connection! id) (retry))
271                      (else (signal exn))))))))))
272
273(define (http:read-body a i)
274  (cond ((string-ci=? (alist-ref "transfer-encoding" a string=? "") "chunked")
275         (let ([limit (http:read-line-limit)])
276           (let loop ([body ""])
277             (let* ([size-line (read-line i limit)]
278                    [size (string->number size-line 16)])
279               (cond ((not (fixnum? size))
280                      (error "http" "read-body" "failed to parse chunk size."))
281                     ((> size 0)
282                      (let ([b (read-string size i)])
283                        (read-line i limit) ; to drop CRLF
284                        (loop (string-append body b))))
285                     (else
286                      (http:read-request-attributes i) ; to drop footer+CRLF
287                      body))))))
288        (else
289         (read-string
290          (cond ((alist-ref "content-length" a string=?)
291                 => string->number)
292                (else
293                 #f))
294          i))))
295
296;; cookie hack
297;; VERY LIMITED: only cares NAME=VALUE, ignoring anything else such as;
298;;               "expires", "path", "domain", "secure" and so on.
299(define (http:extract-cookies req as)
300  (let* ([header (alist-ref "cookie" (http:request-attributes req) string-ci=? "")]
301         [cookies (map (lambda (x) (string-split x "=")) (string-split header ";"))]
302         [update-cookie
303          (lambda (name value)
304            (set! cookies (alist-update! name value cookies string=?)))])
305    (for-each
306     (lambda (x)
307       (if (string=? (car x) "set-cookie")
308           (let* ([s (string-split (cdr x) ";")]
309                  [ss (string-split (car s) "=")])
310             (if (>= (length ss) 2)
311                 (update-cookie (car ss) (cdr ss))))))
312     as)
313    (http:request-attributes-set!
314     req
315     (if (null? cookies)
316         (remove (lambda (a) (string-ci=? (car a) "cookie"))
317                 (http:request-attributes req))
318         ;;else
319         (alist-update! "Cookie"
320                        (string-intersperse
321                         (map (lambda (x) (string-intersperse x "=")) cookies)
322                         ";")
323                        (http:request-attributes req)
324                        string-ci=?)))))
325
326(define (http:GET req)
327  (let ([req (cond ((http:request? req)
328                    req)
329                   ((string? req)
330                    (http:make-request 
331                     'GET req '(("Connection" . "close"))))
332                   (else
333                    (error "http:GET" "unknown http request" req)))])
334    (let-values ([(header a i o) (http:send-request req)])
335      (if a (http:extract-cookies req a))
336      (http:read-body a i))))
337
338(define (http:form-url-encode arg)
339  (url-encode arg (list #\_ #\- #\* #\. #\@)))
340
341(define (http:POST req #!optional (args '())
342                       #!key (type      "application/x-www-form-urlencoded")
343                             (headers   '())
344                             (delim     ""))
345    (let ((req   (cond ((http:request? req)
346                           req)
347                       ((string? req)
348                           (http:make-request 'POST req headers))
349                       (else
350                           (error 'http:POST "unknown http request" req))))
351          (typ   #f))
352        (or (http:request-attribute-get req "Connection")
353            (eq? 'HTTP/1.1 (http:request-protocol req))
354            (http:request-attribute-add! req "Connection" "close"))
355        (or (http:request-attribute-get req "Content-Type")
356            (http:request-attribute-add! req "Content-Type" type))
357        (set! typ (http:request-attribute-get req "Content-Type"))
358        (cond ((or (not (string? typ)) (string-null? typ))
359                  (error 'http:POST "invalid Content-Type header" typ))
360              ((not (list? args))
361                  (if (string? args)
362                      (http:request-body-set! req args)
363                      (error 'http:POST "invalid body args")))
364              ((string-ci=? "application/x-www-form-urlencoded" typ)
365                  (http:request-body-set! req
366                      (string-intersperse
367                          (map
368                              (lambda (x)
369                                  (if (pair? x)
370                                      (string-append
371                                          (http:form-url-encode (car x))
372                                          "="
373                                          (http:form-url-encode (cdr x)))
374                                      x))
375                              args)
376                          "&")))
377              ((string-ci=? "multipart/form-data" typ)
378                  (if (string-null? delim)
379                      (set! delim "----chicken-scheme---\r\n")
380                      (set! delim (conc "---" delim "\r\n")))
381                  (http:request-attribute-add! req "Content-Type"
382                      (string-append typ "; boundary=" delim))
383                  (http:request-body-set! req
384                      (string-append (fold-right
385                          (lambda (e r)
386                              (conc
387                                  "--" delim
388                                  "Content-disposition: form-data; name=\""
389                                  (if (pair? e) (car e) e) "\""
390                                  (cond ((not (pair? e))
391                                            (conc "\r\n\r\n"))
392                                        ((and (list? e) (pair? (cadr e)))
393                                            (fold-right
394                                                (lambda (a n)
395                                                    (if (pair? a)
396                                                        (if (string-suffix?
397                                                                ":" (car a))
398                                                            (conc "\r\n"
399                                                                  (car a) " "
400                                                                  (cdr a) n)
401                                                            (conc "; "
402                                                                  (car a) "=\""
403                                                                  (cdr a) "\""
404                                                                  n))
405                                                        (conc "\r\n\r\n" a n)))
406                                                ""
407                                                (cdr e)))
408                                        (else
409                                            "\r\n\r\n" (cdr e)))
410                                  "\r\n" r))
411                          ""
412                          args)
413                        "--" delim "--")))
414              (else
415                  (http:request-body-set! req
416                      (string-intersperse args delim))))
417        (call-with-values
418            (lambda ()
419                (http:send-request req))
420            (lambda (hdr a i o)
421                (and a
422                     (http:extract-cookies req a))
423                (http:read-body a i)))))
424
Note: See TracBrowser for help on using the repository browser.