New furnace.alloy vocab makes things easier; add expiration for asides and flash scopes

extra/furnace/alloy/alloy.factor

@@ -0,0 +1,24 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences db.tuples alarms calendar db fry
+furnace.cache
+furnace.asides
+furnace.flash
+furnace.sessions
+furnace.db
+furnace.auth.providers ;
+IN: furnace.alloy
+
+: <alloy> ( responder db params -- responder' )
+    [ <asides> <flash-scopes> <sessions> ] 2dip <db-persistence> ;
+
+: state-classes { session flash-scope aside } ; inline
+
+: init-furnace-tables ( -- )
+    state-classes ensure-tables
+    user ensure-table ;
+
+: start-expiring ( db params -- )
+    '[
+        , , [ state-classes [ expire-state ] each ] with-db
+    ] 5 minutes every drop ;

extra/furnace/asides/asides.factor

@@ -2,37 +2,60 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors namespaces sequences arrays kernel
 assocs assocs.lib hashtables math.parser urls combinators
-furnace http http.server http.server.filters furnace.sessions
+html.elements html.templates.chloe.syntax db.types db.tuples
-html.elements html.templates.chloe.syntax ;
+http http.server http.server.filters 
+furnace furnace.cache furnace.sessions ;
 IN: furnace.asides
 
-TUPLE: asides < filter-responder ;
+TUPLE: aside < server-state session method url post-data ;
 
-C: <asides> asides
+: <aside> ( id -- aside )
+    aside new-server-state ;
+
+aside "ASIDES"
+{
+    { "session" "SESSION" BIG-INTEGER +not-null+ }
+    { "method" "METHOD" { VARCHAR 10 } +not-null+ }
+    { "url" "URL" URL +not-null+ }
+    { "post-data" "POST_DATA" FACTOR-BLOB }
+} define-persistent
+
+TUPLE: asides < server-state-manager ;
+
+: <asides> ( responder -- responder' )
+    asides new-server-state-manager ;
 
 : begin-aside* ( -- id )
-    request get
+    f <aside>
-    [ url>> ] [ post-data>> ] [ method>> ] tri 3array
+        session get id>> >>session
-    asides sget set-at-unique
+        request get
-    session-changed ;
+        [ method>> >>method ]
+        [ url>> >>url ]
+        [ post-data>> >>post-data ]
+        tri
+    [ asides get touch-state ] [ insert-tuple ] [ id>> ] tri ;
 
-: end-aside-post ( url post-data -- response )
+: end-aside-post ( aside -- response )
     request [
         clone
-            swap >>post-data
+            over post-data>> >>post-data
-            swap >>url
+            over url>> >>url
     ] change
-    request get url>> path>> split-path
+    url>> path>> split-path
     asides get responder>> call-responder ;
 
 ERROR: end-aside-in-get-error ;
 
+: get-aside ( id -- aside )
+    dup [ aside get-state ] when
+    dup [ dup session>> session get id>> = [ drop f ] unless ] when ;
+
 : end-aside* ( url id -- response )
     request get method>> "POST" = [ end-aside-in-get-error ] unless
-    asides sget at [
+    aside get-state [
-        first3 {
+        dup method>> {
-            { "GET" [ drop <redirect> ] }
+            { "GET" [ url>> <redirect> ] }
-            { "HEAD" [ drop <redirect> ] }
+            { "HEAD" [ url>> <redirect> ] }
             { "POST" [ end-aside-post ] }
         } case
     ] [ <redirect> ] ?if ;
@@ -47,13 +70,12 @@ SYMBOL: aside-id
 : end-aside ( default -- response )
     aside-id [ f ] change end-aside* ;
 
+: request-aside-id ( request -- aside-id )
+    aside-id-key swap request-params at string>number ;
+
 M: asides call-responder*
     dup asides set
-    aside-id-key request get request-params at aside-id set
+    request get request-aside-id aside-id set
-    call-next-method ;
-
-M: asides init-session*
-    H{ } clone asides sset
     call-next-method ;
 
 M: asides link-attr ( tag -- )

extra/furnace/auth/providers/db/db-tests.factor

@@ -14,7 +14,7 @@ login set
 
 "auth-test.db" temp-file sqlite-db [
 
-    init-users-table
+    user ensure-table
 
     [ t ] [
         "slava" <user>

extra/furnace/auth/providers/db/db.factor

@@ -18,8 +18,6 @@ user "USERS"
     { "deleted" "DELETED" INTEGER +not-null+ }
 } define-persistent
 
-: init-users-table ( -- ) user ensure-table ;
-
 SINGLETON: users-in-db
 
 M: users-in-db get-user

extra/furnace/cache/cache.factor

@@ -0,0 +1,36 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors math.intervals
+calendar alarms fry
+random db db.tuples db.types
+http.server.filters ;
+IN: furnace.cache
+
+TUPLE: server-state id expires ;
+
+: new-server-state ( id class -- server-state )
+    new swap >>id ; inline
+
+server-state f
+{
+    { "id" "ID" +random-id+ system-random-generator }
+    { "expires" "EXPIRES" TIMESTAMP +not-null+ }
+} define-persistent
+
+: get-state ( id class -- state )
+    new-server-state select-tuple ;
+
+: expire-state ( class -- )
+    new
+        -1.0/0.0 now [a,b] >>expires
+    delete-tuples ;
+
+TUPLE: server-state-manager < filter-responder timeout ;
+
+: new-server-state-manager ( responder class -- responder' )
+    new
+        swap >>responder
+        20 minutes >>timeout ; inline
+    
+: touch-state ( state manager -- )
+    timeout>> from-now >>expires drop ;

extra/furnace/flash/flash.factor

@@ -1,38 +1,59 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces assocs assocs.lib kernel sequences urls
+USING: namespaces assocs assocs.lib kernel sequences accessors
+urls db.types db.tuples math.parser fry
 http http.server http.server.filters http.server.redirection
-furnace furnace.sessions ;
+furnace furnace.cache furnace.sessions ;
 IN: furnace.flash
 
+TUPLE: flash-scope < server-state session namespace ;
+
+: <flash-scope> ( id -- aside )
+    flash-scope new-server-state ;
+
+flash-scope "FLASH_SCOPES" {
+    { "session" "SESSION" BIG-INTEGER +not-null+ }
+    { "namespace" "NAMESPACE" FACTOR-BLOB +not-null+ }
+} define-persistent
+
 : flash-id-key "__f" ;
 
-TUPLE: flash-scopes < filter-responder ;
+TUPLE: flash-scopes < server-state-manager ;
 
-C: <flash-scopes> flash-scopes
+: <flash-scopes> ( responder -- responder' )
+    flash-scopes new-server-state-manager ;
 
 SYMBOL: flash-scope
 
 : fget ( key -- value ) flash-scope get at ;
 
-M: flash-scopes call-responder*
+: get-flash-scope ( id -- flash-scope )
-    flash-id-key
+    dup [ flash-scope get-state ] when
-    request get request-params at
+    dup [ dup session>> session get id>> = [ drop f ] unless ] when ;
-    flash-scopes sget at flash-scope set
-    call-next-method ;
 
-M: flash-scopes init-session*
+: request-flash-scope ( request -- flash-scope )
-    H{ } clone flash-scopes sset
+    flash-id-key swap request-params at string>number get-flash-scope ;
+
+M: flash-scopes call-responder*
+    dup flash-scopes set
+    request get request-flash-scope flash-scope set
     call-next-method ;
 
 : make-flash-scope ( seq -- id )
-    [ dup get ] H{ } map>assoc flash-scopes sget set-at-unique
+    f <flash-scope>
-    session-changed ;
+        session get id>> >>session
+        swap [ dup get ] H{ } map>assoc >>namespace
+    [ flash-scopes get touch-state ] [ insert-tuple ] [ id>> ] tri ;
 
 : <flash-redirect> ( url seq -- response )
-    make-flash-scope
+    [ clone ] dip
-    [ clone ] dip flash-id-key set-query-param
+    make-flash-scope flash-id-key set-query-param
     <redirect> ;
 
 : restore-flash ( seq -- )
-    [ flash-scope get key? ] filter [ [ fget ] keep set ] each ;
+    flash-scope get dup [
+        namespace>>
+        [ '[ , key? ] filter ]
+        [ '[ [ , at ] keep set ] each ]
+        bi
+    ] [ 2drop ] if ;

extra/furnace/sessions/sessions-tests.factor

@@ -3,7 +3,7 @@ USING: tools.test http furnace.sessions
 furnace.actions http.server http.server.responses
 math namespaces kernel accessors
 prettyprint io.streams.string io.files splitting destructors
-sequences db db.sqlite continuations urls math.parser
+sequences db db.tuples db.sqlite continuations urls math.parser
 furnace ;
 
 : with-session
@@ -54,7 +54,7 @@ M: foo call-responder*
 "auth-test.db" temp-file sqlite-db [
 
     <request> init-request
-    init-sessions-table
+    session ensure-table
 
     [ ] [
         <foo> <sessions>

extra/furnace/sessions/sessions.factor

@@ -5,36 +5,23 @@ random accessors quotations hashtables sequences continuations
 fry calendar combinators destructors alarms
 db db.tuples db.types
 http http.server http.server.dispatchers http.server.filters
-html.elements furnace ;
+html.elements
+furnace furnace.cache ;
 IN: furnace.sessions
 
-TUPLE: session id expires uid namespace changed? ;
+TUPLE: session < server-state uid namespace changed? ;
 
 : <session> ( id -- session )
-    session new
+    session new-server-state ;
-        swap >>id ;
 
 session "SESSIONS"
 {
-    { "id" "ID" +random-id+ system-random-generator }
-    { "expires" "EXPIRES" TIMESTAMP +not-null+ }
     { "uid" "UID" { VARCHAR 255 } }
-    { "namespace" "NAMESPACE" FACTOR-BLOB }
+    { "namespace" "NAMESPACE" FACTOR-BLOB +not-null+ }
 } define-persistent
 
 : get-session ( id -- session )
-    dup [ <session> select-tuple ] when ;
+    dup [ session get-state ] when ;
-
-: init-sessions-table ( -- ) session ensure-table ;
-
-: start-expiring-sessions ( db seq -- )
-    '[
-        , , [
-            session new
-                -1.0/0.0 now [a,b] >>expires
-            delete-tuples
-        ] with-db
-    ] 5 minutes every drop ;
 
 GENERIC: init-session* ( responder -- )
 
@@ -47,9 +34,7 @@ M: filter-responder init-session* responder>> init-session* ;
 TUPLE: sessions < filter-responder timeout domain ;
 
 : <sessions> ( responder -- responder' )
-    sessions new
+    sessions new-server-state-manager ;
-        swap >>responder
-        20 minutes >>timeout ;
 
 : (session-changed) ( session -- )
     t >>changed? drop ;
@@ -78,11 +63,8 @@ TUPLE: sessions < filter-responder timeout domain ;
 : init-session ( session -- )
     session [ sessions get init-session* ] with-variable ;
 
-: cutoff-time ( -- time )
-    sessions get timeout>> from-now ;
-
 : touch-session ( session -- )
-    cutoff-time >>expires drop ;
+    sessions get touch-state ;
 
 : empty-session ( -- session )
     f <session>

extra/http/http-tests.factor

@@ -121,12 +121,12 @@ read-response-test-1' 1array [
 ] unit-test
 
 ! Live-fire exercise
-USING: http.server http.server.static furnace.sessions
+USING: http.server http.server.static furnace.sessions furnace.alloy
 furnace.actions furnace.auth.login furnace.db http.client
 io.server io.files io io.encodings.ascii
 accessors namespaces threads
 http.server.responses http.server.redirection
-http.server.dispatchers ;
+http.server.dispatchers db.tuples ;
 
 : add-quit-action
     <action>
@@ -138,7 +138,7 @@ http.server.dispatchers ;
 [ test-db drop delete-file ] ignore-errors
 
 test-db [
-    init-sessions-table
+    init-furnace-tables
 ] with-db
 
 [ ] [
@@ -269,7 +269,7 @@ SYMBOL: a
 ! Test flash scope
 [ "xyz" ] [
     H{ { "a" "xyz" } { "__u" "http://localhost:1237/" } } "session-id" get session-id-key associate assoc-union
-    "http://localhost:1237/" <post-request> "cookies" get >>cookies http-request nip test-a
+    "http://localhost:1237/" <post-request> "cookies" get >>cookies B http-request nip test-a
 ] unit-test
 
 [ 4 ] [ a get-global ] unit-test

extra/http/server/server.factor

@@ -90,13 +90,13 @@ LOG: httpd-hit NOTICE
 : dispatch-request ( request -- response )
     url>> path>> split-path main-responder get call-responder ;
 
-: prepare-request ( request -- request )
+: prepare-request ( request -- )
     [
         local-address get
         [ secure? "https" "http" ? >>protocol ]
         [ port>> '[ , or ] change-port ]
         bi
-    ] change-url ;
+    ] change-url drop ;
 
 : valid-request? ( request -- ? )
     url>> port>> local-address get port>> = ;

extra/persistent-vectors/persistent-vectors-tests.factor

@@ -24,7 +24,7 @@ random namespaces vectors math math.order ;
     [ t ] swap [ dup >persistent-vector sequence= ] curry unit-test
 ] each
 
-[ ] [ 10000 [ drop 16 random-bits ] PV{ } map-as "1" set ] unit-test
+[ ] [ 10000 [ 16 random-bits ] PV{ } replicate-as "1" set ] unit-test
 [ ] [ "1" get >vector "2" set ] unit-test
 
 [ t ] [

extra/webapps/blogs/blogs.factor

@@ -59,8 +59,6 @@ M: post entity-url
 
 : <post> ( id -- post ) \ post new swap >>id ;
 
-: init-posts-table ( -- ) \ post ensure-table ;
-
 TUPLE: comment < entity parent ;
 
 comment "COMMENTS" {
@@ -78,8 +76,6 @@ M: comment entity-url
         swap >>id
         swap >>parent ;
 
-: init-comments-table ( -- ) comment ensure-table ;
-
 : post ( id -- post )
     [ <post> select-tuple ] [ f <comment> select-tuples ] bi
     >>comments ;

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

@@ -2,9 +2,10 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel sequences assocs io.files io.sockets
 io.server
-namespaces db db.sqlite smtp
+namespaces db db.tuples db.sqlite smtp
 http.server
 http.server.dispatchers
+furnace.alloy
 furnace.db
 furnace.asides
 furnace.flash
@@ -25,24 +26,16 @@ IN: webapps.factor-website
 
 : init-factor-db ( -- )
     test-db [
-        init-users-table
+        init-furnace-tables
-        init-sessions-table
 
-        init-pastes-table
+        {
-        init-annotations-table
+            post comment
-
+            paste annotation
-        init-blog-table
+            blog posting
-        init-postings-table
+            todo
-
+            short-url
-        init-todo-table
+            article revision
-
+        } ensure-tables
-        init-articles-table
-        init-revisions-table
-
-        init-postings-table
-        init-comments-table
-
-        init-short-url-table
     ] with-db ;
 
 TUPLE: factor-website < dispatcher ;
@@ -63,8 +56,7 @@ TUPLE: factor-website < dispatcher ;
         allow-edit-profile
     <boilerplate>
         { factor-website "page" } >>template
-    <asides> <flash-scopes> <sessions>
+    test-db <alloy> ;
-    test-db <db-persistence> ;
 
 : init-factor-website ( -- )
     "factorcode.org" 25 <inet> smtp-server set-global
@@ -75,6 +67,6 @@ TUPLE: factor-website < dispatcher ;
     <factor-website> main-responder set-global ;
 
 : start-factor-website ( -- )
-    test-db start-expiring-sessions
+    test-db start-expiring
     test-db start-update-task
     8812 httpd ;

extra/webapps/pastebin/pastebin.factor

@@ -236,7 +236,3 @@ M: annotation entity-url
         <delete-annotation-action> "delete-annotation" add-responder
     <boilerplate>
         { pastebin "pastebin-common" } >>template ;
-
-: init-pastes-table ( -- ) \ paste ensure-table ;
-
-: init-annotations-table ( -- ) annotation ensure-table ;

extra/webapps/planet/planet.factor

@@ -49,10 +49,6 @@ posting "POSTINGS"
     { "date" "DATE" TIMESTAMP +not-null+ }
 } define-persistent
 
-: init-blog-table ( -- ) blog ensure-table ;
-
-: init-postings-table ( -- ) posting ensure-table ;
-
 : <blog> ( id -- todo )
     blog new
         swap >>id ;

extra/webapps/todo/todo.factor

@@ -28,8 +28,6 @@ todo "TODO"
     { "description" "DESCRIPTION" { VARCHAR 256 } }
 } define-persistent
 
-: init-todo-table ( -- ) todo ensure-table ;
-
 : <todo> ( id -- todo )
     todo new
         swap >>id

extra/webapps/wee-url/wee-url.factor

@@ -16,9 +16,6 @@ short-url "SHORT_URLS" {
     { "url" "URL" TEXT +not-null+ }
 } define-persistent
 
-: init-short-url-table ( -- )
-    short-url ensure-table ;
-
 : letter-bank ( -- seq )
     CHAR: a CHAR: z [a,b]
     CHAR: A CHAR: Z [a,b]

extra/webapps/wiki/wiki.factor

@@ -46,8 +46,6 @@ article "ARTICLES" {
 
 : <article> ( title -- article ) article new swap >>title ;
 
-: init-articles-table ( -- ) article ensure-table ;
-
 TUPLE: revision id title author date content ;
 
 revision "REVISIONS" {
@@ -71,8 +69,6 @@ M: revision feed-entry-url id>> revision-url ;
 : <revision> ( id -- revision )
     revision new swap >>id ;
 
-: init-revisions-table ( -- ) revision ensure-table ;
-
 : validate-title ( -- )
     { { "title" [ v-one-line ] } } validate-params ;