-! Copyright (C) 2008, 2009 Slava Pestov.\r
-! 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 splitting urls\r
-xml.entities\r
-http.server\r
-http.server.responses\r
-furnace.utilities\r
-furnace.redirection\r
-furnace.conversations\r
-furnace.chloe-tags\r
-html.forms\r
-html.components\r
-html.templates.chloe\r
-html.templates.chloe.syntax\r
-html.templates.chloe.compiler ;\r
-IN: furnace.actions\r
-\r
-SYMBOL: rest\r
-\r
-TUPLE: action rest init authorize display validate submit ;\r
-\r
-: new-action ( class -- action )\r
- new [ ] >>init [ ] >>validate [ ] >>authorize ; inline\r
-\r
-: <action> ( -- action )\r
- action new-action ;\r
-\r
-: merge-forms ( form -- )\r
- [ form get ] dip\r
- [ [ errors>> ] bi@ append! drop ]\r
- [ [ values>> ] bi@ assoc-union! drop ]\r
- [ validation-failed>> >>validation-failed drop ]\r
- 2tri ;\r
-\r
-: set-nested-form ( form name -- )\r
- [\r
- merge-forms\r
- ] [\r
- unclip [ set-nested-form ] nest-form\r
- ] if-empty ;\r
-\r
-: restore-validation-errors ( -- )\r
- form cget [\r
- nested-forms cget set-nested-form\r
- ] when* ;\r
-\r
-: handle-get ( action -- response )\r
- '[\r
- _ dup display>> [\r
- {\r
- [ init>> call( -- ) ]\r
- [ authorize>> call( -- ) ]\r
- [ drop restore-validation-errors ]\r
- [ display>> call( -- response ) ]\r
- } cleave\r
- ] [ drop <400> ] if\r
- ] with-exit-continuation ;\r
-\r
-CONSTANT: revalidate-url-key "__u"\r
-\r
-: revalidate-url ( -- url/f )\r
- revalidate-url-key param\r
- dup [ >url ensure-port [ same-host? ] keep and ] when ;\r
-\r
-: validation-failed ( -- * )\r
- post-request? revalidate-url and [\r
- begin-conversation\r
- nested-forms-key param " " split harvest nested-forms cset\r
- form get form cset\r
- <continue-conversation>\r
- ] [ <400> ] if*\r
- exit-with ;\r
-\r
-: handle-post ( action -- response )\r
- '[\r
- _ dup submit>> [\r
- [ validate>> call( -- ) ]\r
- [ authorize>> call( -- ) ]\r
- [ submit>> call( -- response ) ]\r
- tri\r
- ] [ drop <400> ] if\r
- ] with-exit-continuation ;\r
-\r
-: handle-rest ( path action -- )\r
- rest>> dup [ [ "/" join ] dip set-param ] [ 2drop ] if ;\r
-\r
-: init-action ( path action -- )\r
- begin-form\r
- handle-rest ;\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 url get revalidate-url-key hidden-form-field ;\r
-\r
-: check-validation ( -- )\r
- validation-failed? [ validation-failed ] when ;\r
-\r
-: validate-params ( validators -- )\r
- params get swap validate-values check-validation ;\r
-\r
-: validate-integer-id ( -- )\r
- { { "id" [ v-number ] } } validate-params ;\r
-\r
-TUPLE: page-action < action template ;\r
-\r
-: <chloe-content> ( path -- response )\r
- resolve-template-path <chloe> <html-content> ;\r
-\r
-: <page-action> ( -- page )\r
- page-action new-action\r
- dup '[ _ template>> <chloe-content> ] >>display ;\r
+! Copyright (C) 2008, 2009 Slava Pestov.
+! 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 splitting urls
+xml.entities
+http.server
+http.server.responses
+furnace.utilities
+furnace.redirection
+furnace.conversations
+furnace.chloe-tags
+html.forms
+html.components
+html.templates.chloe
+html.templates.chloe.syntax
+html.templates.chloe.compiler ;
+IN: furnace.actions
+
+SYMBOL: rest
+
+TUPLE: action rest init authorize display validate submit ;
+
+: new-action ( class -- action )
+ new [ ] >>init [ ] >>validate [ ] >>authorize ; inline
+
+: <action> ( -- action )
+ action new-action ;
+
+: merge-forms ( form -- )
+ [ form get ] dip
+ [ [ errors>> ] bi@ append! drop ]
+ [ [ values>> ] bi@ assoc-union! drop ]
+ [ validation-failed>> >>validation-failed drop ]
+ 2tri ;
+
+: set-nested-form ( form name -- )
+ [
+ merge-forms
+ ] [
+ unclip [ set-nested-form ] nest-form
+ ] if-empty ;
+
+: restore-validation-errors ( -- )
+ form cget [
+ nested-forms cget set-nested-form
+ ] when* ;
+
+: handle-get ( action -- response )
+ '[
+ _ dup display>> [
+ {
+ [ init>> call( -- ) ]
+ [ authorize>> call( -- ) ]
+ [ drop restore-validation-errors ]
+ [ display>> call( -- response ) ]
+ } cleave
+ ] [ drop <400> ] if
+ ] with-exit-continuation ;
+
+CONSTANT: revalidate-url-key "__u"
+
+: revalidate-url ( -- url/f )
+ revalidate-url-key param
+ dup [ >url ensure-port [ same-host? ] keep and ] when ;
+
+: validation-failed ( -- * )
+ post-request? revalidate-url and [
+ begin-conversation
+ nested-forms-key param " " split harvest nested-forms cset
+ form get form cset
+ <continue-conversation>
+ ] [ <400> ] if*
+ exit-with ;
+
+: handle-post ( action -- response )
+ '[
+ _ dup submit>> [
+ [ validate>> call( -- ) ]
+ [ authorize>> call( -- ) ]
+ [ submit>> call( -- response ) ]
+ tri
+ ] [ drop <400> ] if
+ ] with-exit-continuation ;
+
+: handle-rest ( path action -- )
+ rest>> dup [ [ "/" join ] dip set-param ] [ 2drop ] if ;
+
+: init-action ( path action -- )
+ begin-form
+ handle-rest ;
+
+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 url get revalidate-url-key hidden-form-field ;
+
+: check-validation ( -- )
+ validation-failed? [ validation-failed ] when ;
+
+: validate-params ( validators -- )
+ params get swap validate-values check-validation ;
+
+: validate-integer-id ( -- )
+ { { "id" [ v-number ] } } validate-params ;
+
+TUPLE: page-action < action template ;
+
+: <chloe-content> ( path -- response )
+ resolve-template-path <chloe> <html-content> ;
+
+: <page-action> ( -- page )
+ page-action new-action
+ dup '[ _ template>> <chloe-content> ] >>display ;
projects / factor.git / blobdiff