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

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

Update signal handling for when remote closes the connection unexpectedly. Bug reported by Drew Hess

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.