Start page flow code

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

@@ -13,6 +13,7 @@ http.server.auth.providers
 http.server.auth.providers.null
 http.server.actions
 http.server.components
+http.server.flows
 http.server.forms
 http.server.sessions
 http.server.boilerplate
@@ -22,7 +23,6 @@ http.server.validators ;
 IN: http.server.auth.login
 QUALIFIED: smtp
 
-SYMBOL: post-login-url
 SYMBOL: login-failed?
 
 TUPLE: login < dispatcher users ;
@@ -60,8 +60,7 @@ M: user-saver dispose
 
 : successful-login ( user -- response )
     logged-in-user sset
-    post-login-url sget "$login" or f <permanent-redirect>
+    "$login" end-flow ;
-    f post-login-url sset ;
 
 :: <login-action> ( -- action )
     [let | form [ <login-form> ] |
@@ -155,8 +154,6 @@ SYMBOL: user-exists?
         "verify-password" <password> add-field
         "email" <email> add-field ;
 
-SYMBOL: previous-page
-
 :: <edit-profile-action> ( -- action )
     [let | form [ <edit-profile-form> ] |
         <action>
@@ -196,7 +193,7 @@ SYMBOL: previous-page
 
                 user-profile-changed? on
 
-                previous-page sget f <permanent-redirect>
+                "$login" end-flow
             ] >>submit
     ] ;
 
@@ -342,14 +339,15 @@ TUPLE: protected responder ;
 
 C: <protected> protected
 
+M: protected init-session* responder>> init-session* ;
+
 : show-login-page ( -- response )
-    request get request-url post-login-url sset
+    begin-flow
     "$login/login" f <temporary-redirect> ;
 
 M: protected call-responder ( path responder -- response )
     logged-in-user sget dup [
         save-user-after
-        request get request-url previous-page sset
         responder>> call-responder
     ] [
         3drop

extra/http/server/boilerplate/boilerplate.factor

@@ -5,6 +5,7 @@ io io.streams.string arrays
 html.elements
 http
 http.server
+http.server.sessions
 http.server.templating ;
 IN: http.server.boilerplate
 
@@ -12,6 +13,8 @@ TUPLE: boilerplate responder template ;
 
 : <boilerplate> f boilerplate boa ;
 
+M: boilerplate init-session* responder>> init-session* ;
+
 SYMBOL: title
 
 : set-title ( string -- )

extra/http/server/db/db.factor

@@ -1,11 +1,13 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: db http.server kernel accessors
+USING: db http.server http.server.sessions kernel accessors
 continuations namespaces destructors ;
 IN: http.server.db
 
 TUPLE: db-persistence responder db params ;
 
+M: db-persistence init-session* responder>> init-session* ;
+
 C: <db-persistence> db-persistence
 
 : connect-db ( db-persistence -- )

extra/http/server/flows/flows.factor

@@ -0,0 +1,50 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors namespaces sequences arrays kernel
+assocs assocs.lib hashtables math.parser
+html.elements http http.server http.server.sessions ;
+IN: http.server.flows
+
+TUPLE: flows responder ;
+
+C: <flows> flows
+
+: begin-flow* ( -- id )
+    request get [ path>> ] [ query>> ] bi 2array
+    flows sget set-at-unique
+    session-changed ;
+
+: end-flow* ( default id -- response )
+    flows sget at [ first2 ] [ f ] ?if <permanent-redirect> ;
+
+SYMBOL: flow-id
+
+: flow-id-key "factorflowid" ;
+
+: begin-flow ( -- )
+    begin-flow* flow-id set ;
+
+: end-flow ( default -- response )
+    flow-id get end-flow* ;
+
+: add-flow-id ( query -- query' )
+    flow-id get [ flow-id-key associate assoc-union ] when* ;
+
+: flow-form-field ( -- )
+    flow-id get [
+        <input
+            "hidden" =type
+            flow-id-key =name
+            =value
+        input/>
+    ] when* ;
+
+M: flows call-responder
+    [ add-flow-id ] add-link-hook
+    [ flow-form-field ] add-form-hook
+    flow-id-key request-params at flow-id set
+    responder>> call-responder ;
+
+M: flows init-session*
+    H{ } clone flows sset
+    responder>> init-session* ;

extra/http/server/server.factor

@@ -69,8 +69,11 @@ SYMBOL: base-paths
 
 SYMBOL: link-hook
 
+: add-link-hook ( quot -- )
+    link-hook [ compose ] change ; inline
+
 : modify-query ( query -- query )
-    link-hook get [ ] or call ;
+    link-hook get call ;
 
 : base-path ( string -- path )
     dup base-paths get at
@@ -93,8 +96,11 @@ SYMBOL: link-hook
 
 SYMBOL: form-hook
 
+: add-form-hook ( quot -- )
+    form-hook [ compose ] change ;
+
 : hidden-form-field ( -- )
-    form-hook get [ ] or call ;
+    form-hook get call ;
 
 : absolute-redirect ( to query -- url )
     #! Same host.
@@ -226,6 +232,9 @@ SYMBOL: exit-continuation
 : do-request ( request -- response )
     [
         H{ } clone base-paths set
+        [ ] link-hook set
+        [ ] form-hook set
+
         [ log-request ]
         [ request set ]
         [ path>> split-path main-responder get call-responder ] tri

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

@@ -3,7 +3,7 @@ USING: tools.test http http.server.sessions
 http.server.sessions.storage http.server.sessions.storage.db
 http.server.actions http.server math namespaces kernel accessors
 prettyprint io.streams.string io.files splitting destructors
-sequences db db.sqlite ;
+sequences db db.sqlite continuations ;
 
 : with-session
     [
@@ -49,8 +49,12 @@ M: foo call-responder
             "text/plain" <content> exit-with
         ] >>display ;
 
+[ "auth-test.db" temp-file sqlite-db delete-file ] ignore-errors
+
 "auth-test.db" temp-file sqlite-db [
 
+    init-sessions-table
+
     [
         empty-session
             123 >>id session set

extra/http/server/sessions/sessions.factor

@@ -10,11 +10,7 @@ http.server.sessions.storage.null
 html.elements ;
 IN: http.server.sessions
 
-! ! ! ! ! !
+TUPLE: session id expiry namespace changed? ;
-! WARNING: this session manager is vulnerable to XSRF attacks
-! ! ! ! ! !
-
-TUPLE: session id user-agent client-addr namespace ;
 
 : <session> ( id -- session )
     session new
@@ -24,6 +20,8 @@ GENERIC: init-session* ( responder -- )
 
 M: object init-session* drop ;
 
+M: dispatcher init-session* default>> init-session* ;
+
 TUPLE: session-manager responder sessions ;
 
 : new-session-manager ( responder class -- responder' )
@@ -31,18 +29,23 @@ TUPLE: session-manager responder sessions ;
         null-sessions >>sessions
         swap >>responder ; inline
 
-SYMBOL: session-changed?
+: (session-changed) ( session -- )
+    t >>changed? drop ;
+
+: session-changed ( -- )
+    session get (session-changed) ;
 
 : sget ( key -- value )
     session get namespace>> at ;
 
 : sset ( value key -- )
-    session get namespace>> set-at
+    session get
-    session-changed? on ;
+    [ namespace>> set-at ] [ (session-changed) ] bi ;
 
 : schange ( key quot -- )
-    session get namespace>> swap change-at
+    session get
-    session-changed? on ; inline
+    [ namespace>> swap change-at ] keep
+    (session-changed) ; inline
 
 : sessions session-manager get sessions>> ;
 
@@ -51,11 +54,18 @@ SYMBOL: session-changed?
 : init-session ( session managed -- )
     >r session r> '[ , init-session* ] with-variable ;
 
+: timeout 20 minutes ;
+
+: cutoff-time ( -- time )
+    now timeout time+ timestamp>millis ;
+
+: touch-session ( session -- )
+    cutoff-time >>expiry drop ;
+
 : empty-session ( -- session )
     f <session>
-        "" >>user-agent
+        H{ } clone >>namespace
-        "" >>client-addr
+        dup touch-session ;
-        H{ } clone >>namespace ;
 
 : begin-session ( responder -- session )
     >r empty-session r>
@@ -70,8 +80,9 @@ TUPLE: session-saver session ;
 C: <session-saver> session-saver
 
 M: session-saver dispose
-    session-changed? get
+    session>> dup changed?>> [
-    [ session>> sessions update-session ] [ drop ] if ;
+        [ touch-session ] [ sessions update-session ] bi
+    ] [ drop ] if ;
 
 : save-session-after ( session -- )
     <session-saver> add-always-destructor ;
@@ -80,14 +91,6 @@ M: session-saver dispose
     [ save-session-after ] [ session set ] bi
     [ session-manager set ] [ responder>> call-responder ] bi ;
 
-TUPLE: null-sessions < session-manager ;
-
-: <null-sessions> ( responder -- manager )
-    null-sessions new-session-manager ;
-
-M: null-sessions call-responder ( path responder -- response )
-    <session> call-responder/session ;
-
 TUPLE: url-sessions < session-manager ;
 
 : <url-sessions> ( responder -- responder' )
@@ -105,9 +108,8 @@ TUPLE: url-sessions < session-manager ;
 : session-form-field ( -- )
     <input
         "hidden" =type
-        session-id-key =id
         session-id-key =name
-        session get id>> =value
+        session get id>> number>string =value
     input/> ;
 
 : new-url-session ( path responder -- response )
@@ -115,8 +117,8 @@ TUPLE: url-sessions < session-manager ;
     <temporary-redirect> ;
 
 M: url-sessions call-responder ( path responder -- response )
-    [ add-session-id ] link-hook set
+    [ add-session-id ] add-link-hook
-    [ session-form-field ] form-hook set
+    [ session-form-field ] add-form-hook
     dup current-url-session [
         call-responder/session
     ] [

extra/http/server/sessions/storage/db/db.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs accessors kernel http.server.sessions.storage
-http.server.sessions http.server db.tuples db.types math.parser
+http.server.sessions http.server db db.tuples db.types math.parser
-classes.singleton random ;
+math.intervals fry random calendar sequences alarms ;
 IN: http.server.sessions.storage.db
 
 SINGLETON: sessions-in-db
@@ -11,8 +11,7 @@ session "SESSIONS"
 {
     ! { "id" "ID" +random-id+ system-random-generator }
     { "id" "ID" INTEGER +native-id+ }
-    { "user-agent" "USERAGENT" { VARCHAR 256 } +not-null+ }
+    { "expiry" "EXPIRY" BIG-INTEGER +not-null+ }
-    { "client-addr" "CLIENTADDR" { VARCHAR 256 } +not-null+ }
     { "namespace" "NAMESPACE" FACTOR-BLOB }
 } define-persistent
 
@@ -29,3 +28,13 @@ M: sessions-in-db delete-session ( id storage -- )
 
 M: sessions-in-db new-session ( session storage -- )
     drop insert-tuple ;
+
+: expired-sessions ( -- session )
+    f <session>
+    USE: math now timestamp>millis [ 60 60 * 1000 * - ] keep [a,b] >>expiry
+    select-tuples ;
+
+: start-expiring-sessions ( db seq -- )
+    '[
+        , , [ expired-sessions [ delete-tuple ] each ] with-db
+    ] 5 minutes every drop ;

extra/http/server/sessions/storage/storage.factor

@@ -3,8 +3,6 @@
 USING: calendar ;
 IN: http.server.sessions.storage
 
-: timeout 20 minutes ;
-
 GENERIC: get-session ( id storage -- session )
 
 GENERIC: update-session ( session storage -- )

extra/http/server/templating/chloe/chloe.factor

@@ -4,6 +4,7 @@ io io.files io.encodings.utf8 html.elements unicode.case
 tuple-syntax xml xml.data xml.writer xml.utilities
 http.server
 http.server.auth
+http.server.flows
 http.server.components
 http.server.sessions
 http.server.templating
@@ -83,14 +84,33 @@ SYMBOL: tags
     dup empty?
     [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
 
+: a-flow-attr ( tag -- )
+    "flow" optional-attr {
+        { "none" [ flow-id off ] }
+        { "begin" [ begin-flow ] }
+        { "current" [ ] }
+        { f [ ] }
+    } case ;
+
+: a-session-attr ( tag -- )
+    "session" optional-attr {
+        { "none" [ session off flow-id off ] }
+        { "current" [ ] }
+        { f [ ] }
+    } case ;
+
 : a-start-tag ( tag -- )
+    [
         <a
+        dup a-flow-attr
+        dup a-session-attr
         dup "value" optional-attr [ value f ] [
             [ "href" required-attr ]
             [ "query" optional-attr parse-query-attr ]
             bi
         ] ?if link>string =href
-    a> ;
+        a>
+    ] with-scope ;
 
 : process-tag-children ( tag -- )
     [ process-template ] each ;

extra/webapps/factor-website/factor-website.factor

@@ -4,6 +4,7 @@ USING: accessors kernel sequences assocs io.files io.sockets
 namespaces db db.sqlite smtp
 http.server
 http.server.db
+http.server.flows
 http.server.sessions
 http.server.auth.login
 http.server.auth.providers.db
@@ -20,27 +21,6 @@ IN: webapps.factor-website
 : factor-template ( path -- template )
     "resource:extra/webapps/factor-website/" swap ".xml" 3append <chloe> ;
 
-: <factor-boilerplate> ( responder -- responder' )
-    <login>
-        users-in-db >>users
-        allow-registration
-        allow-password-recovery
-        allow-edit-profile
-    <boilerplate>
-        "page" factor-template >>template
-    <url-sessions>
-        sessions-in-db >>sessions
-    test-db <db-persistence> ;
-
-: <pastebin-app> ( -- responder )
-    <pastebin> <factor-boilerplate> ;
-
-: <planet-app> ( -- responder )
-    <planet-factor> <factor-boilerplate> ;
-
-: <todo-app> ( -- responder )
-    <todo-list> <protected> <factor-boilerplate> ;
-
 : init-factor-db ( -- )
     test-db [
         init-users-table
@@ -56,9 +36,20 @@ IN: webapps.factor-website
 
 : <factor-website> ( -- responder )
     <dispatcher>
-        <todo-app> "todo" add-responder
+        <todo-list> "todo" add-responder
-        <pastebin-app> "pastebin" add-responder
+        <pastebin> "pastebin" add-responder
-        <planet-app> "planet" add-responder ;
+        <planet-factor> "planet" add-responder
+    <login>
+        users-in-db >>users
+        allow-registration
+        allow-password-recovery
+        allow-edit-profile
+    <boilerplate>
+        "page" factor-template >>template
+    <flows>
+    <url-sessions>
+        sessions-in-db >>sessions
+    test-db <db-persistence> ;
 
 : init-factor-website ( -- )
     "factorcode.org" 25 <inet> smtp-server set-global
@@ -66,6 +57,9 @@ IN: webapps.factor-website
 
     init-factor-db
 
-    <factor-website> main-responder set-global
+    <factor-website> main-responder set-global ;
 
-    "planet" main-responder get responders>> at start-update-task ;
+: start-factor-website
+    test-db start-expiring-sessions
+    "planet" main-responder get responders>> at test-db start-update-task
+    8812 httpd ;

extra/webapps/pastebin/pastebin.xml

@@ -13,7 +13,7 @@
 
 		<t:comment>
 		<t:if code="http.server.auth.login:allow-edit-profile?">
-			| <t:a href="$login/edit-profile">Edit Profile</t:a>
+			| <t:a href="$login/edit-profile" flow="begin">Edit Profile</t:a>
 		</t:if>
 
 		<t:form action="$login/logout" class="inline">

extra/webapps/planet/entry-summary.xml

@@ -4,7 +4,7 @@
 
 	<p class="news">
 		<strong><t:view component="title" /></strong> <br/>
-		<t:a value="link" class="more">Read More...</t:a>
+		<t:a value="link" session="none" class="more">Read More...</t:a>
 	</p>
 
 </t:chloe>

extra/webapps/planet/entry.xml

@@ -3,7 +3,7 @@
 <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
 
 	<h2 class="posting-title">
-		<t:a value="link"><t:view component="title" /></t:a>
+		<t:a value="link" session="none"><t:view component="title" /></t:a>
 	</h2>
 
 	<p class="posting-body">
@@ -11,7 +11,7 @@
 	</p>
 
 	<p class="posting-date">
-		<t:a value="link"><t:view component="pub-date" /></t:a>
+		<t:a value="link" session="none"><t:view component="pub-date" /></t:a>
 	</p>
 
 </t:chloe>

extra/webapps/planet/planet.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors sequences sorting locals math
 calendar alarms logging concurrency.combinators namespaces
-sequences.lib db.types db.tuples db
+sequences.lib db.types db.tuples db fry
 rss xml.writer
 http.server
 http.server.crud
@@ -167,5 +167,7 @@ blog "BLOGS"
     <boilerplate>
         "planet" planet-template >>template ;
 
-: start-update-task ( planet -- )
+: start-update-task ( planet db seq -- )
-    [ update-cached-postings ] curry 10 minutes every drop ;
+    '[
+        , , , [ update-cached-postings ] with-db
+    ] 10 minutes every drop ;

extra/webapps/planet/planet.xml

@@ -14,7 +14,7 @@
 
 		<t:comment>
 		<t:if code="http.server.auth.login:allow-edit-profile?">
-			| <t:a href="$login/edit-profile">Edit Profile</t:a>
+			| <t:a href="$login/edit-profile" flow="begin">Edit Profile</t:a>
 		</t:if>
 
 		<t:form action="$login/logout" class="inline">

extra/webapps/todo/todo.xml

@@ -9,7 +9,7 @@
 		| <t:a href="$todo-list/edit">Add Item</t:a>
 
 		<t:if code="http.server.auth.login:allow-edit-profile?">
-			| <t:a href="$login/edit-profile">Edit Profile</t:a>
+			| <t:a href="$login/edit-profile" flow="begin">Edit Profile</t:a>
 		</t:if>
 
 		<t:form action="$login/logout" class="inline">