1 ! Copyright (C) 2008 Slava Pestov.
\r
2 ! See http://factorcode.org/license.txt for BSD license.
\r
3 USING: accessors sequences kernel assocs combinators
\r
4 validators http hashtables namespaces fry continuations locals
\r
5 io arrays math boxes splitting urls
\r
8 http.server.responses
\r
11 furnace.conversations
\r
16 html.templates.chloe
\r
17 html.templates.chloe.syntax
\r
18 html.templates.chloe.compiler ;
\r
25 : render-validation-messages ( -- )
\r
28 <ul "errors" =class ul>
\r
29 [ <li> escape-string write </li> ] each
\r
33 CHLOE: validation-messages
\r
34 drop [ render-validation-messages ] [code] ;
\r
36 TUPLE: action rest authorize init display validate submit ;
\r
38 : new-action ( class -- action )
\r
39 new [ ] >>init [ ] >>validate [ ] >>authorize ; inline
\r
41 : <action> ( -- action )
\r
44 : merge-forms ( form -- )
\r
46 [ [ errors>> ] bi@ push-all ]
\r
47 [ [ values>> ] bi@ swap update ]
\r
48 [ swap validation-failed>> >>validation-failed drop ]
\r
51 : set-nested-form ( form name -- )
\r
55 unclip [ set-nested-form ] nest-form
\r
58 : restore-validation-errors ( -- )
\r
60 nested-forms cget set-nested-form
\r
63 : handle-get ( action -- response )
\r
68 [ authorize>> call ]
\r
69 [ drop restore-validation-errors ]
\r
73 ] with-exit-continuation ;
\r
75 : param ( name -- value )
\r
78 : revalidate-url-key "__u" ;
\r
80 : revalidate-url ( -- url/f )
\r
81 revalidate-url-key param
\r
82 dup [ >url ensure-port [ same-host? ] keep and ] when ;
\r
84 : validation-failed ( -- * )
\r
85 post-request? revalidate-url and [
\r
87 nested-forms-key param " " split harvest nested-forms cset
\r
89 <continue-conversation>
\r
93 : handle-post ( action -- response )
\r
97 [ authorize>> call ]
\r
100 ] [ drop <400> ] if
\r
101 ] with-exit-continuation ;
\r
103 : handle-rest ( path action -- assoc )
\r
104 rest>> dup [ [ "/" join ] dip associate ] [ 2drop f ] if ;
\r
106 : init-action ( path action -- )
\r
109 request get request-params assoc-union params set ;
\r
111 M: action call-responder* ( path action -- response )
\r
112 [ init-action ] keep
\r
113 request get method>> {
\r
114 { "GET" [ handle-get ] }
\r
115 { "HEAD" [ handle-get ] }
\r
116 { "POST" [ handle-post ] }
\r
119 M: action modify-form
\r
120 drop url get revalidate-url-key hidden-form-field ;
\r
122 : check-validation ( -- )
\r
123 validation-failed? [ validation-failed ] when ;
\r
125 : validate-params ( validators -- )
\r
126 params get swap validate-values check-validation ;
\r
128 : validate-integer-id ( -- )
\r
129 { { "id" [ v-number ] } } validate-params ;
\r
131 TUPLE: page-action < action template ;
\r
133 : <chloe-content> ( path -- response )
\r
134 resolve-template-path <chloe> "text/html" <content> ;
\r
136 : <page-action> ( -- page )
\r
137 page-action new-action
\r
138 dup '[ _ template>> <chloe-content> ] >>display ;
\r