source: project/release/4/http-client/tags/0.12/http-client.scm @ 33933

Last change on this file since 33933 was 33933, checked in by sjamaan, 18 months ago

Tag http-client 0.13

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