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 ;
: generate-key ( assoc -- str )
>r 256 random-bits >hex r>
>r 32 random-bits >hex r>
2dup key? [ nip generate-key ] [ drop ] if ;
: 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
io.streams.string kernel arrays splitting sequences
assocs io.sockets ;
assocs io.sockets db db.sqlite ;
IN: http.tests
[ "hello%20world" ] [ "hello world" url-encode ] unit-test
@ -134,15 +134,22 @@ read-response-test-1' 1array [
! Live-fire exercise
USING: http.server http.server.static http.server.sessions
http.server.actions http.server.auth.login http.client
io.server io.files io accessors namespaces threads
io.encodings.ascii ;
http.server.sessions.storage.db http.server.actions
http.server.auth.login http.server.db http.client
io.server io.files io io.encodings.ascii
accessors namespaces threads ;
: add-quit-action
<action>
[ stop-server "text/html" <content> [ "Goodbye" write ] >>body ] >>display
"quit" add-responder ;
: test-db "test.db" temp-file sqlite-db ;
test-db [
init-sessions-table
] with-db
[ ] [
[
<dispatcher>
@ -187,11 +194,14 @@ io.encodings.ascii ;
<dispatcher>
<action> <protected>
<login>
<url-sessions> "" add-responder
<url-sessions>
sessions-in-db >>sessions
"" add-responder
add-quit-action
<dispatcher>
<action> "a" add-main-responder
"d" add-responder
test-db <db-persistence>
main-responder set
[ 1237 httpd ] "HTTPD test" spawn drop
@ -214,9 +224,12 @@ io.encodings.ascii ;
[
<dispatcher>
<action> [ "text/plain" <content> [ "Hi" write ] >>body ] >>display
<login> <url-sessions>
<login>
<url-sessions>
sessions-in-db >>sessions
"" add-responder
add-quit-action
test-db <db-persistence>
main-responder set
[ 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.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>
f post-login-url sset ;
"$login" end-flow ;
:: <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

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

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

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

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

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

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

@ -1,12 +1,14 @@
IN: http.server.sessions.tests
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
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 \ session swap with-variable ; inline
: with-session
[
>r [ save-session-after ] [ \ session set ] bi r> call
] with-destructors ; inline
TUPLE: foo ;
@ -19,12 +21,46 @@ M: foo call-responder
"x" [ 1+ ] schange
"text/html" <content> [ "x" sget pprint ] >>body ;
: url-responder-mock-test
[
"123" session-id set
H{ } clone session set
<request>
"GET" >>method
"id" get session-id-key set-query-param
"/" >>path
request set
{ } session-manager get call-responder
[ write-response-body drop ] with-string-writer
] with-destructors ;
: cookie-responder-mock-test
[
<request>
"GET" >>method
"cookies" get >>cookies
"/" >>path
request set
{ } session-manager get call-responder
[ write-response-body drop ] with-string-writer
] with-destructors ;
: <exiting-action>
<action>
[
"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
session-changed? off
[ H{ { "factorsessid" "123" } } ] [ H{ } add-session-id ] unit-test
[ H{ { "factorsessid" 123 } } ] [ H{ } add-session-id ] unit-test
[ ] [ 3 "x" sset ] unit-test
@ -42,26 +78,47 @@ M: foo call-responder
[ ] [
<foo> <url-sessions>
<sessions-in-memory> >>sessions
"manager" set
sessions-in-db >>sessions
session-manager set
] unit-test
[ t ] [
session-manager get begin-session id>>
session-manager get sessions>> get-session session?
] 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
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" } "manager" get call-responder
{ "etc" } session-manager get call-responder
] with-destructors
response set
] unit-test
@ -69,17 +126,6 @@ M: foo call-responder
[ ] [ response get "location" header "=" split1 nip "id" set ] unit-test
: url-responder-mock-test
[
<request>
"GET" >>method
"id" get session-id-key set-query-param
"/" >>path
request set
{ } "manager" get call-responder
[ write-response-body drop ] with-string-writer
] with-destructors ;
[ "1" ] [ url-responder-mock-test ] unit-test
[ "2" ] [ url-responder-mock-test ] unit-test
[ "3" ] [ url-responder-mock-test ] unit-test
@ -87,8 +133,8 @@ M: foo call-responder
[ ] [
<foo> <cookie-sessions>
<sessions-in-memory> >>sessions
"manager" set
sessions-in-db >>sessions
session-manager set
] unit-test
[
@ -96,7 +142,7 @@ M: foo call-responder
"GET" >>method
"/" >>path
request set
{ "etc" } "manager" get call-responder response 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
@ -104,27 +150,10 @@ response set
[ ] [ response get cookies>> "cookies" set ] unit-test
: cookie-responder-mock-test
[
<request>
"GET" >>method
"cookies" get >>cookies
"/" >>path
request set
{ } "manager" get call-responder
[ write-response-body drop ] with-string-writer
] 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>
<action>
[
"text/plain" <content> exit-with
] >>display ;
[
[ ] [
<request>
@ -135,6 +164,7 @@ response set
[
{ } <exiting-action> <cookie-sessions>
sessions-in-db >>sessions
call-responder
] with-destructors response set
] unit-test
@ -143,3 +173,4 @@ response set
[ 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.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs calendar kernel math.parser namespaces random
accessors http http.server
http.server.sessions.storage http.server.sessions.storage.assoc
quotations hashtables sequences fry html.elements symbols
continuations destructors ;
USING: assocs kernel math.parser namespaces random
accessors quotations hashtables sequences continuations
fry calendar destructors
http
http.server
http.server.sessions.storage
http.server.sessions.storage.null
html.elements ;
IN: http.server.sessions
! ! ! ! ! !
! WARNING: this session manager is vulnerable to XSRF attacks
! ! ! ! ! !
TUPLE: session id expiry namespace changed? ;
: <session> ( id -- session )
session new
swap >>id ;
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' )
new
<sessions-in-memory> >>sessions
null-sessions >>sessions
swap >>responder ; inline
SYMBOLS: session session-id session-changed? ;
: (session-changed) ( session -- )
t >>changed? drop ;
: session-changed ( -- )
session get (session-changed) ;
: sget ( key -- value )
session get at ;
session get namespace>> at ;
: sset ( value key -- )
session get set-at
session-changed? on ;
session get
[ namespace>> set-at ] [ (session-changed) ] bi ;
: schange ( key quot -- )
session get swap change-at
session-changed? on ; inline
session get
[ namespace>> swap change-at ] keep
(session-changed) ; inline
: sessions session-manager get sessions>> ;
: managed-responder session-manager get responder>> ;
: init-session ( managed -- session )
H{ } clone [ session [ init-session* ] with-variable ] keep ;
: init-session ( session managed -- )
>r session r> '[ , init-session* ] with-variable ;
: begin-session ( responder -- id session )
[ responder>> init-session ] [ sessions>> ] bi
[ new-session ] [ drop ] 2bi ;
: timeout 20 minutes ;
: 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
TUPLE: session-saver id session ;
TUPLE: session-saver session ;
C: <session-saver> session-saver
M: session-saver dispose
session-changed? get [
[ session>> ] [ id>> ] bi
sessions update-session
session>> dup changed?>> [
[ touch-session ] [ sessions update-session ] bi
] [ drop ] if ;
: save-session-after ( id session -- )
: save-session-after ( session -- )
<session-saver> add-always-destructor ;
: call-responder/session ( path responder id session -- response )
[ save-session-after ]
[ [ session-id set ] [ session set ] bi* ] 2bi
: call-responder/session ( path responder session -- response )
[ save-session-after ] [ session set ] 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 ;
: <url-sessions> ( responder -- responder' )
@ -80,42 +98,42 @@ TUPLE: url-sessions < session-manager ;
: session-id-key "factorsessid" ;
: current-url-session ( responder -- id/f session/f )
[ request-params session-id-key swap at ] [ sessions>> ] bi*
[ drop ] [ get-session ] 2bi ;
: current-url-session ( responder -- session/f )
>r request-params session-id-key swap at string>number
r> sessions>> get-session ;
: 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 ( -- )
<input
"hidden" =type
session-id-key =id
session-id-key =name
session-id get =value
session get id>> number>string =value
input/> ;
: new-url-session ( responder -- response )
[ f ] [ begin-session drop session-id-key associate ] bi*
: new-url-session ( path responder -- response )
[ drop f ] [ begin-session id>> session-id-key associate ] bi*
<temporary-redirect> ;
M: url-sessions call-responder ( path responder -- response )
[ add-session-id ] link-hook set
[ session-form-field ] form-hook set
dup current-url-session dup [
[ add-session-id ] add-link-hook
[ session-form-field ] add-form-hook
dup current-url-session [
call-responder/session
] [
2drop nip new-url-session
] if ;
new-url-session
] if* ;
TUPLE: cookie-sessions < session-manager ;
: <cookie-sessions> ( responder -- responder' )
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
[ 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-id-key <cookie> ;
@ -123,12 +141,12 @@ TUPLE: cookie-sessions < session-manager ;
: call-responder/new-session ( path responder -- response )
dup begin-session
[ call-responder/session ]
[ drop <session-cookie> ] 2bi
[ id>> number>string <session-cookie> ] bi
put-cookie ;
M: cookie-sessions call-responder ( path responder -- response )
dup current-cookie-session dup [
dup current-cookie-session [
call-responder/session
] [
2drop call-responder/new-session
] if ;
call-responder/new-session
] 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.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs accessors http.server.sessions.storage
alarms kernel http.server db.tuples db.types math.parser
classes.singleton ;
USING: assocs accessors kernel http.server.sessions.storage
http.server.sessions http.server db db.tuples db.types math.parser
math.intervals fry random calendar sequences alarms ;
IN: http.server.sessions.storage.db
SINGLETON: sessions-in-db
TUPLE: session id namespace ;
session "SESSIONS"
{
! { "id" "ID" +random-id+ system-random-generator }
{ "id" "ID" INTEGER +native-id+ }
{ "expiry" "EXPIRY" BIG-INTEGER +not-null+ }
{ "namespace" "NAMESPACE" FACTOR-BLOB }
} define-persistent
: init-sessions-table session ensure-table ;
: <session> ( id -- session )
session new
swap dup [ string>number ] when >>id ;
M: sessions-in-db get-session ( id storage -- session/f )
drop dup [ <session> select-tuple ] when ;
M: sessions-in-db get-session ( id storage -- namespace/f )
drop
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 update-session ( session storage -- )
drop update-tuple ;
M: sessions-in-db delete-session ( id storage -- )
drop
<session>
delete-tuple ;
drop <session> delete-tuple ;
M: sessions-in-db new-session ( namespace storage -- id )
drop
M: sessions-in-db new-session ( session storage -- )
drop insert-tuple ;
: expired-sessions ( -- session )
f <session>
swap >>namespace
[ insert-tuple ] [ id>> number>string ] bi ;
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 ;

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 ;
IN: http.server.sessions.storage
: timeout 20 minutes ;
GENERIC: get-session ( id storage -- session )
GENERIC: get-session ( id storage -- namespace )
GENERIC: update-session ( namespace id storage -- )
GENERIC: update-session ( session storage -- )
GENERIC: delete-session ( id storage -- )
GENERIC: new-session ( namespace storage -- id )
GENERIC: new-session ( session storage -- )

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

1
extra/serialize/serialize.factor
View File

@ -230,6 +230,7 @@ SYMBOL: deserialized
: deserialize-word ( -- word )
(deserialize) (deserialize) 2dup lookup
dup [ 2nip ] [
drop
"Unknown word: " -rot
2array unparse append throw
] 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
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
<pastebin-app> "pastebin" add-responder
<planet-app> "planet" add-responder ;
<todo-list> "todo" add-responder
<pastebin> "pastebin" 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 ;

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

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

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

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

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

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

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

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences sorting locals math math.order
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 -- )
[ update-cached-postings ] curry 10 minutes every drop ;
: start-update-task ( planet db seq -- )
'[
, , , [ update-cached-postings ] with-db
] 10 minutes every drop ;

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

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

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

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