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

Last change on this file since 33747 was 33747, checked in by sjamaan, 2 years ago

http-client: Introduce max-idle-connections to avoid FD exhaustion.

This also changes the semantics of connections: The connections hash
table now stores a *list* of idle connections per host, which is
shared by all threads. Such a connection can be claimed by a thread,
making it active, which causes it to be removed from the idle list.

File size: 40.1 KB
Line 
1;;;
2;;; Convenient HTTP client library
3;;;
4;; Copyright (c) 2008-2016, 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
15;;    copyright notice, this list of conditions and the following
16;;    disclaimer in the documentation and/or other materials provided
17;;    with the distribution.
18;; 3. Neither the name of the author nor the names of its
19;;    contributors may be used to endorse or promote products derived
20;;    from this software without specific prior written permission.
21;;
22;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
23;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
24;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
25;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
26;; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
27;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
28;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
29;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
30;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
31;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
32;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
33;; OF THE POSSIBILITY OF SUCH DAMAGE.
34;
35(module http-client
36    (max-retry-attempts max-redirect-depth max-idle-connections
37     retry-request? client-software
38     close-connection! close-idle-connections! close-all-connections!
39     call-with-input-request call-with-input-request*
40     with-input-from-request call-with-response
41     store-cookie! delete-cookie! get-cookies-for-uri
42     http-authenticators get-username/password
43     basic-authenticator digest-authenticator
44     determine-username/password determine-proxy
45     determine-proxy-from-environment determine-proxy-username/password
46     server-connector default-server-connector)
47
48(import chicken scheme lolevel)
49(use srfi-1 srfi-13 srfi-18 srfi-69
50     ports files extras tcp data-structures posix
51     intarweb uri-common message-digest md5 string-utils sendfile)
52
53;; Major TODOs:
54;; * Find a better approach for storing cookies and server connections,
55;;    which will scale to applications with hundreds of connections
56;; * Implement md5-sess handling for digest auth
57;; * Use nonce count in digest auth (is this even needed? I think it's only
58;;    needed if there are webservers out there that send the same nonce
59;;    repeatedly. This client doesn't do request pipelining so we don't
60;;    generate requests with the same nonce if the server doesn't)
61;; * Find a way to do automated testing to increase robustness & reliability
62;; * Test and document SSL support
63;; * The authenticators stuff is really really ugly.  It's intentionally
64;;    undocumented so nobody is going to rely on it too much yet, and
65;;    we have the freedom to change it later.
66
67(define-record http-connection base-uri inport outport proxy)
68
69(define max-retry-attempts (make-parameter 1))
70(define max-redirect-depth (make-parameter 5))
71;; Total idle connections.  Maybe later we'll add per-server limits.
72(define max-idle-connections (make-parameter 32))
73
74(define retry-request? (make-parameter idempotent?))
75
76(define (determine-proxy-from-environment uri)
77  (let* ((is-cgi-process (get-environment-variable "REQUEST_METHOD"))
78         ;; If we're running in a CGI script, don't use HTTP_PROXY, to
79         ;; avoid a "httpoxy" attack.  Instead, we use the variable
80         ;; CGI_HTTP_PROXY.  See https://httpoxy.org
81         (proxy-variable
82          (if (and (eq? (uri-scheme uri) 'http) is-cgi-process)
83              "cgi_http_proxy"
84              (conc (uri-scheme uri) "_proxy")))
85         (no-proxy (or (get-environment-variable "no_proxy")
86                       (get-environment-variable "NO_PROXY")))
87         (no-proxy (and no-proxy (map (lambda (s)
88                                        (string-split s ":"))
89                                      (string-split no-proxy ","))))
90         (host-excluded? (lambda (entry)
91                           (let ((host (car entry))
92                                 (port (and (pair? (cdr entry))
93                                            (string->number (cadr entry)))))
94                             (and (or (string=? host "*")
95                                      (string-ci=? host (uri-host uri)))
96                                  (or (not port)
97                                      (= (uri-port uri) port)))))))
98    (cond
99     ((and no-proxy (any host-excluded? no-proxy)) #f)
100     ((or (get-environment-variable proxy-variable)
101          (get-environment-variable (string-upcase proxy-variable))
102          (get-environment-variable "all_proxy")
103          (get-environment-variable "ALL_PROXY")) =>
104          (lambda (proxy)               ; TODO: make this just absolute-uri
105            (and-let* ((proxy-uri (uri-reference proxy))
106                       ((absolute-uri? proxy-uri)))
107              proxy-uri)))
108     (else #f))))
109
110(define determine-proxy (make-parameter determine-proxy-from-environment))
111
112(define determine-proxy-username/password
113  (make-parameter (lambda (uri realm)
114                    (values (uri-username uri) (uri-password uri)))))
115
116;; Maybe only pass uri and realm to this?
117(define determine-username/password
118  (make-parameter (lambda (uri realm)
119                    (values (uri-username uri) (uri-password uri)))))
120
121(define client-software
122  (make-parameter (list (list "CHICKEN Scheme HTTP-client" "0.10" #f))))
123
124
125(define (with-mutex m thunk)
126  (dynamic-wind
127      (lambda () (mutex-lock! m))
128      thunk
129      (lambda () (mutex-unlock! m))))
130
131;; TODO: find a smarter storage mechanism.  Also, this implementation
132;; means cookies are shared between threads, which might not (always)
133;; be desirable.
134(define *cookie-jar* (list))
135
136;; A hash table containing uri-host&port as keys.  Values are circular
137;; lists of connections, pointing to the cons cell of the oldest one.
138(define *idle-connections*
139  (make-hash-table
140   (lambda (a b)
141     (and (equal? (uri-port a) (uri-port b))
142          (equal? (uri-host a) (uri-host b))))
143   (lambda (uri . maybe-bound)
144     (apply string-hash
145            (sprintf "~S ~S" (uri-host uri) (uri-port uri))
146            maybe-bound))))
147
148;; This mutex also stores the connection count.  However, it should be
149;; locked whenever *idle-connections* is accessed, because another
150;; thread should not be able to claim a connection we consider using.
151(define *idle-connections-mutex* (make-mutex '*idle-connections*))
152(mutex-specific-set! *idle-connections-mutex* 0)
153
154(cond-expand
155  ((not has-port-closed)
156   (define (port-closed? p)
157     (##sys#check-port p 'port-closed?)
158     (##sys#slot p 8)))
159  (else))
160
161(define (connection-dropped? con)
162  (or (port-closed? (http-connection-inport con))
163      (port-closed? (http-connection-outport con))
164      (condition-case
165          (and (char-ready? (http-connection-inport con))
166               (eof-object? (peek-char (http-connection-inport con))))
167        ;; Assume connection got reset when we get this exception
168        ((exn i/o net) #t))))
169
170;; Remove the first (oldest) idle connection which is still alive from
171;; the pool and return it.  Any dead connections are pruned.
172(define (grab-idle-connection! uri)
173  (with-mutex
174   *idle-connections-mutex*
175   (lambda ()
176     (define (take-first-idle-connection!)
177       ;; This picks the first idle connection, if any, and removes it
178       ;; from the list.
179       (and-let* ((head (hash-table-ref/default *idle-connections* uri #f))
180                  (connection (car head))
181                  (next (cdr head))
182                  (count (mutex-specific *idle-connections-mutex*)))
183         (if (eq? next head)
184             (hash-table-delete! *idle-connections* uri)
185             ;; Rip out the next entry and move its value forward
186             (begin (set-car! head (car next))
187                    (set-cdr! head (cdr next))))
188         (mutex-specific-set! *idle-connections-mutex* (sub1 count))
189         connection))
190     
191     (let lp ()
192       (and-let* ((con (take-first-idle-connection!)))
193         (cond ((connection-dropped? con)
194                (close-connection! con)
195                (lp))
196               (else con)))))))
197
198;; If max-idle-connections is not yet reached, add it to the pool.  We
199;; add it to the end because it is the freshest one.  This ensures
200;; we'll re-use the oldest first, trying to keep them all alive.
201(define (maybe-add-idle-connection! uri con)
202  (with-mutex
203   *idle-connections-mutex*
204   (lambda ()
205     (let ((count (mutex-specific *idle-connections-mutex*)))
206       (when (< count (max-idle-connections))
207         (cond ((hash-table-ref/default *idle-connections* uri #f) =>
208                (lambda (oldest-con)
209                  (let lp ((head (cdr oldest-con)))
210                    (if (eq? (cdr head) oldest-con) ; last?
211                        (set-cdr! head (cons con oldest-con))
212                        (lp (cdr head))))))
213               (else
214                (let ((new-con (list con)))
215                  (set-cdr! new-con new-con) ; (circular-list con)
216                  (hash-table-set! *idle-connections* uri new-con))))
217         (mutex-specific-set! *idle-connections-mutex* (add1 count)))))))
218
219
220(define (close-connection! uri-or-con)
221  (cond ((http-connection? uri-or-con)
222         (close-input-port (http-connection-inport uri-or-con))
223         (close-output-port (http-connection-outport uri-or-con)))
224        ((grab-idle-connection! uri-or-con) =>
225         (lambda (con)
226           (close-connection! con)            ; Close this one
227           (close-connection! uri-or-con))))) ; Check for others
228
229
230(define (close-idle-connections!)
231  (with-mutex
232   *idle-connections-mutex*
233   (lambda ()
234     (hash-table-walk
235      *idle-connections*
236      (lambda (uri conns)
237        (for-each
238         (lambda (con)
239           (close-input-port (http-connection-inport con))
240           (close-output-port (http-connection-outport con)))
241         conns)
242        (hash-table-delete! *idle-connections* uri)))
243     (mutex-specific-set! *idle-connections-mutex* 0))))
244
245;; OBSOLETE (kept for compat, remove in CHICKEN 5 version)
246(define close-all-connections! close-idle-connections!)
247
248;; Imports from the openssl egg, if available
249(define (dynamic-import module symbol default)
250  (handle-exceptions _ default (eval `(let () (use ,module) ,symbol))))
251
252(define ssl-connect
253  (dynamic-import 'openssl 'ssl-connect (lambda (h p) (values #f #f))))
254
255(define (default-server-connector uri proxy)
256  (let ((remote-end (or proxy uri)))
257    (case (uri-scheme remote-end)
258      ((#f http) (tcp-connect (uri-host remote-end) (uri-port remote-end)))
259      ((https) (receive (in out)
260                   (ssl-connect (uri-host remote-end)
261                                (uri-port remote-end))
262                 (if (and in out)       ; Ugly, but necessary
263                     (values in out)
264                     (http-client-error
265                      'ssl-connect
266                      (conc "Unable to connect over HTTPS. To fix this, "
267                            "install the openssl egg and try again")
268                      (list (uri->string uri))
269                      'missing-openssl-egg
270                      'request-uri uri 'proxy proxy))))
271      (else (http-client-error 'ensure-connection!
272                               "Unknown URI scheme"
273                               (list (uri-scheme remote-end))
274                               'unsupported-uri-scheme
275                               'uri-scheme (uri-scheme remote-end)
276                               'request-uri uri 'proxy proxy)))))
277
278(define server-connector (make-parameter default-server-connector))
279
280(define (ensure-connection! uri)
281  (or (grab-idle-connection! uri)
282      (let ((proxy ((determine-proxy) uri)))
283        (receive (in out) ((server-connector) uri proxy)
284          (make-http-connection uri in out proxy)))))
285
286(define (make-delimited-input-port port len)
287  (if (not len)
288      port ;; no need to delimit anything
289      (let ((pos 0))
290        (make-input-port
291         (lambda ()                     ; read-char
292           (if (= pos len)
293               #!eof
294               (let ((char (read-char port)))
295                 (set! pos (add1 pos))
296                 char)))
297         (lambda ()                     ; char-ready?
298           (or (= pos len) (char-ready? port)))
299         (lambda ()                     ; close
300           (close-input-port port))
301         (lambda ()                     ; peek-char
302           (if (= pos len)
303               #!eof
304               (peek-char port)))
305         (lambda (p bytes buf off)      ; read-string!
306           (let* ((bytes (min bytes (- len pos)))
307                  (bytes-read (read-string! bytes buf port off)))
308             (set! pos (+ pos bytes-read))
309             bytes-read))
310         (lambda (p limit)              ; read-line
311           (if (= pos len)
312               #!eof
313               (let* ((bytes-left (- len pos))
314                      (limit (min (or limit bytes-left) bytes-left))
315                      (line (read-line port limit)))
316                 (unless (eof-object? line)
317                         (set! pos (+ pos (string-length line))))
318                 line)))))))
319
320(define discard-remaining-data!
321  (let ((buf (make-string 1024)))       ; Doesn't matter, discarded anyway
322    (lambda (response port)
323      ;; If header not available or no response object passed, this reads until EOF
324      (let loop ((len (and response
325                           (header-value
326                            'content-length (response-headers response)))))
327        (if len
328            (when (> len 0)
329              (loop (- len (read-string! len buf port))))
330            (when (> (read-string! (string-length buf) buf port) 0)
331              (loop #f)))))))
332
333(define (add-headers req)
334  (let* ((uri (request-uri req))
335         (cookies (get-cookies-for-uri (request-uri req)))
336         (h `(,@(if (not (null? cookies)) `((cookie . ,cookies)) '())
337              (host ,(cons (uri-host uri) (and (not (uri-default-port? uri))
338                                               (uri-port uri))))
339              ,@(if (and (client-software) (not (null? (client-software))))
340                    `((user-agent ,(client-software)))
341                    '()))))
342    (update-request req
343                    headers: (headers h (request-headers req)))))
344
345(define (http-client-error loc msg args specific . rest)
346  (raise (make-composite-condition
347          (make-property-condition 'exn 'location loc 'message msg 'arguments args)
348          (make-property-condition 'http)
349          (apply make-property-condition specific rest))))
350
351;; RFC 2965, section 3.3.3
352(define (cookie-eq? a-name a-info b-name b-info)
353  (and (string-ci=? a-name b-name)
354       (string-ci=? (alist-ref 'domain a-info) (alist-ref 'domain b-info))
355       (equal?      (alist-ref 'path a-info)   (alist-ref 'path b-info))))
356
357(define (store-cookie! cookie-info set-cookie)
358  (let loop ((cookie (set-cookie->cookie set-cookie))
359             (jar *cookie-jar*))
360    (cond
361     ((null? jar)
362      (set! *cookie-jar* (cons (cons cookie-info cookie) *cookie-jar*))
363      *cookie-jar*)
364     ((cookie-eq? (car (get-value set-cookie)) cookie-info
365                  (car (get-value (cdar jar))) (caar jar))
366      (set-car! jar (cons cookie-info cookie))
367      *cookie-jar*)
368     (else (loop cookie (cdr jar))))))
369
370(define (delete-cookie! cookie-name cookie-info)
371  (set! *cookie-jar*
372    (remove! (lambda (c)
373               (cookie-eq? (car (get-value (cdr c))) (car c)
374                           cookie-name cookie-info))
375             *cookie-jar*)))
376
377(define (domain-match? uri pattern)
378  (let ((target (uri-host uri)))
379    (or (string-ci=? target pattern)
380        (and (string-prefix? "." pattern)
381             (string-suffix-ci? pattern target)))))
382
383(define (path-match? uri path)
384  (and (uri-path-absolute? uri)
385       (let loop ((path (cdr (uri-path path)))
386                  (uri-path (cdr (uri-path uri))))
387         (or (null? path)               ; done
388             (and (not (null? uri-path))
389                  (or (and (string-null? (car path)) (null? (cdr path)))
390
391                      (and (string=? (car path) (car uri-path))
392                           (loop (cdr path) (cdr uri-path)))))))))
393
394;; Set-cookie provides some info we don't need to store; strip the
395;; nonessential info
396(define (set-cookie->cookie info)
397  (vector (get-value info)
398          (filter (lambda (p)
399                    (member (car p) '(domain path version)))
400                  (get-params info))))
401
402(define (get-cookies-for-uri uri)
403  (let ((uri (if (string? uri) (uri-reference uri) uri)))
404    (map cdr
405         (sort!
406          (filter (lambda (c)
407                    (let ((info (car c)))
408                     (and (domain-match? uri (alist-ref 'domain info))
409                          (member (uri-port uri)
410                                  (alist-ref 'port info eq?
411                                             (list (uri-port uri))))
412                          (path-match? uri (alist-ref 'path info))
413                          (if (alist-ref 'secure info)
414                              (member (uri-scheme uri) '(https shttp))
415                              #t))))
416                  *cookie-jar*)
417          (lambda (a b)
418            (< (length (uri-path (alist-ref 'path (car a))))
419               (length (uri-path (alist-ref 'path (car b))))))))))
420
421(define (process-set-cookie! con uri r)
422  (let ((prefix-contains-dots?
423         (lambda (host pattern)
424           (string-index host #\. 0 (string-contains-ci host pattern)))))
425    (for-each (lambda (c)
426                (and-let* ((path (or (get-param 'path c) uri))
427                           ((path-match? uri path))
428                           ;; domain must start with dot. Add to intarweb!
429                           (dn (get-param 'domain c (uri-host uri)))
430                           (idx (string-index dn #\.))
431                           ((domain-match? uri dn))
432                           ((not (prefix-contains-dots? (uri-host uri) dn))))
433                  (store-cookie! `((path . ,path)
434                                   (domain . ,dn)
435                                   (secure . ,(get-param 'secure c))) c)))
436              (header-contents 'set-cookie (response-headers r) '()))
437    (for-each (lambda (c)
438                (and-let* (((get-param 'version c)) ; required for set-cookie2
439                           (path (or (get-param 'path c) uri))
440                           ((path-match? uri path))
441                           (dn (get-param 'domain c (uri-host uri)))
442                           ((or (string-ci=? dn ".local")
443                                (and (not (string-null? dn))
444                                     (string-index dn #\. 1))))
445                           ((domain-match? uri dn))
446                           ((not (prefix-contains-dots? (uri-host uri) dn)))
447                           ;; This is a little bit too messy for my tastes...
448                           ;; Can't use #f because that would shortcut and-let*
449                           (ports-value (get-param 'port c 'any))
450                           (ports (if (eq? ports-value #t)
451                                      (list (uri-port uri))
452                                      ports-value))
453                           ((or (eq? ports 'any)
454                                (member (uri-port uri) ports))))
455                  (store-cookie! `((path . ,path)
456                                   (domain . ,dn)
457                                   (port . ,(if (eq? ports 'any) #f ports))
458                                   (secure . ,(get-param 'secure c))) c)))
459              (header-contents 'set-cookie2 (response-headers r) '()))))
460
461(define (call-with-output-digest primitive proc)
462  (let* ((ctx-info (message-digest-primitive-context-info primitive))
463         (ctx (if (procedure? ctx-info) (ctx-info) (allocate ctx-info)))
464         (update-digest (message-digest-primitive-update primitive))
465         (update (lambda (str) (update-digest ctx str (string-length str))))
466         (outport (make-output-port update void)))
467    (handle-exceptions exn
468      (unless (procedure? ctx-info) (free ctx))
469      (let ((result (make-string
470                     (message-digest-primitive-digest-length primitive))))
471        ((message-digest-primitive-init primitive) ctx)
472        (proc outport)
473        ((message-digest-primitive-final primitive) ctx result)
474        (unless (procedure? ctx-info) (free ctx))
475        (string->hex result)))))
476
477(define (get-username/password for-request-header for-uri for-realm)
478  (if (eq? for-request-header 'authorization)
479      ((determine-username/password) for-uri for-realm)
480      ((determine-proxy-username/password) for-uri for-realm)))
481
482;;; TODO: We really, really should get rid of "writer" here.  Some kind of
483;;; generalized way to get the digest is required.  Jeez, HTTP sucks :(
484(define (basic-authenticator response response-header
485                             new-request request-header uri realm writer)
486  (receive (username password)
487    (get-username/password request-header uri realm)
488    (and username
489         (update-request
490          new-request
491          headers: (headers `((,request-header
492                               #(basic ((username . ,username)
493                                        (password . ,(or password ""))))))
494                            (request-headers new-request))))))
495
496(define (digest-authenticator response response-header
497                              new-request request-header uri realm writer)
498  (receive (username password)
499    (get-username/password request-header uri realm)
500    (and username
501         (let* ((hashconc
502                 (lambda args
503                   (message-digest-string
504                    (md5-primitive) (string-join (map ->string args) ":"))))
505                (authless-uri (update-uri (request-uri new-request)
506                                          username: #f password: #f))
507                ;; TODO: domain handling
508                (h (response-headers response))
509                (nonce (header-param 'nonce response-header h))
510                (opaque (header-param 'opaque response-header h))
511                (stale (header-param 'stale response-header h))
512                ;; TODO: "md5-sess" algorithm handling
513                (algorithm (header-param 'algorithm response-header h))
514                (qops (header-param 'qop response-header h '()))
515                (qop (cond ; Pick the strongest of the offered options
516                      ((member 'auth-int qops) 'auth-int)
517                      ((member 'auth qops) 'auth)
518                      (else #f)))
519                (cnonce (and qop (hashconc (current-seconds) realm)))
520                (nc (and qop 1)) ;; TODO
521                (ha1 (hashconc username realm (or password "")))
522                (ha2 (if (eq? qop 'auth-int)
523                         (hashconc (request-method new-request)
524                                   (uri->string authless-uri)
525                                   ;; Generate digest from writer's output
526                                   (call-with-output-digest
527                                    (md5-primitive)
528                                    (lambda (p)
529                                      (writer
530                                       (update-request new-request port: p)))))
531                         (hashconc (request-method new-request)
532                                   (uri->string authless-uri))))
533                (digest
534                 (case qop
535                   ((auth-int auth)
536                    (let ((hex-nc (string-pad (number->string nc 16) 8 #\0)))
537                      (hashconc ha1 nonce hex-nc cnonce qop ha2)))
538                   (else
539                    (hashconc ha1 nonce ha2)))))
540           (update-request new-request
541                           headers: (headers
542                                     `((,request-header
543                                        #(digest ((username . ,username)
544                                                  (uri . ,authless-uri)
545                                                  (realm . ,realm)
546                                                  (nonce . ,nonce)
547                                                  (cnonce . ,cnonce)
548                                                  (qop . ,qop)
549                                                  (nc . ,nc)
550                                                  (response . ,digest)
551                                                  (opaque . ,opaque)))))
552                                     (request-headers new-request)))))))
553
554(define http-authenticators
555  (make-parameter `((basic . ,basic-authenticator)
556                    (digest . ,digest-authenticator))))
557
558(define (authenticate-request request response writer proxy-uri)
559  (and-let* ((type (if (= (response-code response) 401) 'auth 'proxy))
560             (resp-header (if (eq? type 'auth)
561                              'www-authenticate
562                              'proxy-authenticate))
563             (req-header (if (eq? type 'auth)
564                             'authorization
565                             'proxy-authorization))
566             (authtype (header-value resp-header (response-headers response)))
567             (realm (header-param 'realm resp-header (response-headers response)))
568             (auth-uri (if (eq? type 'auth) (request-uri request) proxy-uri))
569             (authenticator (or (alist-ref authtype (http-authenticators))
570                                ;; Should we really raise an error?
571                                (http-client-error 'authenticate-request
572                                                   "Unknown authentication type"
573                                                   (list authtype)
574                                                   'unknown-authtype
575                                                   'authtype authtype
576                                                   'request request))))
577    (authenticator response resp-header request req-header
578                   auth-uri realm writer)))
579
580(define (call-with-response req writer reader)
581  (let loop ((attempts 0)
582             (redirects 0)
583             (req req))
584    (let* ((uri (request-uri req))
585           (con (ensure-connection! uri)))
586      (condition-case
587          (let* ((req (add-headers (update-request
588                                    req port: (http-connection-outport con))))
589                 ;; No outgoing URIs should ever contain credentials or fragments
590                 (req-uri (update-uri uri fragment: #f username: #f password: #f))
591                 ;; RFC1945, 5.1.2: "The absoluteURI form is only allowed
592                 ;; when the request is being made to a proxy."
593                 ;; RFC2616 is a little more regular (hosts MUST accept
594                 ;; absoluteURI), but it says "HTTP/1.1 clients will only
595                 ;; generate them in requests to proxies." (also 5.1.2)
596                 (req-uri (if (http-connection-proxy con)
597                              req-uri
598                              (update-uri req-uri host: #f port: #f scheme: #f
599                                          path: (or (uri-path req-uri) '(/ "")))))
600                 (request (write-request (update-request req uri: req-uri)))
601                 ;; Writer should be prepared to be called several times
602                 ;; Maybe try and figure out a good way to use the
603                 ;; "Expect: 100-continue" header to prevent too much writing?
604                 ;; Unfortunately RFC2616 says it's unreliable (8.2.3)...
605                 (_ (begin (writer request) (flush-output (request-port req))))
606                 (response (read-response (http-connection-inport con)))
607                 (cleanup!
608                  (lambda (clear-response-data?)
609                    (when clear-response-data?
610                      (discard-remaining-data! response
611                                               (response-port response)))
612                    (if (and (keep-alive? request)
613                             (keep-alive? response))
614                        (maybe-add-idle-connection! uri con)
615                        (close-connection! con)))))
616            (when response (process-set-cookie! con uri response))
617            (case (and response (response-code response))
618              ((#f)
619               ;; If the connection is closed prematurely, we SHOULD
620               ;; retry, according to RFC2616, section 8.2.4.  Currently
621               ;; don't do "binary exponential backoff", which we MAY do.
622               (if (or (not (max-retry-attempts)) ; unlimited?
623                       (<= attempts (max-retry-attempts)))
624                   (loop (add1 attempts) redirects req)
625                   (http-client-error 'send-request
626                                      "Server closed connection before sending response"
627                                      (list (uri->string uri))
628                                      'premature-disconnection
629                                      'uri uri 'request req)))
630              ;; TODO: According to spec, we should provide the user
631              ;; with a choice when it's not a GET or HEAD request...
632              ((301 302 303 307)
633               (cleanup! #t)
634               ;; Maybe we should switch to GET on 302 too?  It's not compliant,
635               ;; but very widespread and there's enough software that depends
636               ;; on that behaviour, which might break horribly otherwise...
637               (when (= (response-code response) 303)
638                 (request-method-set! req 'GET)) ; Switch to GET
639               (let* ((loc-uri (header-value 'location
640                                             (response-headers response)))
641                      (new-uri (uri-relative-to loc-uri uri)))
642                 (if (or (not (max-redirect-depth)) ; unlimited?
643                         (< redirects (max-redirect-depth)))
644                     (loop attempts
645                           (add1 redirects)
646                           (update-request req uri: new-uri))
647                     (http-client-error 'send-request
648                                        "Maximum number of redirects exceeded"
649                                        (list (uri->string uri))
650                                        'redirect-depth-exceeded
651                                        'uri uri 'new-uri new-uri
652                                        'request req))))
653              ;; TODO: Test this
654              ((305)             ; Use proxy (for this request only)
655               (cleanup! #t)
656               (let ((old-determine-proxy (determine-proxy))
657                     (proxy-uri (header-value 'location (response-headers response))))
658                 (parameterize ((determine-proxy
659                                 (lambda _
660                                   ;; Reset determine-proxy so the proxy is really
661                                   ;; used for only this one request.
662                                   ;; Yes, this is a bit of a hack :)
663                                   (determine-proxy old-determine-proxy)
664                                   proxy-uri)))
665                   (loop attempts redirects req))))
666              ((401 407) ; Unauthorized, Proxy Authentication Required
667               (cond ((and (or (not (max-retry-attempts)) ; unlimited?
668                               (<= attempts (max-retry-attempts)))
669                           (authenticate-request req response writer
670                                                 (http-connection-proxy con)))
671                      => (lambda (new-req)
672                           (cleanup! #t)
673                           (loop (add1 attempts) redirects new-req)))
674                     (else ;; pass it on, we can't throw an error here
675                      (let ((data (reader response)))
676                        (values data uri response)))))
677              (else (let ((data (reader response)))
678                      (cleanup! #f)
679                      (values data uri response)))))
680        (exn (exn i/o net)
681             ;; Try to recover from bad connections if we may retry.
682             (close-connection! con)
683             (if (and (or (not (max-retry-attempts)) ; unlimited?
684                          (<= attempts (max-retry-attempts)))
685                      ((retry-request?) req))
686                 (loop (add1 attempts) redirects req)
687                 (raise exn)))
688        (exn ()
689           ;; Never leave the port in an unknown/inconsistent state
690           ;; (the error could have occurred while reading, so there
691           ;;  might be data left in the buffer)
692           (close-connection! uri)
693           (raise exn))))))
694
695(define (kv-ref l k #!optional default)
696  (let ((rest (and (pair? l) (memq k l))))
697    (if (and rest (pair? (cdr rest))) (cadr rest) default)))
698
699;; This really, really sucks
700;; TODO: This crap probably belongs in its own egg?  Perhaps later when
701;; we have server-side handling for this too.
702(define (prepare-multipart-chunks boundary entries)
703  (append
704   (map (lambda (entry)
705          (if (not (cdr entry))         ; discard #f values
706              '()
707              (let* ((keys (cdr entry))
708                     (file (kv-ref keys file:))
709                     (filename (or (kv-ref keys filename:)
710                                   (and (port? file) (port-name file))
711                                   (and (string? file) file)))
712                     (filename (and filename
713                                    (pathname-strip-directory filename)))
714                     (h (headers `((content-disposition
715                                    #(form-data ((name . ,(car entry))
716                                                 (filename . ,filename))))
717                                   ,@(if filename
718                                         '((content-type application/octet-stream))
719                                         '()))))
720                     (hs (call-with-output-string
721                           (lambda (s)
722                             (unparse-headers
723                              ;; Allow user headers to override ours
724                              (headers (kv-ref keys headers: '()) h) s)))))
725                (list "--" boundary "\r\n" hs "\r\n"
726                      (cond ((string? file) (cons 'file file))
727                            ((port? file) (cons 'port file))
728                            ((eq? keys #t) "")
729                            (else (->string keys)))
730                  ;; The next boundary must always start on a new line
731                  "\r\n"))))
732        entries)
733   (list (list "--" boundary "--\r\n"))))
734
735(define (write-chunks output-port entries)
736  (for-each (lambda (entry)
737              (for-each (lambda (chunk)
738                          (if (pair? chunk)
739                              (let ((p (if (eq? 'file (car chunk))
740                                           (open-input-file (cdr chunk))
741                                           ;; Should be a port otherwise
742                                           (cdr chunk))))
743                                (handle-exceptions exn
744                                  (begin (close-input-port p) (raise exn))
745                                  (sendfile p output-port))
746                                (close-input-port p))
747                              (display chunk output-port)))
748                        entry))
749            entries))
750
751(define (calculate-chunk-size entries)
752  (call/cc
753   (lambda (return)
754     (fold (lambda (chunks total-size)
755             (fold (lambda (chunk total-size)
756                     (if (pair? chunk)
757                         (if (eq? 'port (car chunk))
758                             ;; Should be a file otherwise.
759                             ;; We can't calculate port lengths.
760                             ;; Let's just punt and hope the server
761                             ;; won't return "411 Length Required"...
762                             ;; (TODO: maybe try seeking it?)
763                             (return #f)
764                             (+ total-size (file-size (cdr chunk))))
765                         (+ total-size (string-length chunk))))
766                   total-size
767                   chunks))
768           0 entries))))
769
770(define (call-with-input-request* uri-or-request writer reader)
771  (let* ((type #f)
772         (uri (cond ((uri? uri-or-request) uri-or-request)
773                    ((string? uri-or-request) (uri-reference uri-or-request))
774                    (else (request-uri uri-or-request))))
775         (req (if (request? uri-or-request)
776                  uri-or-request
777                  (make-request uri: uri method: (if writer 'POST 'GET))))
778         (chunks (cond
779                  ((string? writer) (list (list writer)))
780                  ((and (list? writer)
781                        (any (lambda (x)
782                               (and (pair? x) (pair? (cdr x))
783                                    (eq? (cadr x) file:)))
784                             writer))
785                   (let ((bd (conc "----------------Multipart-=_"
786                                   (gensym 'boundary) "=_=" (current-process-id)
787                                   "=-=" (current-seconds))))
788                     (set! type `#(multipart/form-data ((boundary . ,bd))))
789                     (prepare-multipart-chunks bd writer)))
790                  ;; Default to "&" because some servers choke on ";"
791                  ((list? writer)
792                   (set! type 'application/x-www-form-urlencoded)
793                   (list (list (or (form-urlencode writer separator: "&")
794                                   (http-client-error
795                                    'call-with-input-request
796                                    "Invalid form data!"
797                                    (list (uri->string uri) writer reader)
798                                    'form-data-error
799                                    'request req
800                                    'form-data writer)))))
801                  (else #f)))
802         (req (update-request
803               req
804               headers: (headers
805                         `(,@(if chunks
806                                 `((content-length
807                                    ,(calculate-chunk-size chunks)))
808                                 '())
809                           ,@(if type `((content-type ,type)) '()))
810                         (request-headers req)))))
811    (call-with-response
812     req
813     (cond (chunks (lambda (r)
814                     (write-chunks (request-port r) chunks)
815                     (finish-request-body r)))
816           ((procedure? writer)
817            (lambda (r)
818              (writer (request-port r))
819              (finish-request-body r)))
820           (else (lambda x (void))))
821     (lambda (response)
822       (let ((port (make-delimited-input-port
823                    (response-port response)
824                    (header-value 'content-length (response-headers response))))
825             (body? ((response-has-message-body-for-request?) response req)))
826         (if (= 200 (response-class response)) ; Everything cool?
827             (let ((result (and body? reader (reader port response))))
828               (when body? (discard-remaining-data! #f port))
829               result)
830             (http-client-error
831              'call-with-input-request
832              ;; Message
833              (sprintf (case (response-class response)
834                         ((400) "Client error: ~A ~A")
835                         ((500) "Server error: ~A ~A")
836                         (else "Unexpected server response: ~A ~A"))
837                       (response-code response) (response-reason response))
838              ;; arguments
839              (list (uri->string uri))
840              ;; Specific type
841              (case (response-class response)
842                ((400) 'client-error)
843                ((500) 'server-error)
844                (else 'unexpected-server-response))
845              'response response
846              'body (and body? (read-string #f port)))))))))
847
848(define (call-with-input-request uri-or-request writer reader)
849  (call-with-input-request* uri-or-request writer (lambda (p r) (reader p))))
850
851(define (with-input-from-request uri-or-request writer reader)
852  (call-with-input-request uri-or-request
853                           (if (procedure? writer)
854                               (lambda (p) (with-output-to-port p writer))
855                               writer) ;; Assume it's an alist or #f
856                           (lambda (p) (with-input-from-port p reader))))
857
858)
Note: See TracBrowser for help on using the repository browser.