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
16 html.templates.chloe.syntax
19 http.server.redirection
22 QUALIFIED-WITH: assocs a
23 EXCLUDE: xml.utilities => children>string ;
26 : nested-responders ( -- seq )
27 responder-nesting get a:values ;
29 : each-responder ( quot -- )
30 nested-responders swap each ; inline
32 : base-path ( string -- pair )
33 dup responder-nesting get
34 [ second class superclasses [ name>> = ] with contains? ] with find nip
35 [ first ] [ "No such responder: " swap append throw ] ?if ;
37 : resolve-base-path ( string -- string' )
40 "/" split1 [ base-path [ "/" % % ] each "/" % ] dip %
44 : vocab-path ( vocab -- path )
45 dup vocab-dir vocab-append-path ;
47 : resolve-template-path ( pair -- path )
49 first2 [ vocabulary>> vocab-path % ] [ "/" % % ] bi*
52 GENERIC: modify-query ( query responder -- query' )
54 M: object modify-query drop ;
56 GENERIC: adjust-url ( url -- url' )
60 [ [ modify-query ] each-responder ] change-query
61 [ resolve-base-path ] change-path
64 M: string adjust-url ;
66 GENERIC: modify-form ( responder -- )
68 M: object modify-form drop ;
70 : request-params ( request -- assoc )
72 { "GET" [ url>> query>> ] }
73 { "HEAD" [ url>> query>> ] }
76 dup content-type>> "application/x-www-form-urlencoded" =
77 [ content>> ] [ drop f ] if
81 : referrer ( -- referrer )
82 #! Typo is intentional, its in the HTTP spec!
83 "referer" request get header>> at >url ;
85 : user-agent ( -- user-agent )
86 "user-agent" request get header>> at "" or ;
88 : same-host? ( url -- ? )
90 [ [ protocol>> ] [ host>> ] [ port>> ] tri 3array ] bi@ = ;
92 : cookie-client-state ( key request -- value/f )
93 swap get-cookie dup [ value>> ] when ;
95 : post-client-state ( key request -- value/f )
98 : client-state ( key -- value/f )
99 request get dup method>> {
100 { "GET" [ cookie-client-state ] }
101 { "HEAD" [ cookie-client-state ] }
102 { "POST" [ post-client-state ] }
105 SYMBOL: exit-continuation
107 : exit-with ( value -- )
108 exit-continuation get continue-with ;
110 : with-exit-continuation ( quot -- )
111 '[ exit-continuation set @ ] callcc1 exit-continuation off ;
114 : parse-query-attr ( string -- assoc )
116 [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
118 : a-url-path ( tag -- string )
119 [ "href" required-attr ]
120 [ "rest" optional-attr dup [ value ] when ] bi
121 [ [ "/" ?tail drop "/" ] dip present 3append ] when* ;
123 : a-url ( tag -- url )
124 dup "value" optional-attr
128 [ a-url-path >>path ]
129 [ "query" optional-attr parse-query-attr >>query ]
131 adjust-url relative-to-request
134 CHLOE: atom [ children>string ] [ a-url ] bi add-atom-feed ;
136 CHLOE: write-atom drop write-atom-feeds ;
138 GENERIC: link-attr ( tag responder -- )
140 M: object link-attr 2drop ;
142 : link-attrs ( tag -- )
143 #! Side-effects current namespace.
144 '[ , _ link-attr ] each-responder ;
146 : a-start-tag ( tag -- )
147 [ <a [ link-attrs ] [ a-url =href ] bi a> ] with-scope ;
151 [ process-tag-children ]
155 : hidden-form-field ( value name -- )
164 : nested-forms-key "__n" ;
166 : form-magic ( tag -- )
167 [ modify-form ] each-responder
168 nested-forms get " " join f like nested-forms-key hidden-form-field
169 "for" optional-attr [ "," split [ hidden render ] each ] when* ;
171 : form-start-tag ( tag -- )
177 [ "method" optional-attr "post" or =method ]
178 [ "action" required-attr resolve-base-path =action ]
179 [ attrs>> non-chloe-attrs-only print-attrs ]
188 [ process-tag-children ]
192 STRING: button-tag-markup
193 <t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
194 <button type="submit"></button>
198 : add-tag-attrs ( attrs tag -- )
199 attrs>> swap update ;
202 button-tag-markup string>xml body>>
204 [ [ attrs>> chloe-attrs-only ] dip add-tag-attrs ]
205 [ [ attrs>> non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ]
206 [ [ children>string 1array ] dip "button" tag-named (>>children) ]
208 } 2cleave process-chloe-tag ;