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

Merge branch 'master' of git://factorcode.org/git/factor

db4
Doug Coleman 2008-04-26 11:05:17 -05:00
parent 439c138aa5 14b78f348e
commit b8a6941811
23 changed files with 395 additions and 307 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
extra/assocs/lib/lib.factor
View File

@ -38,7 +38,7 @@ IN: assocs.lib
: insert ( value variable -- ) namespace insert-at ; : insert ( value variable -- ) namespace insert-at ;
: generate-key ( assoc -- str ) : generate-key ( assoc -- str )
>r 256 random-bits >hex r> >r 32 random-bits >hex r>
2dup key? [ nip generate-key ] [ drop ] if ; 2dup key? [ nip generate-key ] [ drop ] if ;
: set-at-unique ( value assoc -- key ) : set-at-unique ( value assoc -- key )

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

@ -1,6 +1,6 @@
USING: http tools.test multiline tuple-syntax USING: http tools.test multiline tuple-syntax
io.streams.string kernel arrays splitting sequences io.streams.string kernel arrays splitting sequences
assocs io.sockets ; assocs io.sockets db db.sqlite ;
IN: http.tests IN: http.tests
[ "hello%20world" ] [ "hello world" url-encode ] unit-test [ "hello%20world" ] [ "hello world" url-encode ] unit-test
@ -134,15 +134,22 @@ read-response-test-1' 1array [
! Live-fire exercise ! Live-fire exercise
USING: http.server http.server.static http.server.sessions USING: http.server http.server.static http.server.sessions
http.server.actions http.server.auth.login http.client http.server.sessions.storage.db http.server.actions
io.server io.files io accessors namespaces threads http.server.auth.login http.server.db http.client
io.encodings.ascii ; io.server io.files io io.encodings.ascii
accessors namespaces threads ;
: add-quit-action : add-quit-action
<action> <action>
[ stop-server "text/html" <content> [ "Goodbye" write ] >>body ] >>display [ stop-server "text/html" <content> [ "Goodbye" write ] >>body ] >>display
"quit" add-responder ; "quit" add-responder ;
: test-db "test.db" temp-file sqlite-db ;
test-db [
init-sessions-table
] with-db
[ ] [ [ ] [
[ [
<dispatcher> <dispatcher>
@ -187,11 +194,14 @@ io.encodings.ascii ;
<dispatcher> <dispatcher>
<action> <protected> <action> <protected>
<login> <login>
<url-sessions> "" add-responder <url-sessions>
sessions-in-db >>sessions
"" add-responder
add-quit-action add-quit-action
<dispatcher> <dispatcher>
<action> "a" add-main-responder <action> "a" add-main-responder
"d" add-responder "d" add-responder
test-db <db-persistence>
main-responder set main-responder set
[ 1237 httpd ] "HTTPD test" spawn drop [ 1237 httpd ] "HTTPD test" spawn drop
@ -214,9 +224,12 @@ io.encodings.ascii ;
[ [
<dispatcher> <dispatcher>
<action> [ "text/plain" <content> [ "Hi" write ] >>body ] >>display <action> [ "text/plain" <content> [ "Hi" write ] >>body ] >>display
<login> <url-sessions> <login>
<url-sessions>
sessions-in-db >>sessions
"" add-responder "" add-responder
add-quit-action add-quit-action
test-db <db-persistence>
main-responder set main-responder set
[ 1237 httpd ] "HTTPD test" spawn drop [ 1237 httpd ] "HTTPD test" spawn drop

14
extra/http/server/auth/login/login.factor
View File

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

3
extra/http/server/boilerplate/boilerplate.factor
View File

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

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

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

50
extra/http/server/flows/flows.factor Normal file
View File

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

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

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

229
extra/http/server/sessions/sessions-tests.factor
View File

@ -1,12 +1,14 @@
IN: http.server.sessions.tests IN: http.server.sessions.tests
USING: tools.test http http.server.sessions USING: tools.test http http.server.sessions
http.server.sessions.storage http.server.sessions.storage.assoc http.server.sessions.storage http.server.sessions.storage.db
http.server.actions http.server math namespaces kernel accessors http.server.actions http.server math namespaces kernel accessors
prettyprint io.streams.string splitting destructors sequences ; prettyprint io.streams.string io.files splitting destructors
sequences db db.sqlite continuations ;
[ H{ } ] [ H{ } add-session-id ] unit-test : with-session
[
: with-session \ session swap with-variable ; inline >r [ save-session-after ] [ \ session set ] bi r> call
] with-destructors ; inline
TUPLE: foo ; TUPLE: foo ;
@ -19,56 +21,6 @@ M: foo call-responder
"x" [ 1+ ] schange "x" [ 1+ ] schange
"text/html" <content> [ "x" sget pprint ] >>body ; "text/html" <content> [ "x" sget pprint ] >>body ;
[
"123" session-id set
H{ } clone session set
session-changed? off
[ H{ { "factorsessid" "123" } } ] [ H{ } add-session-id ] unit-test
[ ] [ 3 "x" sset ] unit-test
[ 9 ] [ "x" sget sq ] unit-test
[ ] [ "x" [ 1- ] schange ] unit-test
[ 4 ] [ "x" sget sq ] unit-test
[ t ] [ session-changed? get ] unit-test
] with-scope
[ t ] [ f <url-sessions> url-sessions? ] unit-test
[ t ] [ f <cookie-sessions> cookie-sessions? ] unit-test
[ ] [
<foo> <url-sessions>
<sessions-in-memory> >>sessions
"manager" set
] unit-test
[ { 5 0 } ] [
[
"manager" get begin-session drop
dup "manager" get sessions>> get-session [ 5 "a" sset ] with-session
dup "manager" get sessions>> get-session [ "a" sget , ] with-session
dup "manager" get sessions>> get-session [ "x" sget , ] with-session
"manager" get sessions>> get-session
"manager" get sessions>> delete-session
] { } make
] unit-test
[ ] [
<request>
"GET" >>method
request set
{ "etc" } "manager" get call-responder
response set
] unit-test
[ 307 ] [ response get code>> ] unit-test
[ ] [ response get "location" header "=" split1 nip "id" set ] unit-test
: url-responder-mock-test : url-responder-mock-test
[ [
<request> <request>
@ -76,34 +28,10 @@ M: foo call-responder
"id" get session-id-key set-query-param "id" get session-id-key set-query-param
"/" >>path "/" >>path
request set request set
{ } "manager" get call-responder { } session-manager get call-responder
[ write-response-body drop ] with-string-writer [ write-response-body drop ] with-string-writer
] with-destructors ; ] with-destructors ;
[ "1" ] [ url-responder-mock-test ] unit-test
[ "2" ] [ url-responder-mock-test ] unit-test
[ "3" ] [ url-responder-mock-test ] unit-test
[ "4" ] [ url-responder-mock-test ] unit-test
[ ] [
<foo> <cookie-sessions>
<sessions-in-memory> >>sessions
"manager" set
] unit-test
[
<request>
"GET" >>method
"/" >>path
request set
{ "etc" } "manager" get call-responder response set
[ "1" ] [ [ response get write-response-body drop ] with-string-writer ] unit-test
response get
] with-destructors
response set
[ ] [ response get cookies>> "cookies" set ] unit-test
: cookie-responder-mock-test : cookie-responder-mock-test
[ [
<request> <request>
@ -111,35 +39,138 @@ response set
"cookies" get >>cookies "cookies" get >>cookies
"/" >>path "/" >>path
request set request set
{ } "manager" get call-responder { } session-manager get call-responder
[ write-response-body drop ] with-string-writer [ write-response-body drop ] with-string-writer
] with-destructors ; ] with-destructors ;
[ "2" ] [ cookie-responder-mock-test ] unit-test
[ "3" ] [ cookie-responder-mock-test ] unit-test
[ "4" ] [ cookie-responder-mock-test ] unit-test
: <exiting-action> : <exiting-action>
<action> <action>
[ [
"text/plain" <content> exit-with "text/plain" <content> exit-with
] >>display ; ] >>display ;
[ [ "auth-test.db" temp-file sqlite-db delete-file ] ignore-errors
[ ] [
<request>
"GET" >>method
"id" get session-id-key set-query-param
"/" >>path
request set
[ "auth-test.db" temp-file sqlite-db [
{ } <exiting-action> <cookie-sessions>
call-responder init-sessions-table
] with-destructors response set
[
empty-session
123 >>id session set
session-changed? off
[ H{ { "factorsessid" 123 } } ] [ H{ } add-session-id ] unit-test
[ ] [ 3 "x" sset ] unit-test
[ 9 ] [ "x" sget sq ] unit-test
[ ] [ "x" [ 1- ] schange ] unit-test
[ 4 ] [ "x" sget sq ] unit-test
[ t ] [ session-changed? get ] unit-test
] with-scope
[ t ] [ f <url-sessions> url-sessions? ] unit-test
[ t ] [ f <cookie-sessions> cookie-sessions? ] unit-test
[ ] [
<foo> <url-sessions>
sessions-in-db >>sessions
session-manager set
] unit-test ] unit-test
[ "text/plain" ] [ response get "content-type" header ] unit-test [ t ] [
session-manager get begin-session id>>
session-manager get sessions>> get-session session?
] unit-test
[ f ] [ response get cookies>> empty? ] unit-test [ { 5 0 } ] [
] with-scope [
session-manager get begin-session
dup [ 5 "a" sset ] with-session
dup [ "a" sget , ] with-session
dup [ "x" sget , ] with-session
id>> session-manager get sessions>> delete-session
] { } make
] unit-test
[ 0 ] [
session-manager get begin-session id>>
session-manager get sessions>> get-session [ "x" sget ] with-session
] unit-test
[ { 5 0 } ] [
[
session-manager get begin-session id>>
dup session-manager get sessions>> get-session [ 5 "a" sset ] with-session
dup session-manager get sessions>> get-session [ "a" sget , ] with-session
dup session-manager get sessions>> get-session [ "x" sget , ] with-session
session-manager get sessions>> delete-session
] { } make
] unit-test
[ ] [
[
<request>
"GET" >>method
request set
{ "etc" } session-manager get call-responder
] with-destructors
response set
] unit-test
[ 307 ] [ response get code>> ] unit-test
[ ] [ response get "location" header "=" split1 nip "id" set ] unit-test
[ "1" ] [ url-responder-mock-test ] unit-test
[ "2" ] [ url-responder-mock-test ] unit-test
[ "3" ] [ url-responder-mock-test ] unit-test
[ "4" ] [ url-responder-mock-test ] unit-test
[ ] [
<foo> <cookie-sessions>
sessions-in-db >>sessions
session-manager set
] unit-test
[
<request>
"GET" >>method
"/" >>path
request set
{ "etc" } session-manager get call-responder response set
[ "1" ] [ [ response get write-response-body drop ] with-string-writer ] unit-test
response get
] with-destructors
response set
[ ] [ response get cookies>> "cookies" set ] unit-test
[ "2" ] [ cookie-responder-mock-test ] unit-test
[ "3" ] [ cookie-responder-mock-test ] unit-test
[ "4" ] [ cookie-responder-mock-test ] unit-test
[
[ ] [
<request>
"GET" >>method
"id" get session-id-key set-query-param
"/" >>path
request set
[
{ } <exiting-action> <cookie-sessions>
sessions-in-db >>sessions
call-responder
] with-destructors response set
] unit-test
[ "text/plain" ] [ response get "content-type" header ] unit-test
[ f ] [ response get cookies>> empty? ] unit-test
] with-scope
] with-db

128
extra/http/server/sessions/sessions.factor
View File

@ -1,78 +1,96 @@
! Copyright (C) 2008 Doug Coleman, Slava Pestov. ! Copyright (C) 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: assocs calendar kernel math.parser namespaces random USING: assocs kernel math.parser namespaces random
accessors http http.server accessors quotations hashtables sequences continuations
http.server.sessions.storage http.server.sessions.storage.assoc fry calendar destructors
quotations hashtables sequences fry html.elements symbols http
continuations destructors ; http.server
http.server.sessions.storage
http.server.sessions.storage.null
html.elements ;
IN: http.server.sessions IN: http.server.sessions
! ! ! ! ! ! TUPLE: session id expiry namespace changed? ;
! WARNING: this session manager is vulnerable to XSRF attacks
! ! ! ! ! ! : <session> ( id -- session )
session new
swap >>id ;
GENERIC: init-session* ( responder -- ) GENERIC: init-session* ( responder -- )
M: object init-session* drop ; M: object init-session* drop ;
M: dispatcher init-session* default>> init-session* ;
TUPLE: session-manager responder sessions ; TUPLE: session-manager responder sessions ;
: new-session-manager ( responder class -- responder' ) : new-session-manager ( responder class -- responder' )
new new
<sessions-in-memory> >>sessions null-sessions >>sessions
swap >>responder ; inline swap >>responder ; inline
SYMBOLS: session session-id session-changed? ; : (session-changed) ( session -- )
t >>changed? drop ;
: session-changed ( -- )
session get (session-changed) ;
: sget ( key -- value ) : sget ( key -- value )
session get at ; session get namespace>> at ;
: sset ( value key -- ) : sset ( value key -- )
session get set-at session get
session-changed? on ; [ namespace>> set-at ] [ (session-changed) ] bi ;
: schange ( key quot -- ) : schange ( key quot -- )
session get swap change-at session get
session-changed? on ; inline [ namespace>> swap change-at ] keep
(session-changed) ; inline
: sessions session-manager get sessions>> ; : sessions session-manager get sessions>> ;
: managed-responder session-manager get responder>> ; : managed-responder session-manager get responder>> ;
: init-session ( managed -- session ) : init-session ( session managed -- )
H{ } clone [ session [ init-session* ] with-variable ] keep ; >r session r> '[ , init-session* ] with-variable ;
: begin-session ( responder -- id session ) : timeout 20 minutes ;
[ responder>> init-session ] [ sessions>> ] bi
[ new-session ] [ drop ] 2bi ; : cutoff-time ( -- time )
now timeout time+ timestamp>millis ;
: touch-session ( session -- )
cutoff-time >>expiry drop ;
: empty-session ( -- session )
f <session>
H{ } clone >>namespace
dup touch-session ;
: begin-session ( responder -- session )
>r empty-session r>
[ responder>> init-session ]
[ sessions>> new-session ]
[ drop ]
2tri ;
! Destructor ! Destructor
TUPLE: session-saver id session ; TUPLE: session-saver session ;
C: <session-saver> session-saver C: <session-saver> session-saver
M: session-saver dispose M: session-saver dispose
session-changed? get [ session>> dup changed?>> [
[ session>> ] [ id>> ] bi [ touch-session ] [ sessions update-session ] bi
sessions update-session
] [ drop ] if ; ] [ drop ] if ;
: save-session-after ( id session -- ) : save-session-after ( session -- )
<session-saver> add-always-destructor ; <session-saver> add-always-destructor ;
: call-responder/session ( path responder id session -- response ) : call-responder/session ( path responder session -- response )
[ save-session-after ] [ save-session-after ] [ session set ] bi
[ [ session-id set ] [ session set ] bi* ] 2bi
[ session-manager set ] [ responder>> call-responder ] bi ; [ session-manager set ] [ responder>> call-responder ] bi ;
TUPLE: null-sessions < session-manager ;
: <null-sessions>
null-sessions new-session-manager ;
M: null-sessions call-responder ( path responder -- response )
H{ } clone f call-responder/session ;
TUPLE: url-sessions < session-manager ; TUPLE: url-sessions < session-manager ;
: <url-sessions> ( responder -- responder' ) : <url-sessions> ( responder -- responder' )
@ -80,42 +98,42 @@ TUPLE: url-sessions < session-manager ;
: session-id-key "factorsessid" ; : session-id-key "factorsessid" ;
: current-url-session ( responder -- id/f session/f ) : current-url-session ( responder -- session/f )
[ request-params session-id-key swap at ] [ sessions>> ] bi* >r request-params session-id-key swap at string>number
[ drop ] [ get-session ] 2bi ; r> sessions>> get-session ;
: add-session-id ( query -- query' ) : add-session-id ( query -- query' )
session-id get [ session-id-key associate assoc-union ] when* ; session get [ id>> session-id-key associate assoc-union ] when* ;
: session-form-field ( -- ) : session-form-field ( -- )
<input <input
"hidden" =type "hidden" =type
session-id-key =id
session-id-key =name session-id-key =name
session-id get =value session get id>> number>string =value
input/> ; input/> ;
: new-url-session ( responder -- response ) : new-url-session ( path responder -- response )
[ f ] [ begin-session drop session-id-key associate ] bi* [ drop f ] [ begin-session id>> session-id-key associate ] bi*
<temporary-redirect> ; <temporary-redirect> ;
M: url-sessions call-responder ( path responder -- response ) 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 dup [ dup current-url-session [
call-responder/session call-responder/session
] [ ] [
2drop nip new-url-session new-url-session
] if ; ] if* ;
TUPLE: cookie-sessions < session-manager ; TUPLE: cookie-sessions < session-manager ;
: <cookie-sessions> ( responder -- responder' ) : <cookie-sessions> ( responder -- responder' )
cookie-sessions new-session-manager ; cookie-sessions new-session-manager ;
: current-cookie-session ( responder -- id namespace/f ) : current-cookie-session ( responder -- session/f )
request get session-id-key get-cookie dup request get session-id-key get-cookie dup
[ value>> dup rot sessions>> get-session ] [ 2drop f f ] if ; [ value>> string>number swap sessions>> get-session ]
[ 2drop f ] if ;
: <session-cookie> ( id -- cookie ) : <session-cookie> ( id -- cookie )
session-id-key <cookie> ; session-id-key <cookie> ;
@ -123,12 +141,12 @@ TUPLE: cookie-sessions < session-manager ;
: call-responder/new-session ( path responder -- response ) : call-responder/new-session ( path responder -- response )
dup begin-session dup begin-session
[ call-responder/session ] [ call-responder/session ]
[ drop <session-cookie> ] 2bi [ id>> number>string <session-cookie> ] bi
put-cookie ; put-cookie ;
M: cookie-sessions call-responder ( path responder -- response ) M: cookie-sessions call-responder ( path responder -- response )
dup current-cookie-session dup [ dup current-cookie-session [
call-responder/session call-responder/session
] [ ] [
2drop call-responder/new-session call-responder/new-session
] if ; ] if* ;

37
extra/http/server/sessions/storage/assoc/assoc.factor
View File

@ -1,37 +0,0 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs assocs.lib accessors http.server.sessions.storage
alarms kernel fry http.server ;
IN: http.server.sessions.storage.assoc
TUPLE: sessions-in-memory sessions alarms ;
: <sessions-in-memory> ( -- storage )
H{ } clone H{ } clone sessions-in-memory boa ;
: cancel-session-timeout ( id storage -- )
alarms>> at [ cancel-alarm ] when* ;
: touch-session ( id storage -- )
[ cancel-session-timeout ]
[ '[ , , delete-session ] timeout later ]
[ alarms>> set-at ]
2tri ;
M: sessions-in-memory get-session ( id storage -- namespace )
[ sessions>> at ] [ touch-session ] 2bi ;
M: sessions-in-memory update-session ( namespace id storage -- )
[ sessions>> set-at ]
[ touch-session ]
2bi ;
M: sessions-in-memory delete-session ( id storage -- )
[ sessions>> delete-at ]
[ cancel-session-timeout ]
2bi ;
M: sessions-in-memory new-session ( namespace storage -- id )
[ sessions>> set-at-unique ]
[ [ touch-session ] [ drop ] 2bi ]
bi ;

24
extra/http/server/sessions/storage/db/db-tests.factor
View File

@ -1,24 +0,0 @@
IN: http.server.sessions.storage.db
USING: http.server.sessions.storage
http.server.sessions.storage.db namespaces io.files
db.sqlite db accessors math tools.test kernel assocs
sequences ;
sessions-in-db "storage" set
"auth-test.db" temp-file sqlite-db [
[ ] [ init-sessions-table ] unit-test
[ f ] [ H{ } "storage" get new-session empty? ] unit-test
H{ } "storage" get new-session "id" set
"id" get "storage" get get-session "session" set
"a" "b" "session" get set-at
"session" get "id" get "storage" get update-session
[ H{ { "b" "a" } } ] [
"id" get "storage" get get-session
] unit-test
] with-db

48
extra/http/server/sessions/storage/db/db.factor
View File

@ -1,46 +1,40 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: assocs accessors http.server.sessions.storage USING: assocs accessors kernel http.server.sessions.storage
alarms kernel http.server db.tuples db.types math.parser http.server.sessions http.server db db.tuples db.types math.parser
classes.singleton ; math.intervals fry random calendar sequences alarms ;
IN: http.server.sessions.storage.db IN: http.server.sessions.storage.db
SINGLETON: sessions-in-db SINGLETON: sessions-in-db
TUPLE: session id namespace ;
session "SESSIONS" session "SESSIONS"
{ {
! { "id" "ID" +random-id+ system-random-generator }
{ "id" "ID" INTEGER +native-id+ } { "id" "ID" INTEGER +native-id+ }
{ "expiry" "EXPIRY" BIG-INTEGER +not-null+ }
{ "namespace" "NAMESPACE" FACTOR-BLOB } { "namespace" "NAMESPACE" FACTOR-BLOB }
} define-persistent } define-persistent
: init-sessions-table session ensure-table ; : init-sessions-table session ensure-table ;
: <session> ( id -- session ) M: sessions-in-db get-session ( id storage -- session/f )
session new drop dup [ <session> select-tuple ] when ;
swap dup [ string>number ] when >>id ;
M: sessions-in-db get-session ( id storage -- namespace/f ) M: sessions-in-db update-session ( session storage -- )
drop drop update-tuple ;
dup [
<session>
select-tuple dup [ namespace>> ] when
] when ;
M: sessions-in-db update-session ( namespace id storage -- )
drop
<session>
swap >>namespace
update-tuple ;
M: sessions-in-db delete-session ( id storage -- ) M: sessions-in-db delete-session ( id storage -- )
drop drop <session> delete-tuple ;
<session>
delete-tuple ;
M: sessions-in-db new-session ( namespace storage -- id ) M: sessions-in-db new-session ( session storage -- )
drop drop insert-tuple ;
: expired-sessions ( -- session )
f <session> f <session>
swap >>namespace USE: math now timestamp>millis [ 60 60 * 1000 * - ] keep [a,b] >>expiry
[ insert-tuple ] [ id>> number>string ] bi ; select-tuples ;
: start-expiring-sessions ( db seq -- )
'[
, , [ expired-sessions [ delete-tuple ] each ] with-db
] 5 minutes every drop ;

16
extra/http/server/sessions/storage/null/null.factor Normal file
View File

@ -0,0 +1,16 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel http.server.sessions.storage ;
IN: http.server.sessions.storage.null
SINGLETON: null-sessions
: null-sessions-error "No session storage installed" throw ;
M: null-sessions get-session null-sessions-error ;
M: null-sessions update-session null-sessions-error ;
M: null-sessions delete-session null-sessions-error ;
M: null-sessions new-session null-sessions-error ;

8
extra/http/server/sessions/storage/storage.factor
View File

@ -3,12 +3,10 @@
USING: calendar ; USING: calendar ;
IN: http.server.sessions.storage IN: http.server.sessions.storage
: timeout 20 minutes ; GENERIC: get-session ( id storage -- session )
GENERIC: get-session ( id storage -- namespace ) GENERIC: update-session ( session storage -- )
GENERIC: update-session ( namespace id storage -- )
GENERIC: delete-session ( id storage -- ) GENERIC: delete-session ( id storage -- )
GENERIC: new-session ( namespace storage -- id ) GENERIC: new-session ( session storage -- )

34
extra/http/server/templating/chloe/chloe.factor
View File

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

1
extra/serialize/serialize.factor
View File

@ -230,6 +230,7 @@ SYMBOL: deserialized
: deserialize-word ( -- word ) : deserialize-word ( -- word )
(deserialize) (deserialize) 2dup lookup (deserialize) (deserialize) 2dup lookup
dup [ 2nip ] [ dup [ 2nip ] [
drop
"Unknown word: " -rot "Unknown word: " -rot
2array unparse append throw 2array unparse append throw
] if ; ] if ;

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

@ -4,6 +4,7 @@ USING: accessors kernel sequences assocs io.files io.sockets
namespaces db db.sqlite smtp namespaces db db.sqlite smtp
http.server http.server
http.server.db http.server.db
http.server.flows
http.server.sessions http.server.sessions
http.server.auth.login http.server.auth.login
http.server.auth.providers.db http.server.auth.providers.db
@ -20,27 +21,6 @@ IN: webapps.factor-website
: factor-template ( path -- template ) : factor-template ( path -- template )
"resource:extra/webapps/factor-website/" swap ".xml" 3append <chloe> ; "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 ( -- ) : init-factor-db ( -- )
test-db [ test-db [
init-users-table init-users-table
@ -56,9 +36,20 @@ IN: webapps.factor-website
: <factor-website> ( -- responder ) : <factor-website> ( -- responder )
<dispatcher> <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 ( -- ) : init-factor-website ( -- )
"factorcode.org" 25 <inet> smtp-server set-global "factorcode.org" 25 <inet> smtp-server set-global
@ -66,6 +57,9 @@ IN: webapps.factor-website
init-factor-db 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 ;

2
extra/webapps/pastebin/pastebin.xml
View File

@ -13,7 +13,7 @@
<t:comment> <t:comment>
<t:if code="http.server.auth.login:allow-edit-profile?"> <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:if>
<t:form action="$login/logout" class="inline"> <t:form action="$login/logout" class="inline">

2
extra/webapps/planet/entry-summary.xml
View File

@ -4,7 +4,7 @@
<p class="news"> <p class="news">
<strong><t:view component="title" /></strong> <br/> <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> </p>
</t:chloe> </t:chloe>

4
extra/webapps/planet/entry.xml
View File

@ -3,7 +3,7 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0"> <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<h2 class="posting-title"> <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> </h2>
<p class="posting-body"> <p class="posting-body">
@ -11,7 +11,7 @@
</p> </p>
<p class="posting-date"> <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> </p>
</t:chloe> </t:chloe>

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

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences sorting locals math math.order USING: kernel accessors sequences sorting locals math math.order
calendar alarms logging concurrency.combinators namespaces calendar alarms logging concurrency.combinators namespaces
sequences.lib db.types db.tuples db sequences.lib db.types db.tuples db fry
rss xml.writer rss xml.writer
http.server http.server
http.server.crud http.server.crud
@ -167,5 +167,7 @@ blog "BLOGS"
<boilerplate> <boilerplate>
"planet" planet-template >>template ; "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 ;

2
extra/webapps/planet/planet.xml
View File

@ -14,7 +14,7 @@
<t:comment> <t:comment>
<t:if code="http.server.auth.login:allow-edit-profile?"> <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:if>
<t:form action="$login/logout" class="inline"> <t:form action="$login/logout" class="inline">

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

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