Improving session management and action link generation

extra/http/client/client.factor

@@ -95,5 +95,4 @@ PRIVATE>
     swap >>post-data-type ;
 
 : http-post ( content-type content url -- response string )
-    #! The content is URL encoded for you.
+    <post-request> http-request contents ;
-    >r url-encode r> <post-request> http-request contents ;

extra/http/http.factor

@@ -4,7 +4,8 @@ USING: fry hashtables io io.streams.string kernel math
 namespaces math.parser assocs sequences strings splitting ascii
 io.encodings.utf8 io.encodings.string namespaces unicode.case
 combinators vectors sorting new-slots accessors calendar
-calendar.format quotations arrays ;
+calendar.format quotations arrays combinators.cleave
+combinators.lib byte-arrays ;
 IN: http
 
 : http-port 80 ; inline
@@ -12,18 +13,21 @@ IN: http
 : url-quotable? ( ch -- ? )
     #! In a URL, can this character be used without
     #! URL-encoding?
-    dup letter?
+    {
-    over LETTER? or
+        [ dup letter? ]
-    over digit? or
+        [ dup LETTER? ]
-    swap "/_-." member? or ; foldable
+        [ dup digit? ]
+        [ dup "/_-.:" member? ]
+    } || nip ; foldable
 
 : push-utf8 ( ch -- )
-    1string utf8 encode [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
+    1string utf8 encode
+    [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
 
 : url-encode ( str -- str )
-    [ [
+    [
-        dup url-quotable? [ , ] [ push-utf8 ] if
+        [ dup url-quotable? [ , ] [ push-utf8 ] if ] each
-    ] each ] "" make ;
+    ] "" make ;
 
 : url-decode-hex ( index str -- )
     2dup length 2 - >= [
@@ -108,7 +112,12 @@ IN: http
     ] when ;
 
 : assoc>query ( hash -- str )
-    [ [ url-encode ] 2apply "=" swap 3append ] { } assoc>map
+    [
+        [ url-encode ]
+        [ dup number? [ number>string ] when url-encode ]
+        bi*
+        "=" swap 3append
+    ] { } assoc>map
     "&" join ;
 
 TUPLE: cookie name value path domain expires http-only ;
@@ -245,6 +254,10 @@ SYMBOL: max-post-request
 : extract-post-data-type ( request -- request )
     dup "content-type" header >>post-data-type ;
 
+: parse-post-data ( request -- request )
+    dup post-data-type>> "application/x-www-form-urlencoded" =
+    [ dup post-data>> query>assoc >>post-data ] when ;
+
 : extract-cookies ( request -- request )
     dup "cookie" header [ parse-cookies >>cookies ] when* ;
 
@@ -257,24 +270,31 @@ SYMBOL: max-post-request
     read-post-data
     extract-host
     extract-post-data-type
+    parse-post-data
     extract-cookies ;
 
 : write-method ( request -- request )
     dup method>> write bl ;
 
-: write-url ( request -- request )
+: (link>string) ( url query -- url' )
-    dup path>> url-encode write
+    [ url-encode ] [ assoc>query ] bi*
-    dup query>> dup assoc-empty? [ drop ] [
+    dup empty? [ drop ] [ "?" swap 3append ] if ;
-        "?" write
+
-        assoc>query write
+: write-url ( request -- )
-    ] if ;
+    [ path>> ] [ query>> ] bi (link>string) write ;
 
 : write-request-url ( request -- request )
-    write-url bl ;
+    dup write-url bl ;
 
 : write-version ( request -- request )
     "HTTP/" write dup request-version write crlf ;
 
+: unparse-post-data ( request -- request )
+    dup post-data>> dup sequence? [ drop ] [
+        assoc>query >>post-data
+        "application/x-www-form-urlencoded" >>post-data-type
+    ] if ;
+
 : write-request-header ( request -- request )
     dup header>> >hashtable
     over host>> [ "host" pick set-at ] when*
@@ -287,6 +307,7 @@ SYMBOL: max-post-request
     dup post-data>> [ write ] when* ;
 
 : write-request ( request -- )
+    unparse-post-data
     write-method
     write-request-url
     write-version
@@ -296,16 +317,17 @@ SYMBOL: max-post-request
     drop ;
 
 : request-url ( request -- url )
+    [
         [
             dup host>> [
-            "http://" write
+                [ "http://" write host>> url-encode write ]
-            dup host>> url-encode write
+                [ ":" write port>> number>string write ]
-            ":" write
+                bi
-            dup port>> number>string write
+            ] [ drop ] if
-        ] when
+        ]
-        dup path>> "/" head? [ "/" write ] unless
+        [ path>> "/" head? [ "/" write ] unless ]
-        write-url
+        [ write-url ]
-        drop
+        tri
     ] with-string-writer ;
 
 : set-header ( request/response value key -- request/response )

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

@@ -29,6 +29,7 @@ blah
 STRING: action-request-test-2
 POST http://foo/bar/baz HTTP/1.1
 content-length: 5
+content-type: application/x-www-form-urlencoded
 
 xxx=4
 ;

extra/http/server/actions/actions.factor

@@ -17,14 +17,6 @@ TUPLE: action init display submit get-params post-params ;
         [ <400> ] >>display
         [ <400> ] >>submit ;
 
-: extract-params ( path -- assoc )
-    +path+ associate
-    request get dup method>> {
-        { "GET" [ query>> ] }
-        { "HEAD" [ query>> ] }
-        { "POST" [ post-data>> query>assoc ] }
-    } case union ;
-
 : with-validator ( string quot -- result error? )
     '[ , @ f ] [
         dup validation-error? [ t ] [ rethrow ] if
@@ -50,12 +42,10 @@ TUPLE: action init display submit get-params post-params ;
     action get display>> call exit-with ;
 
 M: action call-responder ( path action -- response )
-    [ extract-params params set ]
+    [ +path+ associate request-params union params set ]
-    [
+    [ action set ] bi*
-        action set
     request get method>> {
         { "GET" [ handle-get ] }
         { "HEAD" [ handle-get ] }
         { "POST" [ handle-post ] }
-        } case
+    } case ;
-    ] bi* ;

extra/http/server/auth/login/login.factor

@@ -30,7 +30,8 @@ SYMBOL: login-failed?
 
 : successful-login ( user -- response )
     logged-in-user sset
-    post-login-url sget f <permanent-redirect> ;
+    post-login-url sget "" or f <permanent-redirect>
+    f post-login-url sset ;
 
 :: <login-action> ( -- action )
     [let | form [ <login-form> ] |

extra/http/server/auth/login/login.fhtml

@@ -1,10 +1,13 @@
-<% USING: http.server.auth.login http.server.components kernel
+<% USING: http.server.auth.login http.server.components http.server
-namespaces ; %>
+kernel namespaces ; %>
 <html>
 <body>
 <h1>Login required</h1>
 
 <form method="POST" action="login">
+
+<% hidden-form-field %>
+
 <table>
 
 <tr>
@@ -30,10 +33,12 @@ login-failed? get
 
 <p>
 <% allow-registration? [ %>
-    <a href="register">Register</a>
+    <a href="<% "register" f write-link %>">Register</a>
 <% ] when %>
 <% allow-password-recovery? [ %>
-    <a href="recover-password">Recover Password</a>
+    <a href="<% "recover-password" f write-link %>">
+    	Recover Password
+    </a>
 <% ] when %>
 </p>
 

extra/http/server/auth/login/recover-1.fhtml

@@ -1,4 +1,4 @@
-<% USING: http.server.components ; %>
+<% USING: http.server.components http.server ; %>
 <html>
 <body>
 <h1>Recover lost password: step 1 of 4</h1>
@@ -6,6 +6,9 @@
 <p>Enter the username and e-mail address you used to register for this site, and you will receive a link for activating a new password.</p>
 
 <form method="POST" action="recover-password">
+
+<% hidden-form-field %>
+
 <table>
 
 <tr>

extra/http/server/auth/login/recover-3.fhtml

@@ -1,4 +1,4 @@
-<% USING: http.server.components http.server.auth.login
+<% USING: http.server.components http.server.auth.login http.server
 namespaces kernel combinators ; %>
 <html>
 <body>
@@ -7,6 +7,9 @@ namespaces kernel combinators ; %>
 <p>Choose a new password for your account.</p>
 
 <form method="POST" action="new-password">
+
+<% hidden-form-field %>
+
 <table>
 
 <% "username" component render-edit %>

extra/http/server/auth/login/recover-4.fhtml

@@ -1,10 +1,10 @@
-<% USING: http.server.components http.server.auth.login
+<% USING: http.server ; %>
-namespaces kernel combinators ; %>
 <html>
 <body>
 <h1>Recover lost password: step 4 of 4</h1>
 
-<p>Your password has been reset. You may now <a href="login">log in</a>.</p>
+<p>Your password has been reset.
+You may now <a href="<% "login" f write-link %>">log in</a>.</p>
 
 </body>
 </html>

extra/http/server/auth/login/register.fhtml

@@ -1,10 +1,12 @@
 <% USING: http.server.components http.server.auth.login
-namespaces kernel combinators ; %>
+http.server namespaces kernel combinators ; %>
 <html>
 <body>
 <h1>New user registration</h1>
 
 <form method="POST" action="register">
+<% hidden-form-field %>
+
 <table>
 
 <tr>

extra/http/server/auth/providers/db/db.factor

@@ -14,9 +14,7 @@ user "USERS"
     { "profile" "PROFILE" FACTOR-BLOB }
 } define-persistent
 
-: init-users-table ( -- )
+: init-users-table user ensure-table ;
-    [ user drop-table ] ignore-errors
-    user create-table ;
 
 TUPLE: from-db ;
 

extra/http/server/server.factor

@@ -9,6 +9,13 @@ IN: http.server
 
 GENERIC: call-responder ( path responder -- response )
 
+: request-params ( -- assoc )
+    request get dup method>> {
+        { "GET" [ query>> ] }
+        { "HEAD" [ query>> ] }
+        { "POST" [ post-data>> ] }
+    } case ;
+
 : <content> ( content-type -- response )
     <response>
         200 >>code
@@ -45,19 +52,27 @@ SYMBOL: 404-responder
 
 [ <404> ] <trivial-responder> 404-responder set-global
 
-: url-redirect ( to query -- url )
+SYMBOL: link-hook
-    #! Different host.
+
-    dup assoc-empty? [
+: modify-query ( query -- query )
-        drop
+    link-hook get [ ] or call ;
-    ] [
+
-        assoc>query "?" swap 3append
+: link>string ( url query -- url' )
-    ] if ;
+    modify-query (link>string) ;
+
+: write-link ( url query -- )
+    link>string write ;
+
+SYMBOL: form-hook
+
+: hidden-form-field ( -- )
+    form-hook get [ ] or call ;
 
 : absolute-redirect ( to query -- url )
     #! Same host.
     request get clone
         swap [ >>query ] when*
-        swap >>path
+        swap url-encode >>path
     request-url ;
 
 : replace-last-component ( path with -- path' )
@@ -67,11 +82,12 @@ SYMBOL: 404-responder
     request get clone
     swap [ >>query ] when*
     swap [ '[ , replace-last-component ] change-path ] when*
+    dup query>> modify-query >>query
     request-url ;
 
 : derive-url ( to query -- url )
     {
-        { [ over "http://" head? ] [ url-redirect ] }
+        { [ over "http://" head? ] [ link>string ] }
         { [ over "/" head? ] [ absolute-redirect ] }
         { [ t ] [ relative-redirect ] }
     } cond ;

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

@@ -2,6 +2,8 @@ IN: http.server.sessions.tests
 USING: tools.test http.server.sessions math namespaces
 kernel accessors ;
 
+[ H{ } ] [ H{ } add-session-id ] unit-test
+
 : with-session \ session swap with-variable ; inline
 
 TUPLE: foo ;
@@ -10,7 +12,9 @@ C: <foo> foo
 
 M: foo init-session* drop 0 "x" sset ;
 
-f <session> [
+f <session> "123" >>id [
+    [ H{ { "factorsessid" "123" } } ] [ H{ } add-session-id ] unit-test
+
     [ ] [ 3 "x" sset ] unit-test
     
     [ 9 ] [ "x" sget sq ] unit-test

extra/http/server/sessions/sessions.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs calendar kernel math.parser namespaces random
 boxes alarms new-slots accessors http http.server
-quotations hashtables sequences fry combinators.cleave ;
+quotations hashtables sequences fry combinators.cleave
+html.elements ;
 IN: http.server.sessions
 
 ! ! ! ! ! !
@@ -67,12 +68,6 @@ TUPLE: session manager id namespace alarm ;
 : sessions ( -- manager/f )
     \ session get dup [ manager>> ] when ;
 
-GENERIC: session-link* ( url query sessions -- string )
-
-M: object session-link* 2drop url-encode ;
-
-: session-link ( url query -- string ) sessions session-link* ;
-
 TUPLE: null-sessions ;
 
 : <null-sessions>
@@ -88,23 +83,30 @@ TUPLE: url-sessions ;
 
 : sess-id "factorsessid" ;
 
-: current-session ( responder request -- session )
+: current-session ( responder -- session )
-    sess-id query-param swap get-session ;
+    >r request-params sess-id swap at r> get-session ;
+
+: add-session-id ( query -- query' )
+    \ session get [ id>> sess-id associate union ] when* ;
+
+: session-form-field ( -- )
+    <input
+    "hidden" =type
+    sess-id =id
+    sess-id =name
+    \ session get id>> =value
+    input/> ;
 
 M: url-sessions call-responder ( path responder -- response )
-    dup request get current-session [
+    [ add-session-id ] link-hook set
+    [ session-form-field ] form-hook set
+    dup current-session [
         call-responder/session
     ] [
         nip
         f swap new-session sess-id associate <temporary-redirect>
     ] if* ;
 
-M: url-sessions session-link*
-    drop
-    url-encode
-    \ session get id>> sess-id associate union assoc>query
-    dup assoc-empty? [ drop ] [ "?" swap 3append ] if ;
-
 TUPLE: cookie-sessions ;
 
 : <cookie-sessions> ( responder -- responder' )