[PATCH] Add support for HTTP proxies

[Mark H Weaver]

Here's a preliminary patch to add proxy support to our HTTP client.
The API is as follows:

* If the 'http_proxy' environment variable is set to a string such as
  "http://myproxy:8123/";, then existing code should do the right thing
  without any changes.

* To override the environment variable within an arbitrary dynamic
  extent, you can parameterize the new 'current-http-proxy' parameter.
  Valid settings include #f to disable use of the proxy, 'auto to
  consult the environment variable, or a non-empty string.

* Finally, the relevant procedures such as 'http-get' will accept a
  keyword argument #:http-proxy, which accepts the same settings as the
  parameter except that 'auto falls back to the parameter setting.  This
  allows us to avoid the pitfalls of fluids/parameters when possible.

There's also the question of what to do if an existing port is passed to
'http-get' etc.  It needs to know whether the port is connected to a
proxy.  The solution implemented here is two-pronged.  First, there's an
object property 'http-proxy-port?' that is set by 'open-socket-for-uri'
and consulted by various procedures.  This should make existing code
"just work".  Second, the relevant procedures accept a keyword argument
'#:using-proxy?'.

Still to be done: documentation and tests.  However, before spending
time on that I wanted to ask for feedback on this general approach.

What do you think?

    Mark


>From 0e1928e957e09c8822e0ea8ac9199381e1657bc2 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <address@hidden>
Date: Fri, 7 Jun 2013 00:47:33 -0400
Subject: [PATCH] Add support for HTTP proxies (PRELIMINARY)

* module/web/http.scm (http-proxy-port?): New exported object property.
  (current-http-proxy): New exported parameter.
  (write-request-line): Add 'using-proxy?' keyword argument.  If set,
  write an absolute-URI in the request line.

* module/web/request.scm (write-request): Add 'using-proxy?' keyword
  argument.  Pass it through to 'write-request-line'.

* module/web/client.scm: Import (web http).
  (choose-http-proxy): New procedure.
  (open-socket-for-uri): Add 'http-proxy' keyword argument.  If
  'chosen-http-proxy' returns a true value, connect to the proxy instead
  of the URI host, and set the 'http-proxy-port?' object property on the
  socket to true.
  (request, http-get, http-get*, http-head, http-post, http-put,
  http-delete, http-trace, http-options): Add 'http-proxy' and
  'using-proxy?' keyword arguments.
  (define-http-verb): Add 'http-proxy' and 'using-proxy?' keyword
  arguments to the defined verb.
---
 module/web/client.scm  |   44 ++++++++++++++++++++++++++++++++++----------
 module/web/http.scm    |   26 ++++++++++++++++++++++++--
 module/web/request.scm |    5 +++--
 3 files changed, 61 insertions(+), 14 deletions(-)

diff --git a/module/web/client.scm b/module/web/client.scm
index 7d5ea49..6d7b765 100644
--- a/module/web/client.scm
+++ b/module/web/client.scm
@@ -39,6 +39,7 @@
   #:use-module (web request)
   #:use-module (web response)
   #:use-module (web uri)
+  #:use-module (web http)
   #:use-module (srfi srfi-1)
   #:export (open-socket-for-uri
             http-get
@@ -56,9 +57,21 @@
    ((uri? uri-or-string) uri-or-string)
    (else (error "Invalid URI" uri-or-string))))
 
-(define (open-socket-for-uri uri-or-string)
+(define* (choose-http-proxy #:optional (http-proxy 'auto))
+  (define (valid-proxy? p)
+    (or (not p)
+        (and (string? p)
+             (not (string-null? p)))))
+  (define (identity p) p)
+  (cond (http-proxy            valid-proxy? => identity)
+        ((current-http-proxy)  valid-proxy? => identity)
+        ((getenv "http_proxy") valid-proxy? => identity)
+        (else #f)))
+
+(define* (open-socket-for-uri uri-or-string #:key (http-proxy 'auto))
   "Return an open input/output port for a connection to URI."
-  (define uri (ensure-uri uri-or-string))
+  (define chosen-proxy (choose-http-proxy http-proxy))
+  (define uri (ensure-uri (or chosen-proxy uri-or-string)))
   (define addresses
     (let ((port (uri-port uri)))
       (delete-duplicates
@@ -84,6 +97,8 @@
           (setvbuf s _IOFBF)
           ;; Enlarge the receive buffer.
           (setsockopt s SOL_SOCKET SO_RCVBUF (* 12 1024))
+          ;; If this is proxy server, associate that fact with the port.
+          (when http-proxy (set! (http-proxy-port? s) #t))
           s)
         (lambda args
           ;; Connection failed, so try one of the other addresses.
@@ -192,8 +207,10 @@ as is the case by default with a request returned by 
`build-request'."
 
 ;; We could expose this to user code if there is demand.
 (define* (request uri #:key
+                  (http-proxy 'auto)
                   (body #f)
-                  (port (open-socket-for-uri uri))
+                  (port (open-socket-for-uri uri #:http-proxy http-proxy))
+                  (using-proxy? (http-proxy-port? port))
                   (method "GET")
                   (version '(1 . 1))
                   (keep-alive? #f)
@@ -211,7 +228,7 @@ as is the case by default with a request returned by 
`build-request'."
                     #:port port)))
   (call-with-values (lambda () (sanitize-request request body))
     (lambda (request body)
-      (let ((request (write-request request port)))
+      (let ((request (write-request request port #:using-proxy? using-proxy?)))
         (when body
           (write-request-body request body))
         (force-output (request-port request))
@@ -236,8 +253,10 @@ as is the case by default with a request returned by 
`build-request'."
                           body))))))))))
 
 (define* (http-get uri #:key
+                   (http-proxy 'auto)
                    (body #f)
-                   (port (open-socket-for-uri uri))
+                   (port (open-socket-for-uri uri #:http-proxy http-proxy))
+                   (using-proxy? (http-proxy-port? port))
                    (version '(1 . 1)) (keep-alive? #f)
                    ;; #:headers is the new name of #:extra-headers.
                    (extra-headers #f) (headers (or extra-headers '()))
@@ -275,11 +294,13 @@ true)."
   (request uri #:method "GET" #:body body
            #:port port #:version version #:keep-alive? keep-alive?
            #:headers headers #:decode-body? decode-body?
-           #:streaming? streaming?))
+           #:streaming? streaming? #:using-proxy? using-proxy?))
 
 (define* (http-get* uri #:key
+                    (http-proxy 'auto)
                     (body #f)
-                    (port (open-socket-for-uri uri))
+                    (port (open-socket-for-uri uri #:http-proxy http-proxy))
+                    (using-proxy? (http-proxy-port? port))
                     (version '(1 . 1)) (keep-alive? #f)
                     ;; #:headers is the new name of #:extra-headers.
                     (extra-headers #f) (headers (or extra-headers '()))
@@ -290,12 +311,15 @@ true)."
    "Instead, use `http-get' with the #:streaming? #t keyword argument.")
   (http-get uri #:body body
             #:port port #:version version #:keep-alive? keep-alive?
-            #:headers headers #:decode-body? #t #:streaming? #t))
+            #:headers headers #:decode-body? #t #:streaming? #t
+            #:using-proxy? using-proxy?))
 
 (define-syntax-rule (define-http-verb http-verb method doc)
   (define* (http-verb uri #:key
+                      (http-proxy 'auto)
                       (body #f)
-                      (port (open-socket-for-uri uri))
+                      (port (open-socket-for-uri uri #:http-proxy http-proxy))
+                      (using-proxy? (http-proxy-port? port))
                       (version '(1 . 1))
                       (keep-alive? #f)
                       (headers '())
@@ -306,7 +330,7 @@ true)."
              #:body body #:method method
              #:port port #:version version #:keep-alive? keep-alive?
              #:headers headers #:decode-body? decode-body?
-             #:streaming? streaming?)))
+             #:streaming? streaming? #:using-proxy? using-proxy?)))
 
 (define-http-verb http-head
   "HEAD"
diff --git a/module/web/http.scm b/module/web/http.scm
index 35169ef..27d6a41 100644
--- a/module/web/http.scm
+++ b/module/web/http.scm
@@ -66,7 +66,10 @@
             write-response-line
 
             make-chunked-input-port
-            make-chunked-output-port))
+            make-chunked-output-port
+
+            http-proxy-port?
+            current-http-proxy))
 
 
 (define (string->header name)
@@ -1113,10 +1116,26 @@ three values: the method, the URI, and the version."
         (display #\? port)
         (display (uri-query uri) port))))
 
-(define (write-request-line method uri version port)
+(define* (write-request-line method uri version port
+                             #:key (using-proxy? (http-proxy-port? port)))
   "Write the first line of an HTTP request to PORT."
   (display method port)
   (display #\space port)
+  (when using-proxy?
+    (let ((scheme (uri-scheme uri))
+          (host (uri-host uri))
+          (host-port (uri-port uri)))
+      (when (and scheme host)
+        (display scheme port)
+        (display "://" port)
+        (if (string-index host #\:)
+            (begin (display #\[ port)
+                   (display host port)
+                   (display #\] port))
+            (display host port))
+        (unless ((@@ (web uri) default-port?) scheme host-port)
+          (display #\: port)
+          (display host-port port)))))
   (let ((path (uri-path uri))
         (query (uri-query uri)))
     (if (not (string-null? path))
@@ -1958,3 +1977,6 @@ KEEP-ALIVE? is true."
     (unless keep-alive?
       (close-port port)))
   (make-soft-port (vector put-char put-string flush #f close) "w"))
+
+(define http-proxy-port? (make-object-property))
+(define current-http-proxy (make-parameter 'auto))
diff --git a/module/web/request.scm b/module/web/request.scm
index 7ced076..665d022 100644
--- a/module/web/request.scm
+++ b/module/web/request.scm
@@ -206,13 +206,14 @@ requests."
       (make-request method uri version (read-headers port) meta port))))
 
 ;; FIXME: really return a new request?
-(define (write-request r port)
+(define* (write-request r port #:key (using-proxy? (http-proxy-port? port)))
   "Write the given HTTP request to PORT.
 
 Return a new request, whose ‘request-port’ will continue writing
 on PORT, perhaps using some transfer encoding."
   (write-request-line (request-method r) (request-uri r)
-                      (request-version r) port)
+                      (request-version r) port
+                      #:using-proxy? using-proxy?)
   (write-headers (request-headers r) port)
   (display "\r\n" port)
   (if (eq? port (request-port r))
-- 
1.7.10.4