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

Last change on this file since 26784 was 26784, checked in by sjamaan, 9 years ago

http-client: Use intarweb's new response-has-method-body-for-request? parameter to determine whether to read out the response using the user-supplied procedure. Also, if reader is #f, ignore it

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