remove math.blas.syntax and merge parsing words into math.blas.vectors/matrices
[factor/jcg.git] / basis / furnace / utilities / utilities.factor
blobe09047b74a769edf8d0907f1c747508db5182c3b
1 ! Copyright (C) 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: namespaces make assocs sequences kernel classes splitting
4 words vocabs.loader accessors strings combinators arrays
5 continuations present fry urls html.elements http http.server
6 http.server.redirection http.server.remapping ;
7 IN: furnace.utilities
9 : word>string ( word -- string )
10     [ vocabulary>> ] [ name>> ] bi ":" glue ;
12 : words>strings ( seq -- seq' )
13     [ word>string ] map ;
15 ERROR: no-such-word name vocab ;
17 : string>word ( string -- word )
18     ":" split1 swap 2dup lookup dup
19     [ 2nip ] [ drop no-such-word ] if ;
21 : strings>words ( seq -- seq' )
22     [ string>word ] map ;
24 : nested-responders ( -- seq )
25     responder-nesting get values ;
27 : each-responder ( quot -- )
28    nested-responders swap each ; inline
30 : base-path ( string -- pair )
31     dup responder-nesting get
32     [ second class superclasses [ name>> = ] with any? ] with find nip
33     [ first ] [ "No such responder: " swap append throw ] ?if ;
35 : resolve-base-path ( string -- string' )
36     "$" ?head [
37         [
38             "/" split1 [ base-path [  "/" % % ] each "/" % ] dip %
39         ] "" make
40     ] when ;
42 : vocab-path ( vocab -- path )
43     dup vocab-dir vocab-append-path ;
45 : resolve-template-path ( pair -- path )
46     [
47         first2 [ vocabulary>> vocab-path % ] [ "/" % % ] bi*
48     ] "" make ;
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' )
60 M: url adjust-url
61     clone
62         [ [ modify-query ] each-responder ] change-query
63         [ resolve-base-path ] change-path
64     relative-to-request ;
66 M: string adjust-url ;
68 GENERIC: adjust-redirect-url ( url -- url' )
70 M: url adjust-redirect-url
71     adjust-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 -- )
82 M: object modify-form drop ;
84 : hidden-form-field ( value name -- )
85     over [
86         <input
87             "hidden" =type
88             =name
89             present =value
90         input/>
91     ] [ 2drop ] if ;
93 : nested-forms-key "__n" ;
95 : request-params ( request -- assoc )
96     dup method>> {
97         { "GET" [ url>> query>> ] }
98         { "HEAD" [ url>> query>> ] }
99         { "POST" [ post-data>> params>> ] }
100     } case ;
102 : referrer ( -- referrer/f )
103     #! Typo is intentional, it's in the HTTP spec!
104     "referer" request get header>> at
105     dup [ >url ensure-port [ remap-port ] change-port ] when ;
107 : user-agent ( -- user-agent )
108     "user-agent" request get header>> at "" or ;
110 : same-host? ( url -- ? )
111     dup [
112         url get [
113             [ protocol>> ]
114             [ host>> ]
115             [ port>> remap-port ]
116             tri 3array
117         ] bi@ =
118     ] when ;
120 : cookie-client-state ( key request -- value/f )
121     swap get-cookie dup [ value>> ] when ;
123 : post-client-state ( key request -- value/f )
124     request-params at ;
126 : client-state ( key -- value/f )
127     request get dup method>> {
128         { "GET" [ cookie-client-state ] }
129         { "HEAD" [ cookie-client-state ] }
130         { "POST" [ post-client-state ] }
131     } case ;
133 SYMBOL: exit-continuation
135 : exit-with ( value -- )
136     exit-continuation get continue-with ;
138 : with-exit-continuation ( quot -- value )
139     '[ exit-continuation set @ ] callcc1 exit-continuation off ;