! See http://factorcode.org/license.txt for BSD license.\r
USING: accessors sequences kernel assocs combinators\r
validators http hashtables namespaces fry continuations locals\r
-io arrays math boxes\r
+io arrays math boxes splitting urls\r
xml.entities\r
http.server\r
http.server.responses\r
furnace\r
+furnace.flash\r
html.elements\r
html.components\r
+html.components\r
html.templates.chloe\r
html.templates.chloe.syntax ;\r
IN: furnace.actions\r
: <action> ( -- action )\r
action new-action ;\r
\r
+: flashed-variables ( -- seq )\r
+ { validation-messages named-validation-messages } ;\r
+\r
: handle-get ( action -- response )\r
- blank-values\r
- [ init>> call ]\r
- [ display>> call ]\r
- bi ;\r
+ '[\r
+ ,\r
+ [ init>> call ]\r
+ [ drop flashed-variables restore-flash ]\r
+ [ display>> call ]\r
+ tri\r
+ ] with-exit-continuation ;\r
\r
: validation-failed ( -- * )\r
- request get method>> "POST" =\r
- [ action get display>> call ] [ <400> ] if exit-with ;\r
+ request get method>> "POST" = [ f ] [ <400> ] if exit-with ;\r
\r
-: handle-post ( action -- response )\r
- init-validation\r
- blank-values\r
- [ validate>> call ]\r
- [ submit>> call ] bi ;\r
+: (handle-post) ( action -- response )\r
+ [ validate>> call ] [ submit>> call ] bi ;\r
\r
-: handle-rest-param ( arg -- )\r
- dup length 1 > action get rest-param>> not or\r
- [ <404> exit-with ] [\r
- action get rest-param>> associate rest-param set\r
- ] if ;\r
+: param ( name -- value )\r
+ params get at ;\r
\r
-M: action call-responder* ( path action -- response )\r
- dup action set\r
- '[\r
- , dup empty? [ drop ] [ handle-rest-param ] if\r
+: revalidate-url-key "__u" ;\r
\r
- init-validation\r
- ,\r
- request get\r
- [ request-params rest-param get assoc-union params set ]\r
- [ method>> ] bi\r
- {\r
- { "GET" [ handle-get ] }\r
- { "HEAD" [ handle-get ] }\r
- { "POST" [ handle-post ] }\r
- } case\r
- ] with-exit-continuation ;\r
+: check-url ( url -- ? )\r
+ request get url>>\r
+ [ [ protocol>> ] [ host>> ] [ port>> ] tri 3array ] bi@ = ;\r
\r
-: param ( name -- value )\r
- params get at ;\r
+: revalidate-url ( -- url/f )\r
+ revalidate-url-key param dup [ >url dup check-url swap and ] when ;\r
+\r
+: handle-post ( action -- response )\r
+ '[\r
+ form-nesting-key params get at " " split\r
+ [ , (handle-post) ]\r
+ [ swap '[ , , nest-values ] ] reduce\r
+ call\r
+ ] with-exit-continuation\r
+ [\r
+ revalidate-url\r
+ [ flashed-variables <flash-redirect> ] [ <403> ] if*\r
+ ] unless* ;\r
+\r
+: handle-rest-param ( path action -- assoc )\r
+ rest-param>> dup [ associate ] [ 2drop f ] if ;\r
+\r
+: init-action ( path action -- )\r
+ blank-values\r
+ init-validation\r
+ handle-rest-param\r
+ request get request-params assoc-union params set ;\r
+\r
+M: action call-responder* ( path action -- response )\r
+ [ init-action ] keep\r
+ request get method>> {\r
+ { "GET" [ handle-get ] }\r
+ { "HEAD" [ handle-get ] }\r
+ { "POST" [ handle-post ] }\r
+ } case ;\r
+\r
+M: action modify-form\r
+ drop request get url>> revalidate-url-key hidden-form-field ;\r
\r
: check-validation ( -- )\r
validation-failed? [ validation-failed ] when ;\r
--- /dev/null
+! 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 ;
! See http://factorcode.org/license.txt for BSD license.\r
USING: accessors quotations assocs kernel splitting\r
combinators sequences namespaces hashtables sets\r
-fry arrays threads qualified random validators\r
+fry arrays threads qualified random validators words\r
io\r
io.sockets\r
io.encodings.utf8\r
furnace.auth.providers\r
furnace.auth.providers.db\r
furnace.actions\r
-furnace.flows\r
+furnace.asides\r
+furnace.flash\r
furnace.sessions\r
furnace.boilerplate ;\r
QUALIFIED: smtp\r
IN: furnace.auth.login\r
\r
+: word>string ( word -- string )\r
+ [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ;\r
+\r
+: words>strings ( seq -- seq' )\r
+ [ word>string ] map ;\r
+\r
+: string>word ( string -- word )\r
+ ":" split1 swap lookup ;\r
+\r
+: strings>words ( seq -- seq' )\r
+ [ string>word ] map ;\r
+\r
TUPLE: login < dispatcher users checksum ;\r
\r
+TUPLE: protected < filter-responder description capabilities ;\r
+\r
: users ( -- provider )\r
login get users>> ;\r
\r
\r
! ! ! Login\r
: successful-login ( user -- response )\r
- username>> set-uid URL" $login" end-flow ;\r
+ username>> set-uid URL" $login" end-aside ;\r
\r
: login-failed ( -- * )\r
"invalid username or password" validation-error\r
\r
: <login-action> ( -- action )\r
<page-action>\r
+ [\r
+ protected fget [\r
+ [ description>> "description" set-value ]\r
+ [ capabilities>> words>strings "capabilities" set-value ] bi\r
+ ] when*\r
+ ] >>init\r
+\r
{ login "login" } >>template\r
\r
[\r
\r
drop\r
\r
- URL" $login" end-flow\r
+ URL" $login" end-aside\r
] >>submit ;\r
\r
! ! ! Password recovery\r
<action>\r
[\r
f set-uid\r
- URL" $login" end-flow\r
+ URL" $login" end-aside\r
] >>submit ;\r
\r
! ! ! Authentication logic\r
-\r
-TUPLE: protected < filter-responder capabilities ;\r
-\r
-C: <protected> protected\r
+: <protected> ( responder -- protected )\r
+ protected new\r
+ swap >>responder ;\r
\r
: show-login-page ( -- response )\r
- begin-flow\r
- URL" $login/login" <redirect> ;\r
+ begin-aside\r
+ URL" $login/login" { protected } <flash-redirect> ;\r
\r
: check-capabilities ( responder user -- ? )\r
[ capabilities>> ] bi@ subset? ;\r
\r
M: protected call-responder* ( path responder -- response )\r
+ dup protected set\r
uid dup [\r
users get-user 2dup check-capabilities [\r
[ logged-in-user set ] [ save-user-after ] bi\r
! ! ! Configuration\r
\r
: allow-edit-profile ( login -- login )\r
- <edit-profile-action> f <protected> <login-boilerplate>\r
+ <edit-profile-action> <protected>\r
+ "edit your profile" >>description\r
+ <login-boilerplate>\r
"edit-profile" add-responder ;\r
\r
: allow-registration ( login -- login )\r
<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>
--- /dev/null
+! 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 ;
+++ /dev/null
-! 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* ;
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 ;
V{ } responder-nesting set
"a/b/c" split-path main-responder get call-responder body>>
] unit-test
+
+[ "<input type='hidden' name='foo' value='&&&' />" ]
+[ [ "&&&" "foo" hidden-form-field ] with-string-writer ]
+unit-test
fry urls multiline
xml
xml.data
+xml.entities
xml.writer
xml.utilities
html.components
{ "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
[ 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
[ [ 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 ;
[ 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>> {
: 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
: 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 [
"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
: (bind-tag) ( tag quot -- )
[
- [ "name" required-attr value ] keep
+ [ "name" required-attr ] keep
'[ , process-tag-children ]
] dip call ; inline
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
--- /dev/null
+<?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>
--- /dev/null
+<?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>
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
;
[
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{ }
}
] [
] 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
code: 404
message: "not found"
header: H{ { "content-type" "text/html; charset=UTF8" } }
- cookies: V{ }
+ cookies: { }
content-type: "text/html"
content-charset: "UTF8"
}
[ ] [
[
<dispatcher>
+ <action> <protected>
<login>
<sessions>
"" add-responder
[ "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
unicode.case unicode.categories qualified
-urls html.templates ;
+urls html.templates xml xml.data xml.writer ;
EXCLUDE: fry => , ;
version
header
post-data
-post-data-type
cookies ;
: set-header ( request/response value key -- request/response )
: 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
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* ;
read-post-data
detect-protocol
extract-host
- extract-post-data-type
- parse-post-data
extract-cookies ;
: write-method ( request -- 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 ;
: 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
: 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* ;
request get "accept" header "HTTP_ACCEPT" set\r
\r
post? [\r
- request get post-data-type>> "CONTENT_TYPE" set\r
- request get post-data>> length number>string "CONTENT_LENGTH" set\r
+ request get post-data>> raw>>\r
+ [ "CONTENT_TYPE" set ]\r
+ [ length number>string "CONTENT_LENGTH" set ]\r
+ bi\r
] when\r
] H{ } make-assoc ;\r
\r
"CGI output follows" >>message\r
swap '[\r
, output-stream get swap <cgi-process> <process-stream> [\r
- post? [ request get post-data>> write flush ] when\r
+ post? [ request get post-data>> raw>> write flush ] when\r
input-stream get swap (stream-copy)\r
] with-stream\r
] >>body ;\r
--- /dev/null
+USING: http http.server math sequences continuations tools.test ;
+IN: http.server.tests
+
+[ t ] [ [ \ + first ] [ <500> ] recover response? ] unit-test
: <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
http.server
http.server.dispatchers
furnace.db
-furnace.flows
+furnace.asides
+furnace.flash
furnace.sessions
furnace.auth.login
furnace.auth.providers.db
allow-edit-profile
<boilerplate>
{ factor-website "page" } >>template
- <flows>
- <sessions>
+ <asides> <flash-scopes> <sessions>
test-db <db-persistence> ;
: init-factor-website ( -- )
<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>
<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>
<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>
"id" value
"new-annotation" [
- "id" set-value
+ "parent" set-value
mode-names "modes" set-value
"factor" "mode" set-value
] nest-values
] >>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> ]
<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 ;
<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>
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 ;
<delete-action> "delete" add-responder
<boilerplate>
{ todo-list "todo" } >>template
- f <protected> ;
+ <protected>
+ "view your todo list" >>description ;
| <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>
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
<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>
| <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>
<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
<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>
{ wiki "user-edits" } >>template ;
+SYMBOL: can-delete-wiki-articles?
+
+can-delete-wiki-articles? define-capability
+
: <wiki> ( -- dispatcher )
wiki new-dispatcher
<dispatcher>
<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
<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 ;
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 ;
: 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 ;
projects / factor.git / commitdiff