Fix host: header in http.client and add redirection limit

extra/http/client/client-tests.factor

@@ -6,9 +6,9 @@ tuple-syntax namespaces ;
 [ "/" "localhost" 8888 ] [ "http://localhost:8888" parse-url ] unit-test
 
 [ "foo.txt" ] [ "http://www.paulgraham.com/foo.txt" download-name ] unit-test
-[ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt?xxx" download-name ] unit-test
+[ "foo.txt" ] [ "http://www.arc.com/foo.txt?xxx" download-name ] unit-test
-[ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt/" download-name ] unit-test
+[ "foo.txt" ] [ "http://www.arc.com/foo.txt/" download-name ] unit-test
-[ "www.arcsucks.com" ] [ "http://www.arcsucks.com////" download-name ] unit-test
+[ "www.arc.com" ] [ "http://www.arc.com////" download-name ] unit-test
 
 [
     TUPLE{ request
@@ -18,7 +18,7 @@ tuple-syntax namespaces ;
         port: 80
         version: "1.1"
         cookies: V{ }
-        header: H{ }
+        header: H{ { "connection" "close" } }
     }
 ] [
     [

extra/http/client/client.factor

@@ -3,9 +3,17 @@
 USING: assocs http kernel math math.parser namespaces sequences
 io io.sockets io.streams.string io.files io.timeouts strings
 splitting calendar continuations accessors vectors
-io.encodings.8-bit io.encodings.binary fry debugger ;
+io.encodings.8-bit io.encodings.binary fry debugger inspector ;
 IN: http.client
 
+: max-redirects 10 ;
+
+ERROR: too-many-redirects ;
+
+M: too-many-redirects summary
+    drop
+    [ "Redirection limit of " % max-redirects # " exceeded" % ] "" make ;
+
 DEFER: http-request
 
 <PRIVATE
@@ -29,22 +37,26 @@ DEFER: http-request
 : relative-redirect ( path -- request )
     request get swap store-path ;
 
+SYMBOL: redirects
+
 : do-redirect ( response -- response stream )
     dup response-code 300 399 between? [
         stdio get dispose
+        redirects inc
+        redirects get max-redirects < [
             header>> "location" swap at
             dup "http://" head? [
                 absolute-redirect
             ] [
                 relative-redirect
             ] if "GET" >>method http-request
+        ] [
+            too-many-redirects
+        ] if
     ] [
         stdio get
     ] if ;
 
-: request-addr ( request -- addr )
-    dup host>> swap port>> <inet> ;
-
 : close-on-error ( stream quot -- )
     '[ , with-stream* ] [ ] pick '[ , dispose ] cleanup ; inline
 

extra/http/http-tests.factor

@@ -143,6 +143,9 @@ io.encodings.ascii ;
             <dispatcher>
                 "extra/http/test" resource-path <static> >>default
             "nested" add-responder
+            <action>
+                [ "redirect-loop" f <permanent-redirect> ] >>display
+            "redirect-loop" add-responder
         main-responder set
 
         [ 1237 httpd ] "HTTPD test" spawn drop
@@ -160,10 +163,13 @@ io.encodings.ascii ;
         "GET nested HTTP/1.0\r\n" write flush
         "\r\n" write flush
         readln drop
-        read-header USE: prettyprint
+        read-header
-    ] with-stream dup . "location" swap at "/" head?
+    ] with-stream "location" swap at "/" head?
 ] unit-test
 
+[ "http://localhost:1237/redirect-loop" http-get ]
+[ too-many-redirects? ] must-fail-with
+
 [ "Goodbye" ] [
     "http://localhost:1237/quit" http-get
 ] unit-test

extra/http/http.factor

@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry hashtables io io.streams.string kernel math sets
 namespaces math.parser assocs sequences strings splitting ascii
-io.encodings.utf8 io.encodings.string namespaces unicode.case
+io.encodings.utf8 io.encodings.string io.sockets namespaces
-combinators vectors sorting accessors calendar
+unicode.case combinators vectors sorting accessors calendar
 calendar.format quotations arrays combinators.lib byte-arrays ;
 IN: http
 
@@ -299,9 +299,15 @@ SYMBOL: max-post-request
         "application/x-www-form-urlencoded" >>post-data-type
     ] if ;
 
+: request-addr ( request -- addr )
+    [ host>> ] [ port>> ] bi <inet> ;
+
+: request-host ( request -- string )
+    [ host>> ] [ drop ":" ] [ port>> number>string ] tri 3append ;
+
 : write-request-header ( request -- request )
     dup header>> >hashtable
-    over host>> [ "host" pick set-at ] when*
+    over host>> [ over request-host "host" pick set-at ] when
     over post-data>> [ length "content-length" pick set-at ] when*
     over post-data-type>> [ "content-type" pick set-at ] when*
     over cookies>> f like [ unparse-cookies "cookie" pick set-at ] when*