More httpd work

extra/http/http-tests.factor

@@ -18,6 +18,11 @@ IN: http.tests
 
 [ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test
 
+[ "/" ] [ "http://foo.com" url>path ] unit-test
+[ "/" ] [ "http://foo.com/" url>path ] unit-test
+[ "/bar" ] [ "http://foo.com/bar" url>path ] unit-test
+[ "/bar" ] [ "/bar" url>path ] unit-test
+
 STRING: read-request-test-1
 GET http://foo/bar HTTP/1.1
 Some-Header: 1
@@ -31,7 +36,7 @@ blah
     TUPLE{ request
         port: 80
         method: "GET"
-        path: "bar"
+        path: "/bar"
         query: H{ }
         version: "1.1"
         header: H{ { "some-header" "1; 2" } { "content-length" "4" } }
@@ -45,7 +50,7 @@ blah
 ] unit-test
 
 STRING: read-request-test-1'
-GET bar HTTP/1.1
+GET /bar HTTP/1.1
 content-length: 4
 some-header: 1; 2
 
@@ -69,7 +74,7 @@ Host: www.sex.com
     TUPLE{ request
         port: 80
         method: "HEAD"
-        path: "bar"
+        path: "/bar"
         query: H{ }
         version: "1.1"
         header: H{ { "host" "www.sex.com" } }

extra/http/http.factor

@@ -180,9 +180,15 @@ cookies ;
 : set-query-param ( request value key -- request )
     pick query>> set-at ;
 
+: chop-hostname ( str -- str' )
+    CHAR: / over index over length or tail
+    dup empty? [ drop "/" ] when ;
+
 : url>path ( url -- path )
-    url-decode "http://" ?head
-    [ "/" split1 "" or nip ] [ "/" ?head drop ] if ;
+    #! Technically, only proxies are meant to support hostnames
+    #! in HTTP requests, but IE sends these sometimes so we
+    #! just chop the hostname part.
+    url-decode "http://" ?head [ chop-hostname ] when ;
 
 : read-method ( request -- request )
     " " read-until [ "Bad request: method" throw ] unless

extra/http/server/actions/actions.factor

@@ -0,0 +1,12 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: http.server.actions
+
+TUPLE: action quot params method ;
+
+C: <action> action
+
+: extract-params ( assoc action -- ... )
+    params>> [ first2 >r swap at r> call ] with each ;
+
+: call-action ;

extra/http/server/callbacks/callbacks.factor

@@ -50,12 +50,12 @@ SYMBOL: exit-continuation
     #! When executed inside a 'show' call, this will force a
     #! HTTP 302 to occur to instruct the browser to forward to
     #! the request URL.
-    <temporary-redirect> exit-with ;
+    request get swap <temporary-redirect> exit-with ;
 
 : cont-id "factorcontid" ;
 
 : id>url ( id -- url )
-    request get clone
+    request get
     swap cont-id associate >>query
     request-url ;
 
@@ -102,9 +102,8 @@ SYMBOL: current-show
     [ restore-request store-current-show ] when* ;
 
 : show-final ( quot -- * )
-    [
-        >r store-current-show redirect-to-here r> call exit-with
-    ] with-scope ; inline
+    >r redirect-to-here store-current-show
+    r> call exit-with ; inline
 
 M: callback-responder call-responder
     [
@@ -122,49 +121,15 @@ M: callback-responder call-responder
     ] callcc1 >r 3drop r> ;
 
 : show-page ( quot -- )
+    >r redirect-to-here store-current-show r>
     [
-        >r store-current-show redirect-to-here r>
-        [
-            [ ] register-callback
-            call
-            exit-with
-        ] callcc1 restore-request
-    ] with-scope ; inline
+        [ ] register-callback
+        with-scope
+        exit-with
+    ] callcc1 restore-request ; inline
 
 : quot-id ( quot -- id )
     current-show get swap t register-callback ;
 
 : quot-url ( quot -- url )
     quot-id id>url ;
-
-! SYMBOL: current-show
-! 
-! : store-current-show ( -- )
-!   #! Store the current continuation in the variable 'current-show'
-!   #! so it can be returned to later by href callbacks. Note that it
-!   #! recalls itself when the continuation is called to ensure that
-!   #! it resets its value back to the most recent show call.
-!   [  ( 0 -- )
-!       [ ( 0 1 -- )
-!           current-show set ( 0 -- )
-!           continue
-!       ] callcc1
-!       nip
-!       store-current-show
-!   ] callcc0 ;
-! 
-
-! 
-! : show-final ( quot -- * )
-!     store-current-show
-!     redirect-to-here
-!     call
-!     exit-with ; inline
-! 
-! : show-page ( quot -- request )
-!     store-current-show redirect-to-here
-!     [
-!         register-continuation
-!         call
-!         exit-with
-!     ] callcc1 restore-request ; inline

extra/http/server/db/db.factor

@@ -0,0 +1,13 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: db http.server kernel new-slots accessors ;
+IN: http.server.db
+
+TUPLE: db-persistence responder db params ;
+
+C: <db-persistence> db-persistence
+
+M: db-persistence call-responder
+    dup db>> over params>> [
+        responder>> call-responder
+    ] with-db ;

extra/http/server/server-tests.factor

@@ -51,3 +51,11 @@ M: mock-responder call-responder
         header>> "location" swap at "baz/" tail? r> and
     ] unit-test
 ] with-scope
+
+[
+    <dispatcher>
+        "default" <mock-responder> >>default
+    default-host set
+
+    [ "/default" ] [ "/default" default-host get find-responder drop ] unit-test
+] with-scope

extra/http/server/server.factor

@@ -3,7 +3,7 @@
 USING: assocs kernel namespaces io io.timeouts strings splitting
 threads http sequences prettyprint io.server logging calendar
 new-slots html.elements accessors math.parser combinators.lib
-vocabs.loader debugger html continuations random ;
+vocabs.loader debugger html continuations random combinators ;
 IN: http.server
 
 GENERIC: call-responder ( request path responder -- response )
@@ -12,7 +12,7 @@ TUPLE: trivial-responder response ;
 
 C: <trivial-responder> trivial-responder
 
-M: trivial-responder call-responder 2nip response>> call ;
+M: trivial-responder call-responder nip response>> call ;
 
 : trivial-response-body ( code message -- )
     <html>
@@ -33,18 +33,26 @@ M: trivial-responder call-responder 2nip response>> call ;
 
 SYMBOL: 404-responder
 
-[ <404> ] <trivial-responder> 404-responder set-global
+[ drop <404> ] <trivial-responder> 404-responder set-global
 
-: <redirect> ( to code message -- response )
+: modify-for-redirect ( request to -- url )
+    {
+        { [ dup "http://" head? ] [ nip ] }
+        { [ dup "/" head? ] [ >>path request-url ] }
+        { [ t ] [ >r dup path>> "/" last-split1 drop "/" r> 3append >>path request-url ] }
+    } cond ;
+
+: <redirect> ( request to code message -- response )
     <trivial-response>
-    swap "location" set-header ;
+    -rot modify-for-redirect
+    "location" set-header ;
 
 \ <redirect> DEBUG add-input-logging
 
-: <permanent-redirect> ( to -- response )
+: <permanent-redirect> ( request to -- response )
     301 "Moved Permanently" <redirect> ;
 
-: <temporary-redirect> ( to -- response )
+: <temporary-redirect> ( request to -- response )
     307 "Temporary Redirect" <redirect> ;
 
 : <content> ( content-type -- response )
@@ -54,31 +62,46 @@ SYMBOL: 404-responder
 
 TUPLE: dispatcher default responders ;
 
-: get-responder ( name dispatcher -- responder )
-    tuck responders>> at [ ] [ default>> ] ?if ;
+: <dispatcher> ( -- dispatcher )
+    404-responder H{ } clone dispatcher construct-boa ;
+
+: set-main ( dispatcher name -- dispatcher )
+    [ <temporary-redirect> ] curry
+    <trivial-responder> >>default ;
+
+: split-path ( path -- rest first )
+    [ CHAR: / = ] left-trim "/" split1 swap ;
 
 : find-responder ( path dispatcher -- path responder )
-    >r [ CHAR: / = ] left-trim "/" split1
-    swap [ CHAR: / = ] right-trim r> get-responder ;
+    over split-path pick responders>> at*
+    [ >r >r 2drop r> r> ] [ 2drop default>> ] if ;
 
 : redirect-with-/ ( request -- response )
-    dup path>> "/" append >>path
-    request-url <permanent-redirect> ;
+    dup path>> "/" append <permanent-redirect> ;
 
 M: dispatcher call-responder
     over [
-        find-responder call-responder
+        3dup find-responder call-responder [
+            >r 3drop r>
+        ] [
+            default>> [
+                call-responder
+            ] [
+                3drop f
+            ] if*
+        ] if*
     ] [
         2drop redirect-with-/
     ] if ;
 
-: <dispatcher> ( -- dispatcher )
-    404-responder get-global H{ } clone
-    dispatcher construct-boa ;
-
 : add-responder ( dispatcher responder path -- dispatcher )
     pick responders>> set-at ;
 
+: add-main-responder ( dispatcher responder path -- dispatcher )
+    [ add-responder ] keep set-main ;
+
+: <webapp> ( class -- dispatcher )
+    <dispatcher> swap construct-delegate ; inline
 SYMBOL: virtual-hosts
 SYMBOL: default-host
 
@@ -88,23 +111,33 @@ default-host global [ drop 404-responder get-global ] cache drop
 : find-virtual-host ( host -- responder )
     virtual-hosts get at [ default-host get ] unless* ;
 
+SYMBOL: development-mode
+
 : <500> ( error -- response )
     500 "Internal server error" <trivial-response>
     swap [
         "Internal server error" [
-            [ print-error nl :c ] with-html-stream
+            development-mode get [
+                [ print-error nl :c ] with-html-stream
+            ] [
+                500 "Internal server error"
+                trivial-response-body
+            ] if
         ] simple-page
     ] curry >>body ;
 
-: handle-request ( request -- )
-    [
-        dup dup path>> over host>>
-        find-virtual-host call-responder
-    ] [ <500> ] recover
+: do-response ( request response -- )
     dup write-response
     swap method>> "HEAD" =
     [ drop ] [ write-response-body ] if ;
 
+: do-request ( request -- request )
+    [
+        dup dup path>> over host>>
+        find-virtual-host call-responder
+        [ <404> ] unless*
+    ] [ dup \ do-request log-error <500> ] recover ;
+
 : default-timeout 1 minutes stdio get set-timeout ;
 
 LOG: httpd-hit NOTICE
@@ -112,16 +145,17 @@ LOG: httpd-hit NOTICE
 : log-request ( request -- )
     { method>> host>> path>> } map-exec-with httpd-hit ;
 
-SYMBOL: development-mode
-
-: (httpd) ( -- )
+: handle-client ( -- )
     default-timeout
     development-mode get-global
     [ global [ refresh-all ] bind ] when
-    read-request dup log-request handle-request ;
+    read-request
+    dup log-request
+    do-request do-response ;
 
 : httpd ( port -- )
-    internet-server "http.server" [ (httpd) ] with-server ;
+    internet-server "http.server"
+    [ handle-client ] with-server ;
 
 : httpd-main ( -- ) 8888 httpd ;
 

extra/http/server/sessions/sessions-tests.factor

@@ -1,7 +1,9 @@
-IN: temporary
+IN: http.server.sessions.tests
 USING: tools.test http.server.sessions math namespaces
 kernel accessors ;
 
+: with-session \ session swap with-variable ; inline
+
 "1234" f <session> [
     [ ] [ 3 "x" sset ] unit-test
     

extra/http/server/sessions/sessions.factor

@@ -9,10 +9,12 @@ IN: http.server.sessions
 ! WARNING: this session manager is vulnerable to XSRF attacks
 ! ! ! ! ! !
 
-TUPLE: session-manager responder init sessions ;
+GENERIC: init-session ( responder -- )
+
+TUPLE: session-manager responder sessions ;
 
 : <session-manager> ( responder class -- responder' )
-    >r [ ] H{ } clone session-manager construct-boa r>
+    >r H{ } clone session-manager construct-boa r>
     construct-delegate ; inline
 
 TUPLE: session id manager namespace alarm ;
@@ -42,13 +44,10 @@ TUPLE: session id manager namespace alarm ;
 
 : schange ( key quot -- ) session swap change-at ; inline
 
-: with-session ( session quot -- )
-    >r \ session r> with-variable ; inline
-
 : new-session ( responder -- id )
     [ sessions>> generate-key dup ] keep
     [ <session> dup touch-session ] keep
-    [ init>> with-session ] 2keep
+    [ swap \ session [ responder>> init-session ] with-variable ] 2keep
     >r over r> sessions>> set-at ;
 
 : get-session ( id responder -- session )
@@ -59,7 +58,7 @@ TUPLE: session id manager namespace alarm ;
     ] if ;
 
 : call-responder/session ( request path responder session -- response )
-    [ responder>> call-responder ] with-session ;
+    \ session set responder>> call-responder ;
 
 : sessions ( -- manager/f )
     \ session get dup [ manager>> ] when ;
@@ -82,7 +81,7 @@ M: url-sessions call-responder ( request path responder -- response )
         call-responder/session
     ] [
         new-session nip sess-id set-query-param
-        request-url <temporary-redirect>
+        dup request-url <temporary-redirect>
     ] if* ;
 
 M: url-sessions session-link*
@@ -96,14 +95,15 @@ TUPLE: cookie-sessions ;
 : <cookie-sessions> ( responder -- responder' )
     cookie-sessions <session-manager> ;
 
-: get-session-cookie ( request -- cookie )
-    sess-id get-cookie ;
+: get-session-cookie ( request responder -- cookie )
+    >r sess-id get-cookie dup
+    [ value>> r> get-session ] [ r> 2drop f ] if ;
 
 : <session-cookie> ( id -- cookie )
     sess-id <cookie> ;
 
 M: cookie-sessions call-responder ( request path responder -- response )
-    pick get-session-cookie value>> over get-session [
+    3dup nip get-session-cookie [
         call-responder/session
     ] [
         dup new-session

extra/http/server/static/static.factor

@@ -87,9 +87,17 @@ TUPLE: file-responder root hook special ;
         drop <404>
     ] if ;
 
+: <400> 400 "Bad request" <trivial-response> ;
+
 M: file-responder call-responder ( request path responder -- response )
-    [
-        responder set
-        swap request set
-        serve-object
-    ] with-scope ;
+    over [
+        ".." pick subseq? [
+            3drop <400>
+        ] [
+            responder set
+            swap request set
+            serve-object
+        ] if
+    ] [
+        2drop redirect-with-/
+    ] if ;