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

Implement flash scopes, improved validation and login page, improved http-post

db4
Slava Pestov 2008-06-04 19:54:05 -05:00
parent ab5843d831
commit 9861146d8d
34 changed files with 486 additions and 254 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

92
extra/furnace/actions/actions.factor
View File

@ -2,13 +2,15 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors sequences kernel assocs combinators
validators http hashtables namespaces fry continuations locals
io arrays math boxes
io arrays math boxes splitting urls
xml.entities
http.server
http.server.responses
furnace
furnace.flash
html.elements
html.components
html.components
html.templates.chloe
html.templates.chloe.syntax ;
IN: furnace.actions
@ -39,48 +41,68 @@ TUPLE: action rest-param init display validate submit ;
: <action> ( -- action )
action new-action ;
: flashed-variables ( -- seq )
{ validation-messages named-validation-messages } ;
: handle-get ( action -- response )
blank-values
[ init>> call ]
[ display>> call ]
bi ;
'[
,
[ init>> call ]
[ drop flashed-variables restore-flash ]
[ display>> call ]
tri
] with-exit-continuation ;
: validation-failed ( -- * )
request get method>> "POST" =
[ action get display>> call ] [ <400> ] if exit-with ;
request get method>> "POST" = [ f ] [ <400> ] if exit-with ;
: handle-post ( action -- response )
init-validation
blank-values
[ validate>> call ]
[ submit>> call ] bi ;
: handle-rest-param ( arg -- )
dup length 1 > action get rest-param>> not or
[ <404> exit-with ] [
action get rest-param>> associate rest-param set
] if ;
M: action call-responder* ( path action -- response )
dup action set
'[
, dup empty? [ drop ] [ handle-rest-param ] if
init-validation
,
request get
[ request-params rest-param get assoc-union params set ]
[ method>> ] bi
{
{ "GET" [ handle-get ] }
{ "HEAD" [ handle-get ] }
{ "POST" [ handle-post ] }
} case
] with-exit-continuation ;
: (handle-post) ( action -- response )
[ validate>> call ] [ submit>> call ] bi ;
: param ( name -- value )
params get at ;
: revalidate-url-key "__u" ;
: check-url ( url -- ? )
request get url>>
[ [ protocol>> ] [ host>> ] [ port>> ] tri 3array ] bi@ = ;
: revalidate-url ( -- url/f )
revalidate-url-key param dup [ >url dup check-url swap and ] when ;
: handle-post ( action -- response )
'[
form-nesting-key params get at " " split
[ , (handle-post) ]
[ swap '[ , , nest-values ] ] reduce
call
] with-exit-continuation
[
revalidate-url
[ flashed-variables <flash-redirect> ] [ <403> ] if*
] unless* ;
: handle-rest-param ( path action -- assoc )
rest-param>> dup [ associate ] [ 2drop f ] if ;
: init-action ( path action -- )
blank-values
init-validation
handle-rest-param
request get request-params assoc-union params set ;
M: action call-responder* ( path action -- response )
[ init-action ] keep
request get method>> {
{ "GET" [ handle-get ] }
{ "HEAD" [ handle-get ] }
{ "POST" [ handle-post ] }
} case ;
M: action modify-form
drop request get url>> revalidate-url-key hidden-form-field ;
: check-validation ( -- )
validation-failed? [ validation-failed ] when ;

73
extra/furnace/asides/asides.factor Normal file
View File

@ -0,0 +1,73 @@
! 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 urls combinators
furnace http http.server http.server.filters furnace.sessions
html.elements html.templates.chloe.syntax ;
IN: furnace.asides
TUPLE: asides < filter-responder ;
C: <asides> asides
: begin-aside* ( -- id )
request get
[ url>> ] [ post-data>> ] [ method>> ] tri 3array
asides sget set-at-unique
session-changed ;
: end-aside-post ( url post-data -- response )
request [
clone
swap >>post-data
swap >>url
] change
request get url>> path>> split-path
asides get responder>> call-responder ;
ERROR: end-aside-in-get-error ;
: 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> ] }
{ "POST" [ end-aside-post ] }
} case
] [ <redirect> ] ?if ;
SYMBOL: aside-id
: aside-id-key "__a" ;
: begin-aside ( -- )
begin-aside* aside-id set ;
: end-aside ( default -- response )
aside-id [ f ] change end-aside* ;
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
call-next-method ;
M: asides link-attr ( tag -- )
drop
"aside" optional-attr {
{ "none" [ aside-id off ] }
{ "begin" [ begin-aside ] }
{ "current" [ ] }
{ f [ ] }
} case ;
M: asides modify-query ( query responder -- query' )
drop
aside-id get [ aside-id-key associate assoc-union ] when* ;
M: asides modify-form ( responder -- )
drop aside-id get aside-id-key hidden-form-field ;

48
extra/furnace/auth/login/login.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors quotations assocs kernel splitting
combinators sequences namespaces hashtables sets
fry arrays threads qualified random validators
fry arrays threads qualified random validators words
io
io.sockets
io.encodings.utf8
@ -26,14 +26,29 @@ furnace.auth
furnace.auth.providers
furnace.auth.providers.db
furnace.actions
furnace.flows
furnace.asides
furnace.flash
furnace.sessions
furnace.boilerplate ;
QUALIFIED: smtp
IN: furnace.auth.login
: word>string ( word -- string )
[ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ;
: words>strings ( seq -- seq' )
[ word>string ] map ;
: string>word ( string -- word )
":" split1 swap lookup ;
: strings>words ( seq -- seq' )
[ string>word ] map ;
TUPLE: login < dispatcher users checksum ;
TUPLE: protected < filter-responder description capabilities ;
: users ( -- provider )
login get users>> ;
@ -64,7 +79,7 @@ M: user-saver dispose
! ! ! Login
: successful-login ( user -- response )
username>> set-uid URL" $login" end-flow ;
username>> set-uid URL" $login" end-aside ;
: login-failed ( -- * )
"invalid username or password" validation-error
@ -72,6 +87,13 @@ M: user-saver dispose
: <login-action> ( -- action )
<page-action>
[
protected fget [
[ description>> "description" set-value ]
[ capabilities>> words>strings "capabilities" set-value ] bi
] when*
] >>init
{ login "login" } >>template
[
@ -177,7 +199,7 @@ M: user-saver dispose
drop
URL" $login" end-flow
URL" $login" end-aside
] >>submit ;
! ! ! Password recovery
@ -290,23 +312,23 @@ SYMBOL: lost-password-from
<action>
[
f set-uid
URL" $login" end-flow
URL" $login" end-aside
] >>submit ;
! ! ! Authentication logic
TUPLE: protected < filter-responder capabilities ;
C: <protected> protected
: <protected> ( responder -- protected )
protected new
swap >>responder ;
: show-login-page ( -- response )
begin-flow
URL" $login/login" <redirect> ;
begin-aside
URL" $login/login" { protected } <flash-redirect> ;
: check-capabilities ( responder user -- ? )
[ capabilities>> ] bi@ subset? ;
M: protected call-responder* ( path responder -- response )
dup protected set
uid dup [
users get-user 2dup check-capabilities [
[ logged-in-user set ] [ save-user-after ] bi
@ -337,7 +359,9 @@ M: login call-responder* ( path responder -- response )
! ! ! Configuration
: allow-edit-profile ( login -- login )
<edit-profile-action> f <protected> <login-boilerplate>
<edit-profile-action> <protected>
"edit your profile" >>description
<login-boilerplate>
"edit-profile" add-responder ;
: allow-registration ( login -- login )

13
extra/furnace/auth/login/login.xml
View File

@ -4,6 +4,19 @@
<t:title>Login</t:title>
<t:if t:value="description">
<p>You must log in to <t:label t:name="description" />.</p>
</t:if>
<t:if t:value="capabilities">
<p>Your user must have the following capabilities:</p>
<ul>
<t:each t:name="capabilities">
<li><t:label t:name="value" /></li>
</t:each>
</ul>
</t:if>
<t:form t:action="login">
<table>

38
extra/furnace/flash/flash.factor Normal file
View File

@ -0,0 +1,38 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs assocs.lib kernel sequences urls
http http.server http.server.filters http.server.redirection
furnace furnace.sessions ;
IN: furnace.flash
: flash-id-key "__f" ;
TUPLE: flash-scopes < filter-responder ;
C: <flash-scopes> flash-scopes
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 ;
M: flash-scopes init-session*
H{ } clone flash-scopes sset
call-next-method ;
: make-flash-scope ( seq -- id )
[ dup get ] H{ } map>assoc flash-scopes sget set-at-unique
session-changed ;
: <flash-redirect> ( url seq -- response )
make-flash-scope
[ clone ] dip flash-id-key set-query-param
<redirect> ;
: restore-flash ( seq -- )
[ flash-scope get key? ] filter [ [ fget ] keep set ] each ;

78
extra/furnace/flows/flows.factor
View File

@ -1,78 +0,0 @@
! 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 urls combinators
furnace http http.server http.server.filters furnace.sessions
html.elements html.templates.chloe.syntax ;
IN: furnace.flows
TUPLE: flows < filter-responder ;
C: <flows> flows
: begin-flow* ( -- id )
request get
[ url>> ] [ post-data>> ] [ method>> ] tri 3array
flows sget set-at-unique
session-changed ;
: end-flow-post ( url post-data -- response )
request [
clone
"POST" >>method
swap >>post-data
swap >>url
] change
request get url>> path>> split-path
flows get responder>> call-responder ;
: end-flow* ( url id -- response )
flows sget at [
first3 {
{ "GET" [ drop <redirect> ] }
{ "HEAD" [ drop <redirect> ] }
{ "POST" [ end-flow-post ] }
} case
] [ <redirect> ] ?if ;
SYMBOL: flow-id
: flow-id-key "factorflowid" ;
: begin-flow ( -- )
begin-flow* flow-id set ;
: end-flow ( default -- response )
flow-id get end-flow* ;
M: flows call-responder*
dup flows set
flow-id-key request get request-params at flow-id set
call-next-method ;
M: flows init-session*
H{ } clone flows sset
call-next-method ;
M: flows link-attr ( tag -- )
drop
"flow" optional-attr {
{ "none" [ flow-id off ] }
{ "begin" [ begin-flow ] }
{ "current" [ ] }
{ f [ ] }
} case ;
M: flows modify-query ( query responder -- query' )
drop
flow-id get [ flow-id-key associate assoc-union ] when* ;
M: flows hidden-form-field ( responder -- )
drop
flow-id get [
<input
"hidden" =type
flow-id-key =name
=value
input/>
] when* ;

7
extra/furnace/furnace-tests.factor
View File

@ -1,6 +1,7 @@
IN: furnace.tests
USING: http.server.dispatchers http.server.responses
http.server furnace tools.test kernel namespaces accessors ;
http.server furnace tools.test kernel namespaces accessors
io.streams.string ;
TUPLE: funny-dispatcher < dispatcher ;
: <funny-dispatcher> funny-dispatcher new-dispatcher ;
@ -28,3 +29,7 @@ M: base-path-check-responder call-responder*
V{ } responder-nesting set
"a/b/c" split-path main-responder get call-responder body>>
] unit-test
[ "<input type='hidden' name='foo' value='&amp;&amp;&amp;' />" ]
[ [ "&&&" "foo" hidden-form-field ] with-string-writer ]
unit-test

57
extra/furnace/furnace.factor
View File

@ -6,6 +6,7 @@ vocabs.loader classes
fry urls multiline
xml
xml.data
xml.entities
xml.writer
xml.utilities
html.components
@ -64,15 +65,19 @@ M: object modify-query drop ;
{ "POST" [ <permanent-redirect> ] }
} case ;
GENERIC: hidden-form-field ( responder -- )
GENERIC: modify-form ( responder -- )
M: object hidden-form-field drop ;
M: object modify-form drop ;
: request-params ( request -- assoc )
dup method>> {
{ "GET" [ url>> query>> ] }
{ "HEAD" [ url>> query>> ] }
{ "POST" [ post-data>> ] }
{ "POST" [
post-data>>
dup content-type>> "application/x-www-form-urlencoded" =
[ content>> ] [ drop f ] if
] }
} case ;
SYMBOL: exit-continuation
@ -128,20 +133,34 @@ CHLOE: a
[ drop </a> ]
tri ;
: hidden-form-field ( value name -- )
over [
<input
"hidden" =type
=name
object>string =value
input/>
] [ 2drop ] if ;
: form-nesting-key "factorformnesting" ;
: form-magic ( tag -- )
[ modify-form ] each-responder
nested-values get " " join f like form-nesting-key hidden-form-field
"for" optional-attr [ hidden render ] when* ;
: form-start-tag ( tag -- )
[
[
<form
"POST" =method
[ link-attrs ]
[ "action" required-attr resolve-base-path =action ]
[ tag-attrs non-chloe-attrs-only print-attrs ]
tri
"POST" =method
[ link-attrs ]
[ "action" required-attr resolve-base-path =action ]
[ tag-attrs non-chloe-attrs-only print-attrs ]
tri
form>
] [
[ hidden-form-field ] each-responder
"for" optional-attr [ hidden render ] when*
] bi
]
[ form-magic ] bi
] with-scope ;
CHLOE: form
@ -167,17 +186,3 @@ CHLOE: button
[ [ children>string 1array ] dip "button" tag-named set-tag-children ]
[ nip ]
} 2cleave process-chloe-tag ;
: attr>word ( value -- word/f )
dup ":" split1 swap lookup
[ ] [ "No such word: " swap append throw ] ?if ;
: attr>var ( value -- word/f )
attr>word dup symbol? [
"Must be a symbol: " swap append throw
] unless ;
: if-satisfied? ( tag -- ? )
"code" required-attr attr>word execute ;
CHLOE: if dup if-satisfied? [ process-tag-children ] [ drop ] if ;

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

@ -109,14 +109,14 @@ M: session-saver dispose
[ session set ] [ save-session-after ] bi
sessions get responder>> call-responder ;
: session-id-key "factorsessid" ;
: session-id-key "__s" ;
: cookie-session-id ( request -- id/f )
session-id-key get-cookie
dup [ value>> string>number ] when ;
: post-session-id ( request -- id/f )
session-id-key swap post-data>> at string>number ;
session-id-key swap request-params at string>number ;
: request-session-id ( -- id/f )
request get dup method>> {
@ -137,13 +137,8 @@ M: session-saver dispose
: put-session-cookie ( response -- response' )
session get id>> number>string <session-cookie> put-cookie ;
M: sessions hidden-form-field ( responder -- )
drop
<input
"hidden" =type
session-id-key =name
session get id>> number>string =value
input/> ;
M: sessions modify-form ( responder -- )
drop session get id>> session-id-key hidden-form-field ;
M: sessions call-responder* ( path responder -- response )
sessions set

22
extra/html/components/components.factor
View File

@ -29,22 +29,30 @@ SYMBOL: values
: deposit-slots ( destination names -- )
[ <mirror> ] dip deposit-values ;
: with-each-index ( seq quot -- )
'[
: with-each-index ( name quot -- )
[ value ] dip '[
[
values [ clone ] change
blank-values
1+ "index" set-value @
] with-scope
] each-index ; inline
: with-each-value ( seq quot -- )
: with-each-value ( name quot -- )
'[ "value" set-value @ ] with-each-index ; inline
: with-each-object ( seq quot -- )
: with-each-object ( name quot -- )
'[ from-object @ ] with-each-index ; inline
: with-values ( object quot -- )
'[ blank-values , from-object @ ] with-scope ; inline
SYMBOL: nested-values
: with-values ( name quot -- )
'[
,
[ nested-values [ swap prefix ] change ]
[ value blank-values from-object ]
bi
@
] with-scope ; inline
: nest-values ( name quot -- )
swap [

20
extra/html/templates/chloe/chloe-tests.factor
View File

@ -148,3 +148,23 @@ TUPLE: person first-name last-name ;
"test9" test-template call-template
] run-template
] unit-test
[ ] [ H{ { "a" H{ { "b" "c" } } } } values set ] unit-test
[ "<form method='POST' action='foo'><input type='hidden' name='factorformnesting' value='a'/></form>" ] [
[
"test10" test-template call-template
] run-template
] unit-test
[ ] [ blank-values ] unit-test
[ ] [
H{ { "first-name" "RBaxter" } { "last-name" "Unknown" } } "person" set-value
] unit-test
[ "<table><tr><td>RBaxter</td><td>Unknown</td></tr></table>" ] [
[
"test11" test-template call-template
] run-template [ blank? not ] filter
] unit-test

13
extra/html/templates/chloe/chloe.factor
View File

@ -68,7 +68,7 @@ CHLOE: odd "index" value odd? [ process-tag-children ] [ drop ] if ;
: (bind-tag) ( tag quot -- )
[
[ "name" required-attr value ] keep
[ "name" required-attr ] keep
'[ , process-tag-children ]
] dip call ; inline
@ -85,6 +85,17 @@ CHLOE: comment drop ;
CHLOE: call-next-template drop call-next-template ;
: attr>word ( value -- word/f )
dup ":" split1 swap lookup
[ ] [ "No such word: " swap append throw ] ?if ;
: if-satisfied? ( tag -- ? )
[ "code" optional-attr [ attr>word execute ] [ t ] if* ]
[ "value" optional-attr [ value ] [ t ] if* ]
bi and ;
CHLOE: if dup if-satisfied? [ process-tag-children ] [ drop ] if ;
CHLOE-SINGLETON: label
CHLOE-SINGLETON: link
CHLOE-SINGLETON: farkup

3
extra/html/templates/chloe/test/test10.xml Normal file
View File

@ -0,0 +1,3 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0"><t:bind t:name="a"><t:form t:action="foo"/></t:bind></t:chloe>

14
extra/html/templates/chloe/test/test11.xml Normal file
View File

@ -0,0 +1,14 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<table>
<t:bind t:name="person">
<tr>
<td><t:label t:name="first-name"/></td>
<td><t:label t:name="last-name"/></td>
</tr>
</t:bind>
</table>
</t:chloe>

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

@ -1,15 +1,16 @@
USING: http tools.test multiline tuple-syntax
io.streams.string kernel arrays splitting sequences
assocs io.sockets db db.sqlite continuations urls ;
assocs io.sockets db db.sqlite continuations urls hashtables ;
IN: http.tests
: lf>crlf "\n" split "\r\n" join ;
STRING: read-request-test-1
GET http://foo/bar HTTP/1.1
POST http://foo/bar HTTP/1.1
Some-Header: 1
Some-Header: 2
Content-Length: 4
Content-type: application/octet-stream
blah
;
@ -17,10 +18,10 @@ blah
[
TUPLE{ request
url: TUPLE{ url protocol: "http" port: 80 path: "/bar" }
method: "GET"
method: "POST"
version: "1.1"
header: H{ { "some-header" "1; 2" } { "content-length" "4" } }
post-data: "blah"
header: H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } }
post-data: TUPLE{ post-data content: "blah" raw: "blah" content-type: "application/octet-stream" }
cookies: V{ }
}
] [
@ -30,8 +31,9 @@ blah
] unit-test
STRING: read-request-test-1'
GET /bar HTTP/1.1
POST /bar HTTP/1.1
content-length: 4
content-type: application/octet-stream
some-header: 1; 2
blah
@ -87,7 +89,7 @@ blah
code: 404
message: "not found"
header: H{ { "content-type" "text/html; charset=UTF8" } }
cookies: V{ }
cookies: { }
content-type: "text/html"
content-charset: "UTF8"
}
@ -172,7 +174,7 @@ test-db [
[ ] [
[
<dispatcher>
<action> f <protected>
<action> <protected>
<login>
<sessions>
"" add-responder
@ -219,3 +221,56 @@ test-db [
[ "Hi" ] [ "http://localhost:1237/" http-get ] unit-test
[ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test
USING: html.components html.elements xml xml.utilities validators
furnace furnace.flash ;
SYMBOL: a
[ ] [
[
<dispatcher>
<action>
[ a get-global "a" set-value ] >>init
[ [ <html> "a" <field> render </html> ] "text/html" <content> ] >>display
[ { { "a" [ v-integer ] } } validate-params ] >>validate
[ "a" value a set-global URL" " <redirect> ] >>submit
<flash-scopes>
<sessions>
>>default
add-quit-action
test-db <db-persistence>
main-responder set
[ 1237 httpd ] "HTTPD test" spawn drop
] with-scope
] unit-test
[ ] [ 100 sleep ] unit-test
3 a set-global
: test-a string>xml "input" tag-named "value" swap at ;
[ "3" ] [
"http://localhost:1237/" http-get*
swap dup cookies>> "cookies" set session-id-key get-cookie
value>> "session-id" set test-a
] unit-test
[ "4" ] [
H{ { "a" "4" } { "__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
] unit-test
[ 4 ] [ a get-global ] unit-test
! 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
] unit-test
[ 4 ] [ a get-global ] unit-test
[ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test

72
extra/http/http.factor
View File

@ -10,7 +10,7 @@ io io.server io.sockets.secure
unicode.case unicode.categories qualified
urls html.templates ;
urls html.templates xml xml.data xml.writer ;
EXCLUDE: fry => , ;
@ -132,7 +132,6 @@ url
version
header
post-data
post-data-type
cookies ;
: set-header ( request/response value key -- request/response )
@ -177,19 +176,27 @@ cookies ;
: header ( request/response key -- value )
swap header>> at ;
SYMBOL: max-post-request
TUPLE: post-data raw content content-type ;
1024 256 * max-post-request set-global
: <post-data> ( raw content-type -- post-data )
post-data new
swap >>content-type
swap >>raw ;
: content-length ( header -- n )
"content-length" swap at string>number dup [
dup max-post-request get > [
"content-length > max-post-request" throw
] when
] when ;
: parse-post-data ( post-data -- post-data )
[ ] [ raw>> ] [ content-type>> ] tri {
{ "application/x-www-form-urlencoded" [ query>assoc ] }
{ "text/xml" [ string>xml ] }
[ drop ]
} case >>content ;
: read-post-data ( request -- request )
dup header>> content-length [ read >>post-data ] when* ;
dup method>> "POST" = [
[ ]
[ "content-length" header string>number read ]
[ "content-type" header ] tri
<post-data> parse-post-data >>post-data
] when ;
: extract-host ( request -- request )
[ ] [ url>> ] [ "host" header parse-host ] tri
@ -197,13 +204,6 @@ SYMBOL: max-post-request
ensure-port
drop ;
: extract-post-data-type ( request -- request )
dup "content-type" header >>post-data-type ;
: parse-post-data ( request -- request )
dup post-data-type>> "application/x-www-form-urlencoded" =
[ dup post-data>> query>assoc >>post-data ] when ;
: extract-cookies ( request -- request )
dup "cookie" header [ parse-cookies >>cookies ] when* ;
@ -225,8 +225,6 @@ SYMBOL: max-post-request
read-post-data
detect-protocol
extract-host
extract-post-data-type
parse-post-data
extract-cookies ;
: write-method ( request -- request )
@ -238,12 +236,6 @@ SYMBOL: max-post-request
: write-version ( request -- request )
"HTTP/" write dup request-version write crlf ;
: unparse-post-data ( request -- request )
dup post-data>> dup sequence? [ drop ] [
assoc>query >>post-data
"application/x-www-form-urlencoded" >>post-data-type
] if ;
: url-host ( url -- string )
[ host>> ] [ port>> ] bi dup "http" protocol-port =
[ drop ] [ ":" swap number>string 3append ] if ;
@ -251,13 +243,33 @@ SYMBOL: max-post-request
: write-request-header ( request -- request )
dup header>> >hashtable
over url>> host>> [ over url>> url-host "host" pick set-at ] when
over post-data>> [ length "content-length" pick set-at ] when*
over post-data-type>> [ "content-type" pick set-at ] when*
over post-data>> [
[ raw>> length "content-length" pick set-at ]
[ content-type>> "content-type" pick set-at ]
bi
] when*
over cookies>> f like [ unparse-cookies "cookie" pick set-at ] when*
write-header ;
GENERIC: >post-data ( object -- post-data )
M: post-data >post-data ;
M: string >post-data "application/octet-stream" <post-data> ;
M: byte-array >post-data "application/octet-stream" <post-data> ;
M: xml >post-data xml>string "text/xml" <post-data> ;
M: assoc >post-data assoc>query "application/x-www-form-urlencoded" <post-data> ;
M: f >post-data ;
: unparse-post-data ( request -- request )
[ >post-data ] change-post-data ;
: write-post-data ( request -- request )
dup post-data>> [ write ] when* ;
dup method>> "POST" = [ dup post-data>> raw>> write ] when ;
: write-request ( request -- )
unparse-post-data
@ -307,7 +319,7 @@ body ;
: read-response-header
read-header >>header
extract-cookies
dup "set-cookie" header parse-cookies >>cookies
dup "content-type" header [
parse-content-type [ >>content-type ] [ >>content-charset ] bi*
] when* ;

8
extra/http/server/cgi/cgi.factor
View File

@ -35,8 +35,10 @@ IN: http.server.cgi
request get "accept" header "HTTP_ACCEPT" set
post? [
request get post-data-type>> "CONTENT_TYPE" set
request get post-data>> length number>string "CONTENT_LENGTH" set
request get post-data>> raw>>
[ "CONTENT_TYPE" set ]
[ length number>string "CONTENT_LENGTH" set ]
bi
] when
] H{ } make-assoc ;
@ -51,7 +53,7 @@ IN: http.server.cgi
"CGI output follows" >>message
swap '[
, output-stream get swap <cgi-process> <process-stream> [
post? [ request get post-data>> write flush ] when
post? [ request get post-data>> raw>> write flush ] when
input-stream get swap (stream-copy)
] with-stream
] >>body ;

4
extra/http/server/server-tests.factor Normal file
View File

@ -0,0 +1,4 @@
USING: http http.server math sequences continuations tools.test ;
IN: http.server.tests
[ t ] [ [ \ + first ] [ <500> ] recover response? ] unit-test

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

@ -40,7 +40,7 @@ main-responder global [ <404> <trivial-responder> or ] change-at
: <500> ( error -- response )
500 "Internal server error" <trivial-response>
development-mode get [ swap '[ , http-error. ] >>body ] [ drop ] if ;
swap development-mode get [ '[ , http-error. ] >>body ] [ drop ] if ;
: do-response ( response -- )
dup write-response

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

@ -6,7 +6,8 @@ namespaces db db.sqlite smtp
http.server
http.server.dispatchers
furnace.db
furnace.flows
furnace.asides
furnace.flash
furnace.sessions
furnace.auth.login
furnace.auth.providers.db
@ -53,8 +54,7 @@ TUPLE: factor-website < dispatcher ;
allow-edit-profile
<boilerplate>
{ factor-website "page" } >>template
<flows>
<sessions>
<asides> <flash-scopes> <sessions>
test-db <db-persistence> ;
: init-factor-website ( -- )

6
extra/webapps/pastebin/paste.xml
View File

@ -28,7 +28,7 @@
<pre class="description"><t:code t:name="contents" t:mode="mode"/></pre>
<t:button t:action="$pastebin/delete-annotation" t:for="aid" class="link-button link">Delete Annotation</t:button>
<t:button t:action="$pastebin/delete-annotation" t:for="id" class="link-button link">Delete Annotation</t:button>
</t:bind-each>
@ -36,13 +36,13 @@
<h2>New Annotation</h2>
<t:form t:action="$pastebin/new-annotation" t:for="id">
<t:form t:action="$pastebin/new-annotation" t:for="parent">
<table>
<tr><th class="field-label">Summary: </th><td><t:field t:name="summary" /></td></tr>
<tr><th class="field-label">Author: </th><td><t:field t:name="author" /></td></tr>
<tr><th class="field-label">Mode: </th><td><t:choice t:name="mode" t:choices="modes" /></td></tr>
<tr><th class="field-label big-field-label">Body:</th><td><t:textarea t:name="contents" t:rows="20" t:cols="60" /></td></tr>
<tr><th class="field-label big-field-label">Body: </th><td><t:textarea t:name="contents" t:rows="20" t:cols="60" /></td></tr>
<tr><th class="field-label">Captcha: </th><td><t:field t:name="captcha" /></td></tr>
<tr>
<td></td>

4
extra/webapps/pastebin/pastebin-common.xml
View File

@ -14,10 +14,10 @@
<t:if t:code="furnace.sessions:uid">
<t:if t:code="furnace.auth.login:allow-edit-profile?">
| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
| <t:a t:href="$login/edit-profile" t:aside="begin">Edit Profile</t:a>
</t:if>
| <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
| <t:button t:action="$login/logout" t:aside="begin" class="link-button link">Logout</t:button>
</t:if>

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

@ -132,7 +132,7 @@ M: annotation entity-link
"id" value
"new-annotation" [
"id" set-value
"parent" set-value
mode-names "modes" set-value
"factor" "mode" set-value
] nest-values
@ -212,12 +212,12 @@ M: annotation entity-link
] >>display
[
{ { "id" [ v-integer ] } } validate-params
{ { "parent" [ v-integer ] } } validate-params
validate-entity
] >>validate
[
"id" value f <annotation>
"parent" value f <annotation>
[ deposit-entity-slots ]
[ insert-tuple ]
[ entity-link <redirect> ]
@ -246,9 +246,13 @@ can-delete-pastes? define-capability
<paste-action> "paste" add-responder
<paste-feed-action> "paste.atom" add-responder
<new-paste-action> "new-paste" add-responder
<delete-paste-action> { can-delete-pastes? } <protected> "delete-paste" add-responder
<delete-paste-action> <protected>
"delete pastes" >>description
{ can-delete-pastes? } >>capabilities "delete-paste" add-responder
<new-annotation-action> "new-annotation" add-responder
<delete-annotation-action> { can-delete-pastes? } <protected> "delete-annotation" add-responder
<delete-annotation-action> <protected>
"delete annotations" >>description
{ can-delete-pastes? } >>capabilities "delete-annotation" add-responder
<boilerplate>
{ pastebin "pastebin-common" } >>template ;

4
extra/webapps/planet/planet-common.xml
View File

@ -11,10 +11,10 @@
<t:if t:code="furnace.sessions:uid">
<t:if t:code="furnace.auth.login:allow-edit-profile?">
| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
| <t:a t:href="$login/edit-profile" t:aside="begin">Edit Profile</t:a>
</t:if>
| <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
| <t:button t:action="$login/logout" t:aside="begin" class="link-button link">Logout</t:button>
</t:if>
</div>

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

@ -198,7 +198,10 @@ can-administer-planet-factor? define-capability
planet-factor new-dispatcher
<planet-action> "list" add-main-responder
<feed-action> "feed.xml" add-responder
<planet-factor-admin> { can-administer-planet-factor? } <protected> "admin" add-responder
<planet-factor-admin> <protected>
"administer Planet Factor" >>description
{ can-administer-planet-factor? } >>capabilities
"admin" add-responder
<boilerplate>
{ planet-factor "planet-common" } >>template ;

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

@ -122,4 +122,5 @@ todo "TODO"
<delete-action> "delete" add-responder
<boilerplate>
{ todo-list "todo" } >>template
f <protected> ;
<protected>
"view your todo list" >>description ;

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

@ -9,10 +9,10 @@
| <t:a t:href="$todo-list/new">Add Item</t:a>
<t:if t:code="furnace.auth.login:allow-edit-profile?">
| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
| <t:a t:href="$login/edit-profile" t:aside="begin">Edit Profile</t:a>
</t:if>
| <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
| <t:button t:action="$login/logout" t:aside="begin" class="link-button link">Logout</t:button>
</div>
<h1><t:write-title /></h1>

16
extra/webapps/user-admin/user-admin.factor
View File

@ -18,18 +18,6 @@ IN: webapps.user-admin
TUPLE: user-admin < dispatcher ;
: word>string ( word -- string )
[ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ;
: words>strings ( seq -- seq' )
[ word>string ] map ;
: string>word ( string -- word )
":" split1 swap lookup ;
: strings>words ( seq -- seq' )
[ string>word ] map ;
: <user-list-action> ( -- action )
<page-action>
[ f <user> select-tuples "users" set-value ] >>init
@ -156,7 +144,9 @@ can-administer-users? define-capability
<delete-user-action> "delete" add-responder
<boilerplate>
{ user-admin "user-admin" } >>template
{ can-administer-users? } <protected> ;
<protected>
"administer users" >>description
{ can-administer-users? } >>capabilities ;
: make-admin ( username -- )
<user>

4
extra/webapps/user-admin/user-admin.xml
View File

@ -7,10 +7,10 @@
| <t:a t:href="$user-admin/new">Add User</t:a>
<t:if t:code="furnace.auth.login:allow-edit-profile?">
| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
| <t:a t:href="$login/edit-profile" t:aside="begin">Edit Profile</t:a>
</t:if>
| <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
| <t:button t:action="$login/logout" t:aside="begin" class="link-button link">Logout</t:button>
</div>
<h1><t:write-title /></h1>

2
extra/webapps/wiki/changes.xml
View File

@ -7,7 +7,7 @@
<ul>
<t:bind-each t:name="changes">
<li>
<t:a t:href="title" t:query="title"><t:label t:name="title" /></t:a>
<t:a t:href="view" t:query="title"><t:label t:name="title" /></t:a>
on
<t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a>
by

4
extra/webapps/wiki/wiki-common.xml
View File

@ -13,10 +13,10 @@
<t:if t:code="furnace.sessions:uid">
<t:if t:code="furnace.auth.login:allow-edit-profile?">
| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
| <t:a t:href="$login/edit-profile" t:aside="begin">Edit Profile</t:a>
</t:if>
| <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
| <t:button t:action="$login/logout" t:aside="begin" class="link-button link">Logout</t:button>
</t:if>

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

@ -214,6 +214,10 @@ revision "REVISIONS" {
{ wiki "user-edits" } >>template ;
SYMBOL: can-delete-wiki-articles?
can-delete-wiki-articles? define-capability
: <wiki> ( -- dispatcher )
wiki new-dispatcher
<dispatcher>
@ -222,7 +226,9 @@ revision "REVISIONS" {
<view-revision-action> "revision" add-responder
<list-revisions-action> "revisions" add-responder
<diff-action> "diff" add-responder
<edit-article-action> { } <protected> "edit" add-responder
<edit-article-action> <protected>
"edit wiki articles" >>description
"edit" add-responder
<boilerplate>
{ wiki "page-common" } >>template
>>default
@ -230,6 +236,9 @@ revision "REVISIONS" {
<user-edits-action> "user-edits" add-responder
<list-articles-action> "articles" add-responder
<list-changes-action> "changes" add-responder
<delete-action> { } <protected> "delete" add-responder
<delete-action> <protected>
"delete wiki articles" >>description
{ can-delete-wiki-articles? } >>capabilities
"delete" add-responder
<boilerplate>
{ wiki "wiki-common" } >>template ;

4
extra/xml-rpc/example.factor
View File

@ -22,6 +22,6 @@ USING: kernel hashtables xml-rpc xml calendar sequences
put-http-response ;
: test-rpc-arith
"add" { 1 2 } <rpc-method> send-rpc xml>string
"text/xml" swap "http://localhost:8080/responder/rpc/"
"add" { 1 2 } <rpc-method> send-rpc
"http://localhost:8080/responder/rpc/"
http-post ;

3
extra/xml-rpc/xml-rpc.factor
View File

@ -158,8 +158,7 @@ TAG: array xml>item
: post-rpc ( rpc url -- rpc )
! This needs to do something in the event of an error
>r "text/xml" swap send-rpc xml>string r> http-post
2nip string>xml receive-rpc ;
>r send-rpc r> http-post nip string>xml receive-rpc ;
: invoke-method ( params method url -- )
>r swap <rpc-method> r> post-rpc ;