Index: http-client.scm
===================================================================
--- http-client.scm	(リビジョン 355)
+++ http-client.scm	(作業コピー)
@@ -37,7 +37,7 @@
   (fixnum)
   ;(no-bound-checks)
   (export 
-   http:send-request http:GET http:POST) 
+   http:send-request http:GET http:POST http:close-all-connections!)
   (foreign-declare #<<EOF
 #ifdef _WIN32
 #include "WINSOCK2.H"
@@ -54,7 +54,54 @@
 (require 'http-utils)
 (require-for-syntax 'regex-case)
 
+;; Connection pool
+(define connections
+  (make-parameter (make-hash-table equal?)))
+(define connections-owner
+  (make-parameter (current-thread)))
 
+(define (ensure-local-connections)
+  (unless (eq? (connections-owner) (current-thread))
+    (connections (make-hash-table equal?))
+    (connections-owner (current-thread))))
+
+(define (connection-id host port)
+  (cons port host))
+
+(define (is-connected? id)
+  (ensure-local-connections)
+  (hash-table-exists? (connections) id))
+
+(define (get-connection id)
+  (ensure-local-connections)
+  (apply values (hash-table-ref (connections) id)))
+
+(define (add-connection! id in out)
+  (ensure-local-connections)
+  (hash-table-set! (connections) id (list in out)))
+  
+(define (close-connection! id)
+  (ensure-local-connections)
+  (let ((con (hash-table-ref (connections) id)))
+    (hash-table-delete! (connections) id)
+    (close-input-port (car con))
+    (close-output-port (cadr con))))
+
+(define (http:close-all-connections!)
+  (ensure-local-connections)
+  (hash-table-walk
+   (connections)
+   (lambda (id con)
+     (hash-table-delete! (connections) id)
+     (close-input-port (car con))
+     (close-output-port (cadr con)))))
+
+(define (is-keep-alive? status as)
+  (or (and (substring-ci=? status "http/1.0")
+           (string-ci=? (alist-ref "connection" as string=? "") "keep-alive"))
+      (and (substring-ci=? status "http/1.1")
+           (not (string-ci=? (alist-ref "connection" as string=? "") "close")))))
+
 ;; Client API:
 
 (define url-rx
@@ -89,39 +136,55 @@
     (let* ([req (if (string? req) 
 		    (http:make-request 'GET req '(("Connection" . "close")))
 		    req) ] 
-	   [as (remove (lambda (a) (string=? (car a) "content-length")) (http:request-attributes req))]
+	   [as (remove (lambda (a) (string-ci=? (car a) "content-length"))
+                       (http:request-attributes req))]
 	   [url (http:request-url req)] 
 	   [b (http:request-body req)] )
       (let*-values ([(serv host port path) (parse-url-host-and-port url)]
-		    [(i o) (cond ((and in out)
-				  (values in out))
-				 ((string=? serv "https")
-				  (ssl-connect host port (http:request-sslctx req)))
-				 (else
-			          (tcp-connect host port)) ) ] )
-	(fprintf o "~A ~A ~A\r\nHost: ~A:~A\r\n" 
-		 (string-upcase (symbol->string (http:request-method req)))
-		 path
-		 (string-upcase (symbol->string (http:request-protocol req)))
-		 host port)
-	(for-each
-	 (lambda (a)
-	   (fprintf o "~A: ~A\r\n" (car a) (cdr a)) )
-	 as)
-	(if (string? b)
-	    (begin
-	      (fprintf o "Content-Length: ~A\r\n\r\n" (string-length b))
-	      (display b o) )
-	    (display "Content-Length: 0\r\n\r\n" o) )
-	(unless in (set-finalizer! i close-input-port))
-	(unless out (set-finalizer! o close-output-port))
-	(let ([header (read-line i)])
-	  (let ([a (http:read-request-attributes i)])
-	    (values header a i o) ) ) ) ) ) )
+                    [(id) (connection-id host port)])
+        (let retry ()
+	  (condition-case
+           (let-values
+             ([(i o) (cond ((and in out) (values in out))
+                           ((is-connected? id) (get-connection id))
+                           ((string=? serv "https") (ssl-connect host port (http:request-sslctx req)))
+                           (else (tcp-connect host port)))])
+             (fprintf o "~A ~A ~A\r\nHost: ~A:~A\r\n" 
+                      (string-upcase (symbol->string (http:request-method req)))
+                      path
+                      (string-upcase (symbol->string (http:request-protocol req)))
+                      host port)
+             (for-each
+              (lambda (a)
+                (fprintf o "~A: ~A\r\n" (car a) (cdr a)) )
+              as)
+             (if (string? b)
+                 (begin
+                   (fprintf o "Content-Length: ~A\r\n\r\n" (string-length b))
+                   (display b o) )
+                 (display "Content-Length: 0\r\n\r\n" o) )
+             (let ([header (read-line i)])
+               (let ([a (http:read-request-attributes i)])
+                 (cond ((and in out))
+                       ((is-keep-alive? header a)
+                        (or (is-connected? id) (add-connection! id i o)))
+                       (else
+                        (set-finalizer! i close-input-port)
+                        (set-finalizer! o close-output-port)))
+                 (values header a i o))))
+           (exn (exn i/o net)
+                (cond ((and in out) (set! in #f) (set! out #f) (retry))
+                      ((is-connected? id) (close-connection! id) (retry))
+                      (else (signal exn))))))))))
 
 (define (http:GET req)
   (let-values ([(header a i o) (http:send-request req)])
-    (read-all i) ) )
+    (read-string
+     (cond ((alist-ref "content-length" header string=?)
+            => string->number)
+           (else
+            #f))
+     i)))
 
 (define (http:POST req #!optional (args '()))
   (let-values ([(header a i o) 
@@ -133,4 +196,9 @@
 		     (begin
 		       (http:request-body-set! req (string-intersperse args "\r\n"))
 		       req) ) ) ] )
-    (read-all i) ) )
+    (read-string
+     (cond ((alist-ref "content-length" header string=?)
+            => string->number)
+           (else
+            #f))
+     i)))