HTTP server and client fixes

extra/http/client/client-tests.factor

@@ -23,6 +23,5 @@ tuple-syntax namespaces ;
     [
         "http://www.apple.com/index.html"
         <get-request>
-        request-with-url
     ] with-scope
 ] unit-test

extra/http/client/client.factor

@@ -6,72 +6,76 @@ splitting calendar continuations accessors vectors io.encodings.latin1
 io.encodings.binary ;
 IN: http.client
 
+DEFER: http-request
+
+<PRIVATE
+
 : parse-url ( url -- resource host port )
     "http://" ?head [ "Only http:// supported" throw ] unless
     "/" split1 [ "/" swap append ] [ "/" ] if*
     swap parse-host ;
 
-<PRIVATE
-
 : store-path ( request path -- request )
     "?" split1 >r >>path r> dup [ query>assoc ] when >>query ;
 
-! This is all pretty complex because it needs to handle
-! HTTP redirects, which might be absolute or relative
 : request-with-url ( url request -- request )
-    clone dup "request" set
     swap parse-url >r >r store-path r> >>host r> >>port ;
 
-DEFER: (http-request)
-
+! This is all pretty complex because it needs to handle
+! HTTP redirects, which might be absolute or relative
 : absolute-redirect ( url -- request )
-    "request" get request-with-url ;
+    request get request-with-url ;
 
 : relative-redirect ( path -- request )
-    "request" get swap store-path ;
+    request get swap store-path ;
 
 : do-redirect ( response -- response stream )
     dup response-code 300 399 between? [
+        stdio get dispose
         header>> "location" swap at
         dup "http://" head? [
             absolute-redirect
         ] [
             relative-redirect
-        ] if "GET" >>method (http-request)
+        ] if "GET" >>method http-request
     ] [
         stdio get
     ] if ;
 
-: (http-request) ( request -- response stream )
-    dup host>> over port>> <inet> latin1 <client> stdio set
-    dup "r" set-global  write-request flush read-response
-    do-redirect ;
+: request-addr ( request -- addr )
+    dup host>> swap port>> <inet> ;
+
+: close-on-error ( stream quot -- )
+    [ with-stream* ] curry [ ] pick [ dispose ] curry cleanup ;
+    inline
 
 PRIVATE>
 
-: http-request ( url request -- response stream )
-    [
-        request-with-url
+: http-request ( request -- response stream )
+    dup request [
+        dup request-addr latin1 <client>
+        1 minutes over set-timeout
         [
-            (http-request)
-            1 minutes over set-timeout
-        ] [ ] [ stdio get dispose ] cleanup
-    ] with-scope ;
+            write-request flush
+            read-response
+            do-redirect
+        ] close-on-error
+    ] with-variable ;
 
-: <get-request> ( -- request )
-    <request> "GET" >>method ;
+: <get-request> ( url -- request )
+    <request> request-with-url "GET" >>method ;
 
 : http-get-stream ( url -- response stream )
     <get-request> http-request ;
 
 : success? ( code -- ? ) 200 = ;
 
-: check-response ( response stream -- stream )
-    swap code>> success?
-    [ dispose "HTTP download failed" throw ] unless ;
+: check-response ( response -- )
+    code>> success?
+    [ "HTTP download failed" throw ] unless ;
 
 : http-get ( url -- string )
-    http-get-stream check-response contents ;
+    http-get-stream contents swap check-response ;
 
 : download-name ( url -- name )
     file-name "?" split1 drop "/" ?tail drop ;
@@ -84,12 +88,13 @@ PRIVATE>
 : download ( url -- )
     dup download-name download-to ;
 
-: <post-request> ( content-type content -- request )
+: <post-request> ( content-type content url -- request )
     <request>
+    request-with-url
     "POST" >>method
     swap >>post-data
     swap >>post-data-type ;
 
 : http-post ( content-type content url -- response string )
     #! The content is URL encoded for you.
-    -rot url-encode <post-request> http-request contents ;
+    >r url-encode r> <post-request> http-request contents ;

extra/http/http-tests.factor

@@ -127,3 +127,30 @@ read-response-test-1' 1array [
     "rmid=732423sdfs73242; path=/; domain=.example.net; expires=Fri, 31-Dec-2010 23:59:59 GMT"
     dup parse-cookies unparse-cookies =
 ] unit-test
+
+! Live-fire exercise
+USING: http.server http.server.static http.server.actions
+http.client io.server io.files io accessors namespaces threads
+io.encodings.ascii ;
+
+[ ] [
+    [
+        <dispatcher>
+        <action>
+            [ stop-server "text/html" <content> [ "Goodbye" write ] >>body ] >>get
+        "quit" add-responder
+        "extra/http/test" resource-path <static> >>default
+        default-host set
+
+        [ 1237 httpd ] "HTTPD test" spawn drop
+    ] with-scope
+] unit-test
+
+[ t ] [
+    "extra/http/test/foo.html" resource-path ascii file-contents
+    "http://localhost:1237/foo.html" http-get =
+] unit-test
+
+[ "Goodbye" ] [
+    "http://localhost:1237/quit" http-get
+] unit-test

extra/http/server/static/static.factor

@@ -3,7 +3,7 @@
 USING: calendar html io io.files kernel math math.parser http
 http.server namespaces parser sequences strings assocs
 hashtables debugger http.mime sorting html.elements logging
-calendar.format new-slots accessors ;
+calendar.format new-slots accessors io.encodings.binary ;
 IN: http.server.static
 
 SYMBOL: responder
@@ -33,7 +33,7 @@ TUPLE: file-responder root hook special ;
         <content>
         over file-length "content-length" set-header
         over file-http-date "last-modified" set-header
-        swap [ <file-reader> stdio get stream-copy ] curry >>body
+        swap [ binary <file-reader> stdio get stream-copy ] curry >>body
     ] <file-responder> ;
 
 : serve-static ( filename mime-type -- response )

extra/http/test/foo.html

@@ -0,0 +1 @@
+<html><head><title>Hello</title></head><body>HTTPd test</body></html>

extra/io/server/server.factor

@@ -40,11 +40,11 @@ PRIVATE>
     f swap t resolve-host ;
 
 : with-server ( seq service encoding quot -- )
-    V{ } clone [
-        swap servers [
+    V{ } clone servers [
+        [
             [ server-loop ] 2curry with-logging
-        ] with-variable
-    ] 3curry curry parallel-each ; inline
+        ] 3curry parallel-each
+    ] with-variable ; inline
 
 : stop-server ( -- )
     servers get [ dispose ] each ;