1 ! Copyright (C) 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: namespaces assocs sequences kernel classes splitting
4 vocabs.loader accessors strings combinators arrays
5 continuations present fry
7 http http.server http.server.redirection ;
10 : nested-responders ( -- seq )
11 responder-nesting get values ;
13 : each-responder ( quot -- )
14 nested-responders swap each ; inline
16 : base-path ( string -- pair )
17 dup responder-nesting get
18 [ second class superclasses [ name>> = ] with contains? ] with find nip
19 [ first ] [ "No such responder: " swap append throw ] ?if ;
21 : resolve-base-path ( string -- string' )
24 "/" split1 [ base-path [ "/" % % ] each "/" % ] dip %
28 : vocab-path ( vocab -- path )
29 dup vocab-dir vocab-append-path ;
31 : resolve-template-path ( pair -- path )
33 first2 [ vocabulary>> vocab-path % ] [ "/" % % ] bi*
36 GENERIC: modify-query ( query responder -- query' )
38 M: object modify-query drop ;
40 GENERIC: adjust-url ( url -- url' )
44 [ [ modify-query ] each-responder ] change-query
45 [ resolve-base-path ] change-path
48 M: string adjust-url ;
50 GENERIC: link-attr ( tag responder -- )
52 M: object link-attr 2drop ;
54 GENERIC: modify-form ( responder -- )
56 M: object modify-form drop ;
58 : hidden-form-field ( value name -- )
67 : nested-forms-key "__n" ;
69 : request-params ( request -- assoc )
71 { "GET" [ url>> query>> ] }
72 { "HEAD" [ url>> query>> ] }
75 dup content-type>> "application/x-www-form-urlencoded" =
76 [ content>> ] [ drop f ] if
80 : referrer ( -- referrer )
81 #! Typo is intentional, its in the HTTP spec!
82 "referer" request get header>> at >url ;
84 : user-agent ( -- user-agent )
85 "user-agent" request get header>> at "" or ;
87 : same-host? ( url -- ? )
89 [ [ protocol>> ] [ host>> ] [ port>> ] tri 3array ] bi@ = ;
91 : cookie-client-state ( key request -- value/f )
92 swap get-cookie dup [ value>> ] when ;
94 : post-client-state ( key request -- value/f )
97 : client-state ( key -- value/f )
98 request get dup method>> {
99 { "GET" [ cookie-client-state ] }
100 { "HEAD" [ cookie-client-state ] }
101 { "POST" [ post-client-state ] }
104 SYMBOL: exit-continuation
106 : exit-with ( value -- )
107 exit-continuation get continue-with ;
109 : with-exit-continuation ( quot -- )
110 '[ exit-continuation set @ ] callcc1 exit-continuation off ;
112 "furnace.chloe-tags" require