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

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

http-client: Don't read HTTP_PROXY env var if used in a CGI script.

CGI is detected through the presence of a REQUEST_METHOD env var.

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