--- /dev/null
+! 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 ;
! 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 ;
+html.elements html.templates.chloe.syntax db.types db.tuples
+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
- [ url>> ] [ post-data>> ] [ method>> ] tri 3array
- asides sget set-at-unique
- session-changed ;
+ f <aside>
+ session get id>> >>session
+ request get
+ [ 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
- swap >>url
+ over post-data>> >>post-data
+ 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 [
- first3 {
- { "GET" [ drop <redirect> ] }
- { "HEAD" [ drop <redirect> ] }
+ aside get-state [
+ dup method>> {
+ { "GET" [ url>> <redirect> ] }
+ { "HEAD" [ url>> <redirect> ] }
{ "POST" [ end-aside-post ] }
} case
] [ <redirect> ] ?if ;
: 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
- call-next-method ;
-
-M: asides init-session*
- H{ } clone asides sset
+ request get request-aside-id aside-id set
call-next-method ;
M: asides link-attr ( tag -- )
\r
"auth-test.db" temp-file sqlite-db [\r
\r
- init-users-table\r
+ user ensure-table\r
\r
[ t ] [\r
"slava" <user>\r
{ "deleted" "DELETED" INTEGER +not-null+ }
} define-persistent
-: init-users-table ( -- ) user ensure-table ;
-
SINGLETON: users-in-db
M: users-in-db get-user
--- /dev/null
+! 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 ;
! 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*
- flash-id-key
- request get request-params at
- flash-scopes sget at flash-scope set
- call-next-method ;
+: get-flash-scope ( id -- flash-scope )
+ dup [ flash-scope get-state ] when
+ dup [ dup session>> session get id>> = [ drop f ] unless ] when ;
+
+: request-flash-scope ( request -- flash-scope )
+ flash-id-key swap request-params at string>number get-flash-scope ;
-M: flash-scopes init-session*
- H{ } clone flash-scopes sset
+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
- session-changed ;
+ f <flash-scope>
+ 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 flash-id-key set-query-param
+ [ clone ] dip
+ 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 ;
furnace.actions http.server http.server.responses\r
math namespaces kernel accessors\r
prettyprint io.streams.string io.files splitting destructors\r
-sequences db db.sqlite continuations urls math.parser\r
+sequences db db.tuples db.sqlite continuations urls math.parser\r
furnace ;\r
\r
: with-session\r
"auth-test.db" temp-file sqlite-db [\r
\r
<request> init-request\r
- init-sessions-table\r
+ session ensure-table\r
\r
[ ] [\r
<foo> <sessions>\r
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
- swap >>id ;
+ session new-server-state ;
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 ;
-
-: 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 ;
+ dup [ session get-state ] when ;
GENERIC: init-session* ( responder -- )
TUPLE: sessions < filter-responder timeout domain ;
: <sessions> ( responder -- responder' )
- sessions new
- swap >>responder
- 20 minutes >>timeout ;
+ sessions new-server-state-manager ;
: (session-changed) ( session -- )
t >>changed? drop ;
: 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>
] 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>
[ test-db drop delete-file ] ignore-errors
test-db [
- init-sessions-table
+ init-furnace-tables
] with-db
[ ] [
! 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
: 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>> = ;
[ 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 ] [
: <post> ( id -- post ) \ post new swap >>id ;
-: init-posts-table ( -- ) \ post ensure-table ;
-
TUPLE: comment < entity parent ;
comment "COMMENTS" {
swap >>id
swap >>parent ;
-: init-comments-table ( -- ) comment ensure-table ;
-
: post ( id -- post )
[ <post> select-tuple ] [ f <comment> select-tuples ] bi
>>comments ;
! 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
: init-factor-db ( -- )
test-db [
- init-users-table
- init-sessions-table
+ init-furnace-tables
- init-pastes-table
- init-annotations-table
-
- init-blog-table
- init-postings-table
-
- init-todo-table
-
- init-articles-table
- init-revisions-table
-
- init-postings-table
- init-comments-table
-
- init-short-url-table
+ {
+ post comment
+ paste annotation
+ blog posting
+ todo
+ short-url
+ article revision
+ } ensure-tables
] with-db ;
TUPLE: factor-website < dispatcher ;
allow-edit-profile
<boilerplate>
{ factor-website "page" } >>template
- <asides> <flash-scopes> <sessions>
- test-db <db-persistence> ;
+ test-db <alloy> ;
: init-factor-website ( -- )
"factorcode.org" 25 <inet> smtp-server set-global
<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 ;
<delete-annotation-action> "delete-annotation" add-responder
<boilerplate>
{ pastebin "pastebin-common" } >>template ;
-
-: init-pastes-table ( -- ) \ paste ensure-table ;
-
-: init-annotations-table ( -- ) annotation ensure-table ;
{ "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 ;
{ "description" "DESCRIPTION" { VARCHAR 256 } }
} define-persistent
-: init-todo-table ( -- ) todo ensure-table ;
-
: <todo> ( id -- todo )
todo new
swap >>id
{ "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]
: <article> ( title -- article ) article new swap >>title ;
-: init-articles-table ( -- ) article ensure-table ;
-
TUPLE: revision id title author date content ;
revision "REVISIONS" {
: <revision> ( id -- revision )
revision new swap >>id ;
-: init-revisions-table ( -- ) revision ensure-table ;
-
: validate-title ( -- )
{ { "title" [ v-one-line ] } } validate-params ;