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

Last change on this file since 33748 was 33748, checked in by sjamaan, 3 years ago

http-client: Close the connection before discarding it, if maximum is reached!

File size: 40.3 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.  If
201;; the maximum is reached, close and discard the connection.
202(define (maybe-add-idle-connection! uri con)
203  (with-mutex
204   *idle-connections-mutex*
205   (lambda ()
206     (let ((count (mutex-specific *idle-connections-mutex*)))
207       (if (< count (max-idle-connections))
208           (begin
209             (cond ((hash-table-ref/default *idle-connections* uri #f) =>
210                    (lambda (oldest-con)
211                      (let lp ((head (cdr oldest-con)))
212                        (if (eq? (cdr head) oldest-con) ; last?
213                            (set-cdr! head (cons con oldest-con))
214                            (lp (cdr head))))))
215                   (else
216                    (let ((new-con (list con)))
217                      (set-cdr! new-con new-con) ; (circular-list con)
218                      (hash-table-set! *idle-connections* uri new-con))))
219             (mutex-specific-set! *idle-connections-mutex* (add1 count)))
220           (close-connection! uri con))))))
221
222
223(define (close-connection! uri-or-con)
224  (cond ((http-connection? uri-or-con)
225         (close-input-port (http-connection-inport uri-or-con))
226         (close-output-port (http-connection-outport uri-or-con)))
227        ((grab-idle-connection! uri-or-con) =>
228         (lambda (con)
229           (close-connection! con)            ; Close this one
230           (close-connection! uri-or-con))))) ; Check for others
231
232
233(define (close-idle-connections!)
234  (with-mutex
235   *idle-connections-mutex*
236   (lambda ()
237     (hash-table-walk
238      *idle-connections*
239      (lambda (uri conns)
240        (for-each
241         (lambda (con)
242           (close-input-port (http-connection-inport con))
243           (close-output-port (http-connection-outport con)))
244         conns)
245        (hash-table-delete! *idle-connections* uri)))
246     (mutex-specific-set! *idle-connections-mutex* 0))))
247
248;; OBSOLETE (kept for compat, remove in CHICKEN 5 version)
249(define close-all-connections! close-idle-connections!)
250
251;; Imports from the openssl egg, if available
252(define (dynamic-import module symbol default)
253  (handle-exceptions _ default (eval `(let () (use ,module) ,symbol))))
254
255(define ssl-connect
256  (dynamic-import 'openssl 'ssl-connect (lambda (h p) (values #f #f))))
257
258(define (default-server-connector uri proxy)
259  (let ((remote-end (or proxy uri)))
260    (case (uri-scheme remote-end)
261      ((#f http) (tcp-connect (uri-host remote-end) (uri-port remote-end)))
262      ((https) (receive (in out)
263                   (ssl-connect (uri-host remote-end)
264                                (uri-port remote-end))
265                 (if (and in out)       ; Ugly, but necessary
266                     (values in out)
267                     (http-client-error
268                      'ssl-connect
269                      (conc "Unable to connect over HTTPS. To fix this, "
270                            "install the openssl egg and try again")
271                      (list (uri->string uri))
272                      'missing-openssl-egg
273                      'request-uri uri 'proxy proxy))))
274      (else (http-client-error 'ensure-connection!
275                               "Unknown URI scheme"
276                               (list (uri-scheme remote-end))
277                               'unsupported-uri-scheme
278                               'uri-scheme (uri-scheme remote-end)
279                               'request-uri uri 'proxy proxy)))))
280
281(define server-connector (make-parameter default-server-connector))
282
283(define (ensure-connection! uri)
284  (or (grab-idle-connection! uri)
285      (let ((proxy ((determine-proxy) uri)))
286        (receive (in out) ((server-connector) uri proxy)
287          (make-http-connection uri in out proxy)))))
288
289(define (make-delimited-input-port port len)
290  (if (not len)
291      port ;; no need to delimit anything
292      (let ((pos 0))
293        (make-input-port
294         (lambda ()                     ; read-char
295           (if (= pos len)
296               #!eof
297               (let ((char (read-char port)))
298                 (set! pos (add1 pos))
299                 char)))
300         (lambda ()                     ; char-ready?
301           (or (= pos len) (char-ready? port)))
302         (lambda ()                     ; close
303           (close-input-port port))
304         (lambda ()                     ; peek-char
305           (if (= pos len)
306               #!eof
307               (peek-char port)))
308         (lambda (p bytes buf off)      ; read-string!
309           (let* ((bytes (min bytes (- len pos)))
310                  (bytes-read (read-string! bytes buf port off)))
311             (set! pos (+ pos bytes-read))
312             bytes-read))
313         (lambda (p limit)              ; read-line
314           (if (= pos len)
315               #!eof
316               (let* ((bytes-left (- len pos))
317                      (limit (min (or limit bytes-left) bytes-left))
318                      (line (read-line port limit)))
319                 (unless (eof-object? line)
320                         (set! pos (+ pos (string-length line))))
321                 line)))))))
322
323(define discard-remaining-data!
324  (let ((buf (make-string 1024)))       ; Doesn't matter, discarded anyway
325    (lambda (response port)
326      ;; If header not available or no response object passed, this reads until EOF
327      (let loop ((len (and response
328                           (header-value
329                            'content-length (response-headers response)))))
330        (if len
331            (when (> len 0)
332              (loop (- len (read-string! len buf port))))
333            (when (> (read-string! (string-length buf) buf port) 0)
334              (loop #f)))))))
335
336(define (add-headers req)
337  (let* ((uri (request-uri req))
338         (cookies (get-cookies-for-uri (request-uri req)))
339         (h `(,@(if (not (null? cookies)) `((cookie . ,cookies)) '())
340              (host ,(cons (uri-host uri) (and (not (uri-default-port? uri))
341                                               (uri-port uri))))
342              ,@(if (and (client-software) (not (null? (client-software))))
343                    `((user-agent ,(client-software)))
344                    '()))))
345    (update-request req
346                    headers: (headers h (request-headers req)))))
347
348(define (http-client-error loc msg args specific . rest)
349  (raise (make-composite-condition
350          (make-property-condition 'exn 'location loc 'message msg 'arguments args)
351          (make-property-condition 'http)
352          (apply make-property-condition specific rest))))
353
354;; RFC 2965, section 3.3.3
355(define (cookie-eq? a-name a-info b-name b-info)
356  (and (string-ci=? a-name b-name)
357       (string-ci=? (alist-ref 'domain a-info) (alist-ref 'domain b-info))
358       (equal?      (alist-ref 'path a-info)   (alist-ref 'path b-info))))
359
360(define (store-cookie! cookie-info set-cookie)
361  (let loop ((cookie (set-cookie->cookie set-cookie))
362             (jar *cookie-jar*))
363    (cond
364     ((null? jar)
365      (set! *cookie-jar* (cons (cons cookie-info cookie) *cookie-jar*))
366      *cookie-jar*)
367     ((cookie-eq? (car (get-value set-cookie)) cookie-info
368                  (car (get-value (cdar jar))) (caar jar))
369      (set-car! jar (cons cookie-info cookie))
370      *cookie-jar*)
371     (else (loop cookie (cdr jar))))))
372
373(define (delete-cookie! cookie-name cookie-info)
374  (set! *cookie-jar*
375    (remove! (lambda (c)
376               (cookie-eq? (car (get-value (cdr c))) (car c)
377                           cookie-name cookie-info))
378             *cookie-jar*)))
379
380(define (domain-match? uri pattern)
381  (let ((target (uri-host uri)))
382    (or (string-ci=? target pattern)
383        (and (string-prefix? "." pattern)
384             (string-suffix-ci? pattern target)))))
385
386(define (path-match? uri path)
387  (and (uri-path-absolute? uri)
388       (let loop ((path (cdr (uri-path path)))
389                  (uri-path (cdr (uri-path uri))))
390         (or (null? path)               ; done
391             (and (not (null? uri-path))
392                  (or (and (string-null? (car path)) (null? (cdr path)))
393
394                      (and (string=? (car path) (car uri-path))
395                           (loop (cdr path) (cdr uri-path)))))))))
396
397;; Set-cookie provides some info we don't need to store; strip the
398;; nonessential info
399(define (set-cookie->cookie info)
400  (vector (get-value info)
401          (filter (lambda (p)
402                    (member (car p) '(domain path version)))
403                  (get-params info))))
404
405(define (get-cookies-for-uri uri)
406  (let ((uri (if (string? uri) (uri-reference uri) uri)))
407    (map cdr
408         (sort!
409          (filter (lambda (c)
410                    (let ((info (car c)))
411                     (and (domain-match? uri (alist-ref 'domain info))
412                          (member (uri-port uri)
413                                  (alist-ref 'port info eq?
414                                             (list (uri-port uri))))
415                          (path-match? uri (alist-ref 'path info))
416                          (if (alist-ref 'secure info)
417                              (member (uri-scheme uri) '(https shttp))
418                              #t))))
419                  *cookie-jar*)
420          (lambda (a b)
421            (< (length (uri-path (alist-ref 'path (car a))))
422               (length (uri-path (alist-ref 'path (car b))))))))))
423
424(define (process-set-cookie! con uri r)
425  (let ((prefix-contains-dots?
426         (lambda (host pattern)
427           (string-index host #\. 0 (string-contains-ci host pattern)))))
428    (for-each (lambda (c)
429                (and-let* ((path (or (get-param 'path c) uri))
430                           ((path-match? uri path))
431                           ;; domain must start with dot. Add to intarweb!
432                           (dn (get-param 'domain c (uri-host uri)))
433                           (idx (string-index dn #\.))
434                           ((domain-match? uri dn))
435                           ((not (prefix-contains-dots? (uri-host uri) dn))))
436                  (store-cookie! `((path . ,path)
437                                   (domain . ,dn)
438                                   (secure . ,(get-param 'secure c))) c)))
439              (header-contents 'set-cookie (response-headers r) '()))
440    (for-each (lambda (c)
441                (and-let* (((get-param 'version c)) ; required for set-cookie2
442                           (path (or (get-param 'path c) uri))
443                           ((path-match? uri path))
444                           (dn (get-param 'domain c (uri-host uri)))
445                           ((or (string-ci=? dn ".local")
446                                (and (not (string-null? dn))
447                                     (string-index dn #\. 1))))
448                           ((domain-match? uri dn))
449                           ((not (prefix-contains-dots? (uri-host uri) dn)))
450                           ;; This is a little bit too messy for my tastes...
451                           ;; Can't use #f because that would shortcut and-let*
452                           (ports-value (get-param 'port c 'any))
453                           (ports (if (eq? ports-value #t)
454                                      (list (uri-port uri))
455                                      ports-value))
456                           ((or (eq? ports 'any)
457                                (member (uri-port uri) ports))))
458                  (store-cookie! `((path . ,path)
459                                   (domain . ,dn)
460                                   (port . ,(if (eq? ports 'any) #f ports))
461                                   (secure . ,(get-param 'secure c))) c)))
462              (header-contents 'set-cookie2 (response-headers r) '()))))
463
464(define (call-with-output-digest primitive proc)
465  (let* ((ctx-info (message-digest-primitive-context-info primitive))
466         (ctx (if (procedure? ctx-info) (ctx-info) (allocate ctx-info)))
467         (update-digest (message-digest-primitive-update primitive))
468         (update (lambda (str) (update-digest ctx str (string-length str))))
469         (outport (make-output-port update void)))
470    (handle-exceptions exn
471      (unless (procedure? ctx-info) (free ctx))
472      (let ((result (make-string
473                     (message-digest-primitive-digest-length primitive))))
474        ((message-digest-primitive-init primitive) ctx)
475        (proc outport)
476        ((message-digest-primitive-final primitive) ctx result)
477        (unless (procedure? ctx-info) (free ctx))
478        (string->hex result)))))
479
480(define (get-username/password for-request-header for-uri for-realm)
481  (if (eq? for-request-header 'authorization)
482      ((determine-username/password) for-uri for-realm)
483      ((determine-proxy-username/password) for-uri for-realm)))
484
485;;; TODO: We really, really should get rid of "writer" here.  Some kind of
486;;; generalized way to get the digest is required.  Jeez, HTTP sucks :(
487(define (basic-authenticator response response-header
488                             new-request request-header uri realm writer)
489  (receive (username password)
490    (get-username/password request-header uri realm)
491    (and username
492         (update-request
493          new-request
494          headers: (headers `((,request-header
495                               #(basic ((username . ,username)
496                                        (password . ,(or password ""))))))
497                            (request-headers new-request))))))
498
499(define (digest-authenticator response response-header
500                              new-request request-header uri realm writer)
501  (receive (username password)
502    (get-username/password request-header uri realm)
503    (and username
504         (let* ((hashconc
505                 (lambda args
506                   (message-digest-string
507                    (md5-primitive) (string-join (map ->string args) ":"))))
508                (authless-uri (update-uri (request-uri new-request)
509                                          username: #f password: #f))
510                ;; TODO: domain handling
511                (h (response-headers response))
512                (nonce (header-param 'nonce response-header h))
513                (opaque (header-param 'opaque response-header h))
514                (stale (header-param 'stale response-header h))
515                ;; TODO: "md5-sess" algorithm handling
516                (algorithm (header-param 'algorithm response-header h))
517                (qops (header-param 'qop response-header h '()))
518                (qop (cond ; Pick the strongest of the offered options
519                      ((member 'auth-int qops) 'auth-int)
520                      ((member 'auth qops) 'auth)
521                      (else #f)))
522                (cnonce (and qop (hashconc (current-seconds) realm)))
523                (nc (and qop 1)) ;; TODO
524                (ha1 (hashconc username realm (or password "")))
525                (ha2 (if (eq? qop 'auth-int)
526                         (hashconc (request-method new-request)
527                                   (uri->string authless-uri)
528                                   ;; Generate digest from writer's output
529                                   (call-with-output-digest
530                                    (md5-primitive)
531                                    (lambda (p)
532                                      (writer
533                                       (update-request new-request port: p)))))
534                         (hashconc (request-method new-request)
535                                   (uri->string authless-uri))))
536                (digest
537                 (case qop
538                   ((auth-int auth)
539                    (let ((hex-nc (string-pad (number->string nc 16) 8 #\0)))
540                      (hashconc ha1 nonce hex-nc cnonce qop ha2)))
541                   (else
542                    (hashconc ha1 nonce ha2)))))
543           (update-request new-request
544                           headers: (headers
545                                     `((,request-header
546                                        #(digest ((username . ,username)
547                                                  (uri . ,authless-uri)
548                                                  (realm . ,realm)
549                                                  (nonce . ,nonce)
550                                                  (cnonce . ,cnonce)
551                                                  (qop . ,qop)
552                                                  (nc . ,nc)
553                                                  (response . ,digest)
554                                                  (opaque . ,opaque)))))
555                                     (request-headers new-request)))))))
556
557(define http-authenticators
558  (make-parameter `((basic . ,basic-authenticator)
559                    (digest . ,digest-authenticator))))
560
561(define (authenticate-request request response writer proxy-uri)
562  (and-let* ((type (if (= (response-code response) 401) 'auth 'proxy))
563             (resp-header (if (eq? type 'auth)
564                              'www-authenticate
565                              'proxy-authenticate))
566             (req-header (if (eq? type 'auth)
567                             'authorization
568                             'proxy-authorization))
569             (authtype (header-value resp-header (response-headers response)))
570             (realm (header-param 'realm resp-header (response-headers response)))
571             (auth-uri (if (eq? type 'auth) (request-uri request) proxy-uri))
572             (authenticator (or (alist-ref authtype (http-authenticators))
573                                ;; Should we really raise an error?
574                                (http-client-error 'authenticate-request
575                                                   "Unknown authentication type"
576                                                   (list authtype)
577                                                   'unknown-authtype
578                                                   'authtype authtype
579                                                   'request request))))
580    (authenticator response resp-header request req-header
581                   auth-uri realm writer)))
582
583(define (call-with-response req writer reader)
584  (let loop ((attempts 0)
585             (redirects 0)
586             (req req))
587    (let* ((uri (request-uri req))
588           (con (ensure-connection! uri)))
589      (condition-case
590          (let* ((req (add-headers (update-request
591                                    req port: (http-connection-outport con))))
592                 ;; No outgoing URIs should ever contain credentials or fragments
593                 (req-uri (update-uri uri fragment: #f username: #f password: #f))
594                 ;; RFC1945, 5.1.2: "The absoluteURI form is only allowed
595                 ;; when the request is being made to a proxy."
596                 ;; RFC2616 is a little more regular (hosts MUST accept
597                 ;; absoluteURI), but it says "HTTP/1.1 clients will only
598                 ;; generate them in requests to proxies." (also 5.1.2)
599                 (req-uri (if (http-connection-proxy con)
600                              req-uri
601                              (update-uri req-uri host: #f port: #f scheme: #f
602                                          path: (or (uri-path req-uri) '(/ "")))))
603                 (request (write-request (update-request req uri: req-uri)))
604                 ;; Writer should be prepared to be called several times
605                 ;; Maybe try and figure out a good way to use the
606                 ;; "Expect: 100-continue" header to prevent too much writing?
607                 ;; Unfortunately RFC2616 says it's unreliable (8.2.3)...
608                 (_ (begin (writer request) (flush-output (request-port req))))
609                 (response (read-response (http-connection-inport con)))
610                 (cleanup!
611                  (lambda (clear-response-data?)
612                    (when clear-response-data?
613                      (discard-remaining-data! response
614                                               (response-port response)))
615                    (if (and (keep-alive? request)
616                             (keep-alive? response))
617                        (maybe-add-idle-connection! uri con)
618                        (close-connection! con)))))
619            (when response (process-set-cookie! con uri response))
620            (case (and response (response-code response))
621              ((#f)
622               ;; If the connection is closed prematurely, we SHOULD
623               ;; retry, according to RFC2616, section 8.2.4.  Currently
624               ;; don't do "binary exponential backoff", which we MAY do.
625               (if (or (not (max-retry-attempts)) ; unlimited?
626                       (<= attempts (max-retry-attempts)))
627                   (loop (add1 attempts) redirects req)
628                   (http-client-error 'send-request
629                                      "Server closed connection before sending response"
630                                      (list (uri->string uri))
631                                      'premature-disconnection
632                                      'uri uri 'request req)))
633              ;; TODO: According to spec, we should provide the user
634              ;; with a choice when it's not a GET or HEAD request...
635              ((301 302 303 307)
636               (cleanup! #t)
637               ;; Maybe we should switch to GET on 302 too?  It's not compliant,
638               ;; but very widespread and there's enough software that depends
639               ;; on that behaviour, which might break horribly otherwise...
640               (when (= (response-code response) 303)
641                 (request-method-set! req 'GET)) ; Switch to GET
642               (let* ((loc-uri (header-value 'location
643                                             (response-headers response)))
644                      (new-uri (uri-relative-to loc-uri uri)))
645                 (if (or (not (max-redirect-depth)) ; unlimited?
646                         (< redirects (max-redirect-depth)))
647                     (loop attempts
648                           (add1 redirects)
649                           (update-request req uri: new-uri))
650                     (http-client-error 'send-request
651                                        "Maximum number of redirects exceeded"
652                                        (list (uri->string uri))
653                                        'redirect-depth-exceeded
654                                        'uri uri 'new-uri new-uri
655                                        'request req))))
656              ;; TODO: Test this
657              ((305)             ; Use proxy (for this request only)
658               (cleanup! #t)
659               (let ((old-determine-proxy (determine-proxy))
660                     (proxy-uri (header-value 'location (response-headers response))))
661                 (parameterize ((determine-proxy
662                                 (lambda _
663                                   ;; Reset determine-proxy so the proxy is really
664                                   ;; used for only this one request.
665                                   ;; Yes, this is a bit of a hack :)
666                                   (determine-proxy old-determine-proxy)
667                                   proxy-uri)))
668                   (loop attempts redirects req))))
669              ((401 407) ; Unauthorized, Proxy Authentication Required
670               (cond ((and (or (not (max-retry-attempts)) ; unlimited?
671                               (<= attempts (max-retry-attempts)))
672                           (authenticate-request req response writer
673                                                 (http-connection-proxy con)))
674                      => (lambda (new-req)
675                           (cleanup! #t)
676                           (loop (add1 attempts) redirects new-req)))
677                     (else ;; pass it on, we can't throw an error here
678                      (let ((data (reader response)))
679                        (values data uri response)))))
680              (else (let ((data (reader response)))
681                      (cleanup! #f)
682                      (values data uri response)))))
683        (exn (exn i/o net)
684             ;; Try to recover from bad connections if we may retry.
685             (close-connection! con)
686             (if (and (or (not (max-retry-attempts)) ; unlimited?
687                          (<= attempts (max-retry-attempts)))
688                      ((retry-request?) req))
689                 (loop (add1 attempts) redirects req)
690                 (raise exn)))
691        (exn ()
692           ;; Never leave the port in an unknown/inconsistent state
693           ;; (the error could have occurred while reading, so there
694           ;;  might be data left in the buffer)
695           (close-connection! uri)
696           (raise exn))))))
697
698(define (kv-ref l k #!optional default)
699  (let ((rest (and (pair? l) (memq k l))))
700    (if (and rest (pair? (cdr rest))) (cadr rest) default)))
701
702;; This really, really sucks
703;; TODO: This crap probably belongs in its own egg?  Perhaps later when
704;; we have server-side handling for this too.
705(define (prepare-multipart-chunks boundary entries)
706  (append
707   (map (lambda (entry)
708          (if (not (cdr entry))         ; discard #f values
709              '()
710              (let* ((keys (cdr entry))
711                     (file (kv-ref keys file:))
712                     (filename (or (kv-ref keys filename:)
713                                   (and (port? file) (port-name file))
714                                   (and (string? file) file)))
715                     (filename (and filename
716                                    (pathname-strip-directory filename)))
717                     (h (headers `((content-disposition
718                                    #(form-data ((name . ,(car entry))
719                                                 (filename . ,filename))))
720                                   ,@(if filename
721                                         '((content-type application/octet-stream))
722                                         '()))))
723                     (hs (call-with-output-string
724                           (lambda (s)
725                             (unparse-headers
726                              ;; Allow user headers to override ours
727                              (headers (kv-ref keys headers: '()) h) s)))))
728                (list "--" boundary "\r\n" hs "\r\n"
729                      (cond ((string? file) (cons 'file file))
730                            ((port? file) (cons 'port file))
731                            ((eq? keys #t) "")
732                            (else (->string keys)))
733                  ;; The next boundary must always start on a new line
734                  "\r\n"))))
735        entries)
736   (list (list "--" boundary "--\r\n"))))
737
738(define (write-chunks output-port entries)
739  (for-each (lambda (entry)
740              (for-each (lambda (chunk)
741                          (if (pair? chunk)
742                              (let ((p (if (eq? 'file (car chunk))
743                                           (open-input-file (cdr chunk))
744                                           ;; Should be a port otherwise
745                                           (cdr chunk))))
746                                (handle-exceptions exn
747                                  (begin (close-input-port p) (raise exn))
748                                  (sendfile p output-port))
749                                (close-input-port p))
750                              (display chunk output-port)))
751                        entry))
752            entries))
753
754(define (calculate-chunk-size entries)
755  (call/cc
756   (lambda (return)
757     (fold (lambda (chunks total-size)
758             (fold (lambda (chunk total-size)
759                     (if (pair? chunk)
760                         (if (eq? 'port (car chunk))
761                             ;; Should be a file otherwise.
762                             ;; We can't calculate port lengths.
763                             ;; Let's just punt and hope the server
764                             ;; won't return "411 Length Required"...
765                             ;; (TODO: maybe try seeking it?)
766                             (return #f)
767                             (+ total-size (file-size (cdr chunk))))
768                         (+ total-size (string-length chunk))))
769                   total-size
770                   chunks))
771           0 entries))))
772
773(define (call-with-input-request* uri-or-request writer reader)
774  (let* ((type #f)
775         (uri (cond ((uri? uri-or-request) uri-or-request)
776                    ((string? uri-or-request) (uri-reference uri-or-request))
777                    (else (request-uri uri-or-request))))
778         (req (if (request? uri-or-request)
779                  uri-or-request
780                  (make-request uri: uri method: (if writer 'POST 'GET))))
781         (chunks (cond
782                  ((string? writer) (list (list writer)))
783                  ((and (list? writer)
784                        (any (lambda (x)
785                               (and (pair? x) (pair? (cdr x))
786                                    (eq? (cadr x) file:)))
787                             writer))
788                   (let ((bd (conc "----------------Multipart-=_"
789                                   (gensym 'boundary) "=_=" (current-process-id)
790                                   "=-=" (current-seconds))))
791                     (set! type `#(multipart/form-data ((boundary . ,bd))))
792                     (prepare-multipart-chunks bd writer)))
793                  ;; Default to "&" because some servers choke on ";"
794                  ((list? writer)
795                   (set! type 'application/x-www-form-urlencoded)
796                   (list (list (or (form-urlencode writer separator: "&")
797                                   (http-client-error
798                                    'call-with-input-request
799                                    "Invalid form data!"
800                                    (list (uri->string uri) writer reader)
801                                    'form-data-error
802                                    'request req
803                                    'form-data writer)))))
804                  (else #f)))
805         (req (update-request
806               req
807               headers: (headers
808                         `(,@(if chunks
809                                 `((content-length
810                                    ,(calculate-chunk-size chunks)))
811                                 '())
812                           ,@(if type `((content-type ,type)) '()))
813                         (request-headers req)))))
814    (call-with-response
815     req
816     (cond (chunks (lambda (r)
817                     (write-chunks (request-port r) chunks)
818                     (finish-request-body r)))
819           ((procedure? writer)
820            (lambda (r)
821              (writer (request-port r))
822              (finish-request-body r)))
823           (else (lambda x (void))))
824     (lambda (response)
825       (let ((port (make-delimited-input-port
826                    (response-port response)
827                    (header-value 'content-length (response-headers response))))
828             (body? ((response-has-message-body-for-request?) response req)))
829         (if (= 200 (response-class response)) ; Everything cool?
830             (let ((result (and body? reader (reader port response))))
831               (when body? (discard-remaining-data! #f port))
832               result)
833             (http-client-error
834              'call-with-input-request
835              ;; Message
836              (sprintf (case (response-class response)
837                         ((400) "Client error: ~A ~A")
838                         ((500) "Server error: ~A ~A")
839                         (else "Unexpected server response: ~A ~A"))
840                       (response-code response) (response-reason response))
841              ;; arguments
842              (list (uri->string uri))
843              ;; Specific type
844              (case (response-class response)
845                ((400) 'client-error)
846                ((500) 'server-error)
847                (else 'unexpected-server-response))
848              'response response
849              'body (and body? (read-string #f port)))))))))
850
851(define (call-with-input-request uri-or-request writer reader)
852  (call-with-input-request* uri-or-request writer (lambda (p r) (reader p))))
853
854(define (with-input-from-request uri-or-request writer reader)
855  (call-with-input-request uri-or-request
856                           (if (procedure? writer)
857                               (lambda (p) (with-output-to-port p writer))
858                               writer) ;; Assume it's an alist or #f
859                           (lambda (p) (with-input-from-port p reader))))
860
861)
Note: See TracBrowser for help on using the repository browser.