1 ! Copyright (C) 2008, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs classes combinators continuations
4 definitions fry http http.server http.server.redirection
5 http.server.remapping io.pathnames kernel make namespaces
6 sequences splitting strings urls words xml.syntax ;
9 : word>string ( word -- string )
10 [ vocabulary>> ] [ name>> ] bi ":" glue ;
12 : words>strings ( seq -- seq' )
15 ERROR: no-such-word name vocab ;
17 : string>word ( string -- word )
18 ":" split1 swap 2dup lookup-word dup
19 [ 2nip ] [ drop throw-no-such-word ] if ;
21 : strings>words ( seq -- seq' )
24 : nested-responders ( -- seq )
25 responder-nesting get values ;
27 : each-responder ( quot: ( ... responder -- ... ) -- )
28 nested-responders swap each ; inline
30 ERROR: no-such-responder responder ;
32 : base-path ( string -- seq )
33 dup responder-nesting get
34 [ second class-of superclasses-of [ name>> = ] with any? ] with find nip
35 [ first ] [ throw-no-such-responder ] ?if ;
37 : resolve-base-path ( string -- string' )
40 "/" split1 [ base-path [ "/" % % ] each "/" % ] dip %
44 : resolve-word-path ( word -- path/f )
45 where [ first parent-directory ] [ f ] if* ;
47 : resolve-template-path ( pair -- path )
48 first2 [ resolve-word-path ] dip append-path ;
50 GENERIC: modify-query ( query responder -- query' )
52 M: object modify-query drop ;
54 GENERIC: modify-redirect-query ( query responder -- query' )
56 M: object modify-redirect-query drop ;
58 GENERIC: adjust-url ( url -- url' )
62 [ [ modify-query ] each-responder ] change-query
63 [ resolve-base-path ] change-path
66 M: string adjust-url ;
68 GENERIC: adjust-redirect-url ( url -- url' )
70 M: url adjust-redirect-url
72 [ [ modify-redirect-query ] each-responder ] change-query ;
74 M: string adjust-redirect-url ;
76 GENERIC: link-attr ( tag responder -- )
78 M: object link-attr 2drop ;
80 GENERIC: modify-form ( responder -- xml/f )
82 M: object modify-form drop f ;
84 : form-modifications ( -- xml )
85 [ [ modify-form [ , ] when* ] each-responder ] { } make ;
87 : hidden-form-field ( value name -- xml )
89 [XML <input type="hidden" value=<-> name=<->/> XML]
92 CONSTANT: nested-forms-key "__n"
94 : referrer ( -- referrer/f )
95 #! Typo is intentional, it's in the HTTP spec!
96 request get "referer" header
97 dup [ >url ensure-port [ remap-port ] change-port ] when ;
99 : user-agent ( -- user-agent )
100 request get "user-agent" header "" or ;
102 : same-host? ( url -- ? )
107 [ port>> remap-port ]
112 : cookie-client-state ( key request -- value/f )
113 swap get-cookie dup [ value>> ] when ;
115 : post-client-state ( key request -- value/f )
118 : client-state ( key -- value/f )
119 request get dup method>> {
120 { "GET" [ cookie-client-state ] }
121 { "HEAD" [ cookie-client-state ] }
122 { "POST" [ post-client-state ] }
125 SYMBOL: exit-continuation
127 : exit-with ( value -- * )
128 exit-continuation get continue-with ;
130 : with-exit-continuation ( quot -- value )
131 '[ exit-continuation set @ ] callcc1 exit-continuation off ; inline