steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Slava Pestov 2008-06-13 20:54:52 -05:00
parent a949c10387
commit e7b786ecfa
18 changed files with 171 additions and 117 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
extra/furnace/alloy/alloy.factor Normal file
View File

@ -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 ;

64
extra/furnace/asides/asides.factor
View File

@ -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 ;
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 ;
@ -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
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 -- )

2
extra/furnace/auth/providers/db/db-tests.factor
View File

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

2
extra/furnace/auth/providers/db/db.factor
View File

@ -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

36
extra/furnace/cache/cache.factor vendored Normal file
View File

@ -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 ;

53
extra/furnace/flash/flash.factor
View File

@ -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*
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 ;
M: flash-scopes init-session*
H{ } clone flash-scopes sset
: request-flash-scope ( request -- flash-scope )
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
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 ;

4
extra/furnace/sessions/sessions-tests.factor
View File

@ -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>

34
extra/furnace/sessions/sessions.factor
View File

@ -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
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 -- )
@ -47,9 +34,7 @@ M: filter-responder init-session* responder>> init-session* ;
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 ;
@ -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>

8
extra/http/http-tests.factor
View File

@ -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

4
extra/http/server/server.factor
View File

@ -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>> = ;

2
extra/persistent-vectors/persistent-vectors-tests.factor
View File

@ -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 ] [

4
extra/webapps/blogs/blogs.factor
View File

@ -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 ;

34
extra/webapps/factor-website/factor-website.factor
View File

@ -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-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 ;
@ -63,8 +56,7 @@ 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
@ -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 ;

4
extra/webapps/pastebin/pastebin.factor
View File

@ -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 ;

4
extra/webapps/planet/planet.factor
View File

@ -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 ;

2
extra/webapps/todo/todo.factor
View File

@ -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

3
extra/webapps/wee-url/wee-url.factor
View File

@ -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]

4
extra/webapps/wiki/wiki.factor
View File

@ -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 ;