1 ! Copyright (C) 2003, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays kernel combinators assocs
4 continuations namespaces sequences splitting words
5 vocabs.loader classes strings
6 fry urls multiline present
15 html.templates.chloe.syntax
18 http.server.redirection
21 QUALIFIED-WITH: assocs a
22 EXCLUDE: xml.utilities => children>string ;
25 : nested-responders ( -- seq )
26 responder-nesting get a:values ;
28 : each-responder ( quot -- )
29 nested-responders swap each ; inline
31 : base-path ( string -- pair )
32 dup responder-nesting get
33 [ second class word-name = ] with find nip
34 [ first ] [ "No such responder: " swap append throw ] ?if ;
36 : resolve-base-path ( string -- string' )
39 "/" split1 [ base-path [ "/" % % ] each "/" % ] dip %
43 : vocab-path ( vocab -- path )
44 dup vocab-dir vocab-append-path ;
46 : resolve-template-path ( pair -- path )
48 first2 [ word-vocabulary vocab-path % ] [ "/" % % ] bi*
51 GENERIC: modify-query ( query responder -- query' )
53 M: object modify-query drop ;
55 GENERIC: adjust-url ( url -- url' )
59 [ [ modify-query ] each-responder ] change-query
60 [ resolve-base-path ] change-path
63 M: string adjust-url ;
65 : <redirect> ( url -- response )
66 adjust-url request get method>> {
67 { "GET" [ <temporary-redirect> ] }
68 { "HEAD" [ <temporary-redirect> ] }
69 { "POST" [ <permanent-redirect> ] }
72 GENERIC: modify-form ( responder -- )
74 M: object modify-form drop ;
76 : request-params ( request -- assoc )
78 { "GET" [ url>> query>> ] }
79 { "HEAD" [ url>> query>> ] }
82 dup content-type>> "application/x-www-form-urlencoded" =
83 [ content>> ] [ drop f ] if
87 SYMBOL: exit-continuation
89 : exit-with exit-continuation get continue-with ;
91 : with-exit-continuation ( quot -- )
92 '[ exit-continuation set @ ] callcc1 exit-continuation off ;
95 : parse-query-attr ( string -- assoc )
97 [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
101 [ "href" required-attr ]
102 [ "query" optional-attr parse-query-attr ] tri
106 adjust-url relative-to-request
109 CHLOE: write-atom drop write-atom-feeds ;
111 GENERIC: link-attr ( tag responder -- )
113 M: object link-attr 2drop ;
115 : link-attrs ( tag -- )
116 '[ , _ link-attr ] each-responder ;
118 : a-start-tag ( tag -- )
122 dup "value" optional-attr [ value f ] [
123 [ "href" required-attr ]
124 [ "query" optional-attr parse-query-attr ]
130 adjust-url relative-to-request =href
136 [ process-tag-children ]
140 : hidden-form-field ( value name -- )
149 : form-nesting-key "__n" ;
151 : form-magic ( tag -- )
152 [ modify-form ] each-responder
153 nested-values get " " join f like form-nesting-key hidden-form-field
154 "for" optional-attr [ "," split [ hidden render ] each ] when* ;
156 : form-start-tag ( tag -- )
162 [ "action" required-attr resolve-base-path =action ]
163 [ tag-attrs non-chloe-attrs-only print-attrs ]
172 [ process-tag-children ]
176 STRING: button-tag-markup
177 <t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
178 <button type="submit"></button>
182 : add-tag-attrs ( attrs tag -- )
183 tag-attrs swap update ;
186 button-tag-markup string>xml delegate
188 [ [ tag-attrs chloe-attrs-only ] dip add-tag-attrs ]
189 [ [ tag-attrs non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ]
190 [ [ children>string 1array ] dip "button" tag-named set-tag-children ]
192 } 2cleave process-chloe-tag ;