;;;; persistent-http-get.scm
;;;; A replacement for http:GET that uses a pool of persistent connections

(define-extension persistent-http-get
  (export
    persistent-http:is-connected? persistent-http:get-connection
    persistent-http:close-connection! persistent-http:close-all-connections!
    persistent-http:GET))

(require-extension (srfi 18) (srfi 69) extras url http-utils http-client)

;;; Network support routines

#>
#ifdef _WIN32
#if _MSC_VER > 1300
#include <winsock2.h>
#else /* _MSC_VER */
#include <winsock.h>
#endif /* _MSC_VER */
#else /* _WIN32 */
#include <netinet/in.h>
#include <netdb.h>
#endif /* _WIN32 */
<#

(define (get-port-by-service-name svc)
  (let ((port ((foreign-lambda* scheme-object ((c-string svc))
		 "struct servent *sve =\n"
		 "  getservbyname(svc, \"tcp\");\n"
		 "return(sve == NULL\n"
		 "	 ? C_SCHEME_FALSE\n"
		 "	 : C_fix(ntohs(sve->s_port)));\n")
	       svc)))
    (if port
      port
      (error 'get-port-by-service-name "unknown service" svc))))

;;; Thread local 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 (request-server-id req)
  (let* ((req (if (string? req)
		(http:make-request 'GET req)
		req))
	 (u (url (http:request-url req)))
	 (scheme (or (url-scheme u) "http"))
	 (host (or (http:request-ip req) (url-host u)))
	 (port (or (url-port u) (get-port-by-service-name scheme))))
    (sprintf "~A://address@hidden:~A" scheme (url-user u) host port)))

(define (persistent-http:is-connected? req)
  (ensure-local-connections)
  (hash-table-exists? (connections) (request-server-id req)))

(define (persistent-http:get-connection req)
  (ensure-local-connections)
  (apply values (hash-table-ref (connections) (request-server-id req))))

(define (persistent-http:close-connection! req)
  (ensure-local-connections)
  (let ((key (request-server-id req)))
    (let ((con (hash-table-ref (connections) key)))
      (hash-table-delete! (connections) key)
      (close-input-port (car con))
      (close-output-port (cadr con)))))

(define (persistent-http:close-all-connections!)
  (ensure-local-connections)
  (hash-table-walk
   (connections)
   (lambda (key con)
      (hash-table-delete! (connections) key)
      (close-input-port (car con))
      (close-output-port (cadr con)))))

;;; HTTP client functionality

(define (persistent-http:GET req #!optional (keep-alive? #t))
  (ensure-local-connections)
  (let* ((req (if (string? req)
		(http:make-request
		  'GET req
		  `(("Connection" . ,(if keep-alive?
				       "keep-alive"
				       "close"))))
		req))
	 (key (request-server-id req))
	 (stat #f)
	 (hdrs '())
	 (in #f)
	 (out #f))
    (dynamic-wind
      void
      (lambda ()
	(set!-values
	  (in out)
	  (apply values (hash-table-ref/default (connections) key '(#f #f))))
	(let retry ()
	  (condition-case
	    (set!-values
	      (stat hdrs in out)
	      (http:send-request req in out))
	    (exn (exn i/o net)
	      (if (and in out)
		(begin
		  (close-input-port in)
		  (close-output-port out)
		  (hash-table-delete! (connections) key)
		  (set! in #f)
		  (set! out #f)
		  (retry))
		(signal exn)))))
	(if (eof-object? stat)
	  #!eof
	  (read-string
	    (cond
	      ((alist-ref "content-length" hdrs equal?)
	       => string->number)
	      (else
		#f))
	    in)))
      (lambda ()
	(if (and keep-alive?
		 (not (string-ci=?
			(alist-ref "connection" hdrs equal? "")
			"close")))
	  (hash-table-set! (connections) key (list in out))
	  (begin
	    (close-input-port in)
	    (close-output-port out)
	    (hash-table-delete! (connections) key)))))))

;;;; vim:set shiftwidth=2 softtabstop=2: ;;;;