http.client, allow to use http proxies

basis/http/client/client-docs.factor

@@ -281,7 +281,14 @@ $nl
     "http.client.encoding"
     "http.client.errors"
 }
-"For authentication, only Basic Access Authentication is implemented, using the username/password from the target url. Alternatively, the " { $link set-basic-auth } " word can be called on the " { $link request } " object."
+"For authentication, only Basic Access Authentication is implemented, using the username/password from the target or proxy url. Alternatively, the " { $link set-basic-auth } " or " { $link set-proxy-basic-auth } " words can be called on the " { $link request } " object."
+$nl
+"The http client can use an HTTP proxy transparently, by using the " { $link "http.proxy-variables" } ". Additionally, the proxy variables can be ignored by setting the " { $slot "proxy-url" } " slot of each " { $link request } " manually:"
+{ $list
+    { "Setting " { $slot "proxy-url" } " to " { $link f } " prevents http.client from using a proxy." }
+    { "Setting the slots of the default empty url in " { $slot "proxy-url" } " overrides the corresponding values from the proxy variables." }
+}
+
 { $see-also "urls" } ;
 
 ABOUT: "http.client"

basis/http/client/client-tests.factor

@@ -13,6 +13,7 @@ IN: http.client.tests
 {
     T{ request
         { url T{ url { protocol "http" } { host "www.apple.com" } { port 80 } { path "/index.html" } } }
+        { proxy-url T{ url } }
         { method "GET" }
         { version "1.1" }
         { cookies V{ } }
@@ -27,6 +28,7 @@ IN: http.client.tests
 {
     T{ request
         { url T{ url { protocol "https" } { host "www.amazon.com" } { port 443 } { path "/index.html" } } }
+        { proxy-url T{ url } }
         { method "GET" }
         { version "1.1" }
         { cookies V{ } }
@@ -58,3 +60,145 @@ IN: http.client.tests
     } [ "\n" join ] [ "\r\n" join ] bi
     [ [ read-response ] with-string-reader ] same?
 ] unit-test
+
+{ "www.google.com:8080" } [
+    URL" http://foo:bar@www.google.com:8080/foo?bar=baz#quux" authority-uri
+] unit-test
+
+{ "/index.html?bar=baz" } [
+    "http://user:pass@www.apple.com/index.html?bar=baz#foo"
+    <get-request>
+        f >>proxy-url
+    request-uri
+] unit-test
+
+{ "/index.html?bar=baz" } [
+    "https://user:pass@www.apple.com/index.html?bar=baz#foo"
+    <get-request>
+        f >>proxy-url
+    request-uri
+] unit-test
+
+{ "http://www.apple.com/index.html?bar=baz" } [
+    "http://user:pass@www.apple.com/index.html?bar=baz#foo"
+    <get-request>
+        "http://localhost:3128" >>proxy-url
+    request-uri
+] unit-test
+
+{ "www.apple.com:80" } [
+    "http://user:pass@www.apple.com/index.html?bar=baz#foo"
+    "CONNECT" <client-request>
+        f >>proxy-url
+    request-uri
+] unit-test
+
+{ "www.apple.com:443" } [
+    "https://www.apple.com/index.html"
+    "CONNECT" <client-request>
+        f >>proxy-url
+     request-uri
+] unit-test
+
+{ f } [
+    "" "no_proxy" [
+        "www.google.fr" <get-request> no-proxy?
+    ] with-variable
+] unit-test
+
+{ f } [
+    "," "no_proxy" [
+        "www.google.fr" <get-request> no-proxy?
+    ] with-variable
+] unit-test
+
+{ f } [
+    "foo,,bar" "no_proxy" [
+        "www.google.fr" <get-request> no-proxy?
+    ] with-variable
+] unit-test
+
+{ t } [
+    "foo,www.google.fr,bar" "no_proxy" [
+        "www.google.fr" <get-request> no-proxy?
+    ] with-variable
+] unit-test
+
+! TODO support 192.168.0.16/4 ?
+CONSTANT: classic-proxy-settings H{
+    { "http.proxy" "http://proxy.private:3128" }
+    { "https.proxy" "http://proxysec.private:3128" }
+    { "no_proxy" "localhost,127.0.0.1,.allprivate,.a.subprivate,b.subprivate" }
+}
+
+{ f } [
+    classic-proxy-settings [
+       "localhost" "GET" <client-request> ?default-proxy proxy-url>>
+    ] with-variables
+] unit-test
+
+{ f } [
+    classic-proxy-settings [
+       "127.0.0.1" "GET" <client-request> ?default-proxy proxy-url>>
+    ] with-variables
+] unit-test
+
+{ URL" http://proxy.private:3128" } [
+    classic-proxy-settings [
+       "27.0.0.1" "GET" <client-request> ?default-proxy proxy-url>>
+    ] with-variables
+] unit-test
+
+{ f } [
+    classic-proxy-settings [
+       "foo.allprivate" "GET" <client-request> ?default-proxy proxy-url>>
+    ] with-variables
+] unit-test
+
+{ f } [
+    classic-proxy-settings [
+       "bar.a.subprivate" "GET" <client-request> ?default-proxy proxy-url>>
+    ] with-variables
+] unit-test
+
+{ URL" http://proxy.private:3128" } [
+    classic-proxy-settings [
+       "a.subprivate" "GET" <client-request> ?default-proxy proxy-url>>
+    ] with-variables
+] unit-test
+
+{ f } [
+    classic-proxy-settings [
+       "bar.b.subprivate" "GET" <client-request> ?default-proxy proxy-url>>
+    ] with-variables
+] unit-test
+
+{ f } [
+    classic-proxy-settings [
+       "b.subprivate" "GET" <client-request> ?default-proxy proxy-url>>
+    ] with-variables
+] unit-test
+
+{ URL" http://proxy.private:3128" } [
+    classic-proxy-settings [
+       "bara.subprivate" "GET" <client-request> ?default-proxy proxy-url>>
+    ] with-variables
+] unit-test
+
+{ URL" http://proxy.private:3128" } [
+    classic-proxy-settings [
+       "google.com" "GET" <client-request> ?default-proxy proxy-url>>
+    ] with-variables
+] unit-test
+
+{ URL" http://proxysec.private:3128" } [
+    classic-proxy-settings [
+       "https://google.com" "GET" <client-request> ?default-proxy proxy-url>>
+    ] with-variables
+] unit-test
+
+{ URL" http://proxy.private:3128" } [
+    classic-proxy-settings [
+       "allprivate.google.com" "GET" <client-request> ?default-proxy proxy-url>>
+    ] with-variables
+] unit-test

basis/http/client/client.factor

@@ -4,19 +4,43 @@ USING: accessors ascii assocs calendar combinators.short-circuit
 destructors fry hashtables http http.client.post-data
 http.parsers io io.crlf io.encodings io.encodings.ascii
 io.encodings.binary io.encodings.iana io.encodings.string
-io.files io.pathnames io.sockets io.timeouts kernel locals math
+io.files io.pathnames io.sockets io.sockets.secure io.timeouts
-math.order math.parser mime.types namespaces present sequences
+kernel locals math math.order math.parser mime.types namespaces
-splitting urls vocabs.loader ;
+present sequences splitting urls vocabs.loader combinators
+environment ;
 IN: http.client
 
 ERROR: too-many-redirects ;
 
+: success? ( code -- ? ) 200 299 between? ;
+
+ERROR: download-failed response ;
+
+: check-response ( response -- response )
+    dup code>> success? [ download-failed ] unless ;
+
 <PRIVATE
 
+: authority-uri ( url -- str )
+    [ host>> ] [ port>> number>string ] bi ":" glue ;
+
+: absolute-uri ( url -- str )
+    clone f >>username f >>password f >>anchor present ;
+
+: abs-path-uri ( url -- str )
+    relative-url f >>anchor present ;
+
+: request-uri ( request -- str )
+    {
+        { [ dup proxy-url>> ] [ url>> absolute-uri ] }
+        { [ dup method>> "CONNECT" = ] [ url>> authority-uri ] }
+        [ url>> abs-path-uri ]
+    } cond ;
+
 : write-request-line ( request -- request )
     dup
     [ method>> write bl ]
-    [ url>> relative-url f >>anchor present write bl ]
+    [ request-uri write bl ]
     [ "HTTP/" write version>> write crlf ]
     tri ;
 
@@ -47,6 +71,7 @@ ERROR: too-many-redirects ;
     dup header>> >hashtable
     over url>> host>> [ set-host-header ] when
     over url>> "Authorization" ?set-basic-auth
+    over proxy-url>> "Proxy-Authorization" ?set-basic-auth
     over post-data>> [ set-post-data-headers ] when*
     over cookies>> [ set-cookie-header ] unless-empty
     write-header ;
@@ -118,14 +143,73 @@ SYMBOL: redirects
     "transfer-encoding" header "chunked" =
     [ read-chunked ] [ each-block ] if ; inline
 
+: request-socket-endpoints ( request -- physical logical )
+    [ proxy-url>> ] [ url>> ] bi [ or ] keep ;
+
 : <request-socket> ( -- stream )
-    request get url>> url-addr ascii <client> drop
+    request get request-socket-endpoints [ url-addr ] bi@
+    remote-address set ascii <client> local-address set
     1 minutes over set-timeout ;
 
+: https-tunnel? ( request -- ? )
+    [ proxy-url>> ] [ url>> protocol>> "https" = ] bi and ;
+
+: ?copy-proxy-basic-auth ( dst-request src-request -- dst-request )
+    proxy-url>> [ username>> ] [ password>> ] bi 2dup and
+    [ set-proxy-basic-auth ] [ 2drop ] if ;
+
+: ?https-tunnel ( -- )
+    request get dup https-tunnel? [
+        <request> swap [ url>> >>url ] [ ?copy-proxy-basic-auth ] bi
+        f >>proxy-url "CONNECT" >>method write-request
+        read-response check-response drop send-secure-handshake
+    ] [ drop ] if ;
+
+! Note: ipv4 addresses are interpreted as subdomains but "work"
+: no-proxy-match? ( host-path no-proxy-path -- ? )
+    dup first empty? [ [ rest ] bi@ ] when
+    [ drop f ] [ tail? ] if-empty ;
+
+: get-no-proxy-list ( -- list )
+    "no_proxy" get
+    [ "no_proxy" os-env ] unless*
+    [ "NO_PROXY" os-env ] unless* ;
+
+: no-proxy? ( request -- ? )
+    url>> host>> "." split
+    get-no-proxy-list [
+        "," split [ "." split no-proxy-match? ] with any?
+    ] [ drop f ] if* ;
+
+: check-proxy ( request proxy -- request' )
+    dup [ host>> ] [ f ] if*
+    [ drop f ] unless [ clone ] dip >>proxy-url ;
+
+: get-default-proxy ( request -- default-proxy )
+    url>> protocol>> "https" = [
+        "https.proxy" get
+        [ "https_proxy" os-env ] unless*
+        [ "HTTPS_PROXY" os-env ] unless*
+    ] [
+        "http.proxy" get
+        [ "http_proxy" os-env ] unless*
+        [ "HTTP_PROXY" os-env ] unless*
+    ] if ;
+
+: ?default-proxy ( request -- request' )
+    dup get-default-proxy
+    over proxy-url>> 2dup and [
+        pick no-proxy? [ nip ] [ [ >url ] dip derive-url ] if
+    ] [ nip ] if check-proxy ;
+
 : (with-http-request) ( request quot: ( chunk -- ) -- response )
-    swap
+    swap ?default-proxy
     request [
         <request-socket> [
+            [
+                [ in>> ] [ out>> ] bi
+                [ ?https-tunnel ] with-streams*
+            ]
             [
                 out>>
                 [ request get write-request ]
@@ -140,7 +224,7 @@ SYMBOL: redirects
                         2tri f
                     ] if
                 ] with-input-stream*
-            ] bi
+            ] tri
         ] with-disposal
         [ do-redirect ] [ nip ] if
     ] with-variable ; inline recursive
@@ -158,13 +242,6 @@ SYMBOL: redirects
 
 PRIVATE>
 
-: success? ( code -- ? ) 200 299 between? ;
-
-ERROR: download-failed response ;
-
-: check-response ( response -- response )
-    dup code>> success? [ download-failed ] unless ;
-
 : with-http-request* ( request quot: ( chunk -- ) -- response )
     [ (with-http-request) ] with-destructors ; inline
 

basis/http/http-docs.factor

@@ -13,6 +13,7 @@ $nl
 { $table
     { { $slot "method" } { "The HTTP method as a " { $link string } ". The most frequently-used HTTP methods are " { $snippet "GET" } ", " { $snippet "HEAD" } " and " { $snippet "POST" } "." } }
     { { $slot "url" } { "The " { $link url } " being requested" } }
+    { { $slot "proxy-url" } { "The proxy " { $link url } " to use, or " { $link f } " for no proxy. If not " { $link f } ", the url will additionally be " { $link derive-url } "'d from the " { $link "http.proxy-variables" } ". The proxy is used if the result has at least the " { $slot "host" } " slot set." } }
     { { $slot "version" } { "The HTTP version. Default is " { $snippet "1.1" } " and should not be changed without good reason." } }
     { { $slot "header" } { "An assoc of HTTP header values. See " { $link "http.headers" } } }
     { { $slot "post-data" } { "See " { $link "http.post-data" } } }
@@ -122,6 +123,12 @@ HELP: set-basic-auth
 { $notes "This word always returns the same object that was input. This allows for a “pipeline” coding style, where several header parameters are set in a row." }
 { $side-effects "request" } ;
 
+HELP: set-proxy-basic-auth
+{ $values { "request" request } { "username" string } { "password" string } }
+{ $description "Sets the " { $snippet "Proxy-Authorization" } " header of " { $snippet "request" } " to perform HTTP Basic authentication with the given " { $snippet "username" } " and " { $snippet "password" } "." }
+{ $notes "This word always returns the same object that was input. This allows for a “pipeline” coding style, where several header parameters are set in a row." }
+{ $side-effects "request" } ;
+
 ARTICLE: "http.cookies" "HTTP cookies"
 "Every " { $link request } " and " { $link response } " instance can contain cookies."
 $nl
@@ -188,4 +195,60 @@ $nl
 }
 { $see-also "urls" } ;
 
+ARTICLE: "http.proxy-variables" "HTTP(S) proxy variables"
+{ $heading "Proxy Variables" }
+"The http and https proxies can be configured per request, or with Factor's dynamic variables, or with the system's environnement variables (searched from left to right) :"
+{ $table
+{ "variable" "Factor dynamic" "environnement #1" "environnement #2" }
+{ "HTTP" { $snippet "\"http.proxy\"" } "http_proxy" "HTTP_PROXY" }
+{ "HTTPS" { $snippet "\"https.proxy\"" } "https_proxy" "HTTPS_PROXY" }
+{ "no proxy" { $snippet "\"no_proxy\"" } "no_proxy" "NO_PROXY" }
+}
+"When making an http request, if the target host is not matched by the no_proxy list, the " { $vocab-link "http.client" } " will fill the missing components of the " { $slot "proxy-url" } " slot of the " { $link request } " from the value of these variables."
+{ $notes "The dynamic variables are keyed by strings. This allows to use Factor's command line support to define them (see in the examples below)." }
+
+{ $heading "no_proxy" }
+"The no_proxy list must be a string containing of comma-separated list of IP addresses (eg " { $snippet "127.0.0.1" } "), hostnames (eg " { $snippet "bar.private" } ") or domain suffixes (eg " { $snippet ".private" } "). A match happens when a value of the list is the same or a suffix of the target for each full subdomain."
+{ $example
+    "USING: http.client http.client.private namespaces prettyprint ;"
+    "\"bar.private\" \"no_proxy\" ["
+         "\"bar.private\" <get-request> no-proxy? ."
+    "] with-variable"
+    "\"bar.private\" \"no_proxy\" ["
+         "\"baz.bar.private\" <get-request> no-proxy? ."
+    "] with-variable"
+    "\"bar.private\" \"no_proxy\" ["
+         "\"foobar.private\" <get-request> no-proxy? ."
+    "] with-variable"
+    "\".private\" \"no_proxy\" ["
+         "\"foobar.private\" <get-request> no-proxy? ."
+    "] with-variable"
+"t
+t
+f
+t"
+}
+
+{ $examples
+{
+{ $subheading "At factor startup:" }
+{ $list
+"$ ./factor -http.proxy=http://localhost:3128"
+"$ http_proxy=\"http://localhost:3128\" ./factor"
+"$ HTTP_PROXY=\"http://localhost:3128\" ./factor"
+}
+
+{ $subheading "Using variables:" }
+{ $example "USE: namespaces \"http://localhost:3128\" \"http.proxy\" set ! or set-global" "" }
+{ $example "USE: namespaces \"http://localhost:3128\" \"http.proxy\" [ ] with-variable" "" }
+
+{ $subheading "Manually making the request:" }
+{ $example "USING: http http.client urls ; URL\" http://localhost:3128\" <request> proxy-url<<" "" }
+
+{ $subheading "Full example:" }
+"$ no_proxy=\"localhost,127.0.0.1,.private\" http_proxy=\"http://proxy.private:3128\" https_proxy=\"http://proxysec.private:3128\" ./factor"
+}
+}
+;
+
 ABOUT: "http"

basis/http/http-tests.factor

@@ -38,6 +38,7 @@ blah
 {
     T{ request
         { url T{ url { path "/bar" } } }
+        { proxy-url T{ url } }
         { method "POST" }
         { version "1.1" }
         { header H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } } }
@@ -77,6 +78,7 @@ Host: www.sex.com
 {
     T{ request
         { url T{ url { host "www.sex.com" } { path "/bar" } } }
+        { proxy-url T{ url } }
         { method "HEAD" }
         { version "1.1" }
         { header H{ { "host" "www.sex.com" } } }
@@ -98,6 +100,7 @@ Host: www.sex.com:101
 {
     T{ request
         { url T{ url { host "www.sex.com" } { port 101 } { path "/bar" } } }
+        { proxy-url T{ url } }
         { method "HEAD" }
         { version "1.1" }
         { header H{ { "host" "www.sex.com:101" } } }

basis/http/http.factor

@@ -134,6 +134,7 @@ TUPLE: cookie name value version comment path domain expires max-age http-only s
 TUPLE: request
 method
 url
+proxy-url
 version
 header
 post-data
@@ -149,12 +150,16 @@ redirects ;
 : set-basic-auth ( request username password -- request )
     basic-auth "Authorization" set-header ;
 
+: set-proxy-basic-auth ( request username password -- request )
+    basic-auth "Proxy-Authorization" set-header ;
+
 : <request> ( -- request )
     request new
         "1.1" >>version
         <url>
             H{ } clone >>query
         >>url
+        <url> >>proxy-url
         H{ } clone >>header
         V{ } clone >>cookies
         "close" "connection" set-header

basis/http/server/requests/requests-tests.factor

@@ -135,6 +135,7 @@ hello
     T{ request
         { method "GET" }
         { url URL" /" }
+        { proxy-url URL" " }
         { version "1.0" }
         { header H{ } }
         { cookies V{ } }

basis/http/server/server-tests.factor

@@ -52,6 +52,7 @@ IN: http.server.tests
     T{ request
         { method "GET" }
         { url URL" /" }
+        { proxy-url URL" " }
         { version "1.0" }
         { header H{ } }
         { cookies V{ } }
@@ -69,6 +70,7 @@ IN: http.server.tests
     T{ request
         { method "GET" }
         { url URL" /" }
+        { proxy-url URL" " }
         { version "1.0" }
         { header H{ } }
         { cookies V{ } }