adam@1478
|
1 (* Copyright (c) 2008-2011, Adam Chlipala
|
adamc@764
|
2 * All rights reserved.
|
adamc@764
|
3 *
|
adamc@764
|
4 * Redistribution and use in source and binary forms, with or without
|
adamc@764
|
5 * modification, are permitted provided that the following conditions are met:
|
adamc@764
|
6 *
|
adamc@764
|
7 * - Redistributions of source code must retain the above copyright notice,
|
adamc@764
|
8 * this list of conditions and the following disclaimer.
|
adamc@764
|
9 * - Redistributions in binary form must reproduce the above copyright notice,
|
adamc@764
|
10 * this list of conditions and the following disclaimer in the documentation
|
adamc@764
|
11 * and/or other materials provided with the distribution.
|
adamc@764
|
12 * - The names of contributors may not be used to endorse or promote products
|
adamc@764
|
13 * derived from this software without specific prior written permission.
|
adamc@764
|
14 *
|
adamc@764
|
15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
|
adamc@764
|
16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
adamc@764
|
17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
adamc@764
|
18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
|
rmbruijn@1597
|
19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
adamc@764
|
20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
adamc@764
|
21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
adamc@764
|
22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
adamc@764
|
23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
adamc@764
|
24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
adamc@764
|
25 * POSSIBILITY OF SUCH DAMAGE.
|
adamc@764
|
26 *)
|
adamc@764
|
27
|
adamc@764
|
28 structure Settings :> SETTINGS = struct
|
adamc@764
|
29
|
ezyang@1739
|
30 val configBin = ref Config.bin
|
ezyang@1739
|
31 val configLib = ref Config.lib
|
ezyang@1739
|
32 val configSrcLib = ref Config.srclib
|
ezyang@1739
|
33 val configInclude = ref Config.includ
|
ezyang@1739
|
34 val configSitelisp = ref Config.sitelisp
|
ezyang@1739
|
35
|
grrwlf@1871
|
36 val configCCompiler = ref Config.ccompiler
|
grrwlf@1871
|
37
|
grrwlf@1871
|
38 fun getCCompiler () = !configCCompiler
|
grrwlf@1871
|
39 fun setCCompiler cc = configCCompiler := cc
|
grrwlf@1871
|
40
|
ezyang@1739
|
41 fun libUr () = OS.Path.joinDirFile {dir = !configSrcLib,
|
ezyang@1739
|
42 file = "ur"}
|
ezyang@1739
|
43 fun libC () = OS.Path.joinDirFile {dir = !configSrcLib,
|
ezyang@1739
|
44 file = "c"}
|
ezyang@1739
|
45 fun libJs () = OS.Path.joinDirFile {dir = !configSrcLib,
|
ezyang@1739
|
46 file = "js"}
|
ezyang@1739
|
47
|
ezyang@1739
|
48 fun libFile s = OS.Path.joinDirFile {dir = libUr (),
|
ezyang@1739
|
49 file = s}
|
ezyang@1739
|
50
|
adam@1637
|
51 val urlPrefixFull = ref "/"
|
adamc@764
|
52 val urlPrefix = ref "/"
|
adam@1370
|
53 val urlPrePrefix = ref ""
|
adamc@764
|
54 val timeout = ref 0
|
adamc@764
|
55 val headers = ref ([] : string list)
|
adamc@766
|
56 val scripts = ref ([] : string list)
|
adamc@764
|
57
|
adam@1637
|
58 fun getUrlPrefixFull () = !urlPrefixFull
|
adamc@764
|
59 fun getUrlPrefix () = !urlPrefix
|
adam@1370
|
60 fun getUrlPrePrefix () = !urlPrePrefix
|
adamc@764
|
61 fun setUrlPrefix p =
|
adam@1370
|
62 let
|
adam@1370
|
63 val prefix = if p = "" then
|
adam@1370
|
64 "/"
|
adam@1370
|
65 else if String.sub (p, size p - 1) <> #"/" then
|
adam@1370
|
66 p ^ "/"
|
adam@1370
|
67 else
|
adam@1370
|
68 p
|
adam@1370
|
69
|
adam@1470
|
70 fun findPrefix n =
|
adam@1470
|
71 let
|
adam@1470
|
72 val (befor, after) = Substring.splitl (fn ch => ch <> #"/") (Substring.extract (prefix, n, NONE))
|
adam@1470
|
73 in
|
adam@1470
|
74 if Substring.isEmpty after then
|
adam@1470
|
75 ("", prefix)
|
adam@1470
|
76 else
|
adam@1470
|
77 (String.substring (prefix, 0, n) ^ Substring.string befor, Substring.string after)
|
rmbruijn@1597
|
78 end
|
adam@1470
|
79
|
adam@1370
|
80 val (prepre, prefix) =
|
adam@1370
|
81 if String.isPrefix "http://" prefix then
|
adam@1470
|
82 findPrefix 7
|
adam@1470
|
83 else if String.isPrefix "https://" prefix then
|
adam@1470
|
84 findPrefix 8
|
adam@1370
|
85 else
|
adam@1370
|
86 ("", prefix)
|
adam@1370
|
87 in
|
adam@1637
|
88 urlPrefixFull := p;
|
adam@1370
|
89 urlPrePrefix := prepre;
|
adam@1370
|
90 urlPrefix := prefix
|
adam@1370
|
91 end
|
adamc@764
|
92
|
adamc@764
|
93 fun getTimeout () = !timeout
|
adamc@764
|
94 fun setTimeout n = timeout := n
|
adamc@764
|
95
|
adamc@764
|
96 fun getHeaders () = !headers
|
adamc@764
|
97 fun setHeaders ls = headers := ls
|
adamc@764
|
98
|
adamc@766
|
99 fun getScripts () = !scripts
|
adamc@766
|
100 fun setScripts ls = scripts := ls
|
adamc@766
|
101
|
adamc@765
|
102 type ffi = string * string
|
adamc@765
|
103
|
adamc@765
|
104 structure K = struct
|
adamc@765
|
105 type ord_key = ffi
|
adamc@765
|
106 fun compare ((m1, x1), (m2, x2)) =
|
adamc@765
|
107 Order.join (String.compare (m1, m2),
|
adamc@765
|
108 fn () => String.compare (x1, x2))
|
adamc@764
|
109 end
|
adamc@765
|
110
|
adamc@765
|
111 structure S = BinarySetFn(K)
|
adamc@765
|
112 structure M = BinaryMapFn(K)
|
adamc@765
|
113
|
adamc@765
|
114 fun basis x = S.addList (S.empty, map (fn x : string => ("Basis", x)) x)
|
adamc@765
|
115
|
adamc@765
|
116 val clientToServerBase = basis ["int",
|
adamc@765
|
117 "float",
|
adamc@765
|
118 "string",
|
adamc@765
|
119 "time",
|
adamc@765
|
120 "file",
|
adamc@765
|
121 "unit",
|
adamc@765
|
122 "option",
|
adamc@765
|
123 "list",
|
adam@1288
|
124 "bool",
|
adam@1288
|
125 "variant"]
|
adamc@765
|
126 val clientToServer = ref clientToServerBase
|
adamc@765
|
127 fun setClientToServer ls = clientToServer := S.addList (clientToServerBase, ls)
|
adamc@765
|
128 fun mayClientToServer x = S.member (!clientToServer, x)
|
adamc@765
|
129
|
adamc@779
|
130 val effectfulBase = basis ["dml",
|
adamc@779
|
131 "nextval",
|
adamc@1073
|
132 "setval",
|
adamc@779
|
133 "set_cookie",
|
adamc@1050
|
134 "clear_cookie",
|
adamc@765
|
135 "new_channel",
|
adamc@1200
|
136 "send",
|
adamc@1200
|
137 "htmlifyInt_w",
|
adamc@1200
|
138 "htmlifyFloat_w",
|
adamc@1200
|
139 "htmlifyString_w",
|
adamc@1200
|
140 "htmlifyBool_w",
|
adamc@1200
|
141 "htmlifyTime_w",
|
adamc@1200
|
142 "attrifyInt_w",
|
adamc@1200
|
143 "attrifyFloat_w",
|
adamc@1200
|
144 "attrifyString_w",
|
adamc@1200
|
145 "attrifyChar_w",
|
adamc@1200
|
146 "urlifyInt_w",
|
adamc@1200
|
147 "urlifyFloat_w",
|
adamc@1200
|
148 "urlifyString_w",
|
adamc@1200
|
149 "urlifyBool_w",
|
adamc@1200
|
150 "urlifyChannel_w"]
|
adamc@765
|
151
|
adamc@765
|
152 val effectful = ref effectfulBase
|
adamc@765
|
153 fun setEffectful ls = effectful := S.addList (effectfulBase, ls)
|
adamc@765
|
154 fun isEffectful x = S.member (!effectful, x)
|
adamc@765
|
155
|
adamc@1171
|
156 val benignBase = basis ["get_cookie",
|
adamc@1171
|
157 "new_client_source",
|
adamc@1171
|
158 "get_client_source",
|
adamc@1171
|
159 "set_client_source",
|
adamc@1171
|
160 "current",
|
adamc@1171
|
161 "alert",
|
adam@1290
|
162 "confirm",
|
adamc@1171
|
163 "onError",
|
adamc@1171
|
164 "onFail",
|
adamc@1171
|
165 "onConnectFail",
|
adamc@1171
|
166 "onDisconnect",
|
adamc@1171
|
167 "onServerError",
|
adam@1783
|
168 "mouseEvent",
|
adam@1783
|
169 "keyEvent",
|
adamc@1250
|
170 "debug",
|
adam@1422
|
171 "rand",
|
adam@1465
|
172 "now",
|
adam@1465
|
173 "getHeader",
|
adam@1555
|
174 "setHeader",
|
adam@1555
|
175 "spawn",
|
adam@1555
|
176 "onClick",
|
adam@1555
|
177 "onDblclick",
|
adam@1555
|
178 "onKeydown",
|
adam@1555
|
179 "onKeypress",
|
adam@1555
|
180 "onKeyup",
|
adam@1555
|
181 "onMousedown",
|
adam@1791
|
182 "onMousemove",
|
adam@1791
|
183 "onMouseout",
|
adam@1791
|
184 "onMouseover",
|
adam@1556
|
185 "onMouseup",
|
adam@1559
|
186 "preventDefault",
|
adam@1559
|
187 "stopPropagation",
|
adam@1785
|
188 "fresh",
|
adam@1785
|
189 "giveFocus"]
|
adamc@1171
|
190
|
adamc@1171
|
191 val benign = ref benignBase
|
adamc@1171
|
192 fun setBenignEffectful ls = benign := S.addList (benignBase, ls)
|
adamc@1171
|
193 fun isBenignEffectful x = S.member (!benign, x)
|
adamc@1171
|
194
|
adam@1595
|
195 val clientBase = basis ["get_client_source",
|
adamc@841
|
196 "current",
|
adamc@765
|
197 "alert",
|
adam@1290
|
198 "confirm",
|
adamc@765
|
199 "recv",
|
adamc@765
|
200 "sleep",
|
adamc@765
|
201 "spawn",
|
adamc@765
|
202 "onError",
|
adamc@765
|
203 "onFail",
|
adamc@765
|
204 "onConnectFail",
|
adamc@765
|
205 "onDisconnect",
|
adamc@895
|
206 "onServerError",
|
adam@1783
|
207 "mouseEvent",
|
adam@1783
|
208 "keyEvent",
|
adam@1555
|
209 "onClick",
|
adam@1555
|
210 "onDblclick",
|
adam@1555
|
211 "onKeydown",
|
adam@1555
|
212 "onKeypress",
|
adam@1555
|
213 "onKeyup",
|
adam@1555
|
214 "onMousedown",
|
adam@1791
|
215 "onMousemove",
|
adam@1791
|
216 "onMouseout",
|
adam@1791
|
217 "onMouseover",
|
adam@1559
|
218 "onMouseup",
|
adam@1559
|
219 "preventDefault",
|
adam@1785
|
220 "stopPropagation",
|
adam@1785
|
221 "giveFocus"]
|
adamc@765
|
222 val client = ref clientBase
|
adamc@765
|
223 fun setClientOnly ls = client := S.addList (clientBase, ls)
|
adamc@765
|
224 fun isClientOnly x = S.member (!client, x)
|
adamc@765
|
225
|
adamc@765
|
226 val serverBase = basis ["requestHeader",
|
adamc@765
|
227 "query",
|
adamc@765
|
228 "dml",
|
adamc@765
|
229 "nextval",
|
adamc@1073
|
230 "setval",
|
adamc@765
|
231 "channel",
|
adam@1787
|
232 "send",
|
adam@1787
|
233 "fieldName",
|
adam@1787
|
234 "fieldValue",
|
adam@1787
|
235 "remainingFields",
|
adam@1787
|
236 "firstFormField"]
|
adamc@765
|
237 val server = ref serverBase
|
adamc@765
|
238 fun setServerOnly ls = server := S.addList (serverBase, ls)
|
adamc@765
|
239 fun isServerOnly x = S.member (!server, x)
|
adamc@765
|
240
|
adamc@765
|
241 val basisM = foldl (fn ((k, v : string), m) => M.insert (m, ("Basis", k), v)) M.empty
|
adamc@765
|
242
|
adamc@765
|
243 val jsFuncsBase = basisM [("alert", "alert"),
|
adam@1599
|
244 ("stringToTime", "stringToTime"),
|
adam@1599
|
245 ("stringToTime_error", "stringToTime_error"),
|
adam@1609
|
246 ("timef", "strftime"),
|
adam@1290
|
247 ("confirm", "confrm"),
|
adamc@765
|
248 ("get_client_source", "sg"),
|
adamc@841
|
249 ("current", "scur"),
|
adamc@765
|
250 ("htmlifyBool", "bs"),
|
adamc@765
|
251 ("htmlifyFloat", "ts"),
|
adamc@765
|
252 ("htmlifyInt", "ts"),
|
adamc@765
|
253 ("htmlifyString", "eh"),
|
adamc@765
|
254 ("new_client_source", "sc"),
|
adamc@765
|
255 ("set_client_source", "sv"),
|
adamc@838
|
256 ("stringToFloat", "pflo"),
|
adamc@838
|
257 ("stringToInt", "pio"),
|
adamc@765
|
258 ("stringToFloat_error", "pfl"),
|
adamc@765
|
259 ("stringToInt_error", "pi"),
|
adamc@765
|
260 ("urlifyInt", "ts"),
|
adamc@765
|
261 ("urlifyFloat", "ts"),
|
adam@1360
|
262 ("urlifyTime", "ts"),
|
adamc@765
|
263 ("urlifyString", "uf"),
|
adamc@912
|
264 ("urlifyBool", "ub"),
|
adamc@765
|
265 ("recv", "rv"),
|
adamc@765
|
266 ("strcat", "cat"),
|
adamc@765
|
267 ("intToString", "ts"),
|
adamc@765
|
268 ("floatToString", "ts"),
|
adamc@821
|
269 ("charToString", "ts"),
|
adamc@765
|
270 ("onError", "onError"),
|
adamc@765
|
271 ("onFail", "onFail"),
|
adamc@765
|
272 ("onConnectFail", "onConnectFail"),
|
adamc@765
|
273 ("onDisconnect", "onDisconnect"),
|
adamc@798
|
274 ("onServerError", "onServerError"),
|
adamc@1108
|
275 ("attrifyString", "atr"),
|
adamc@798
|
276 ("attrifyInt", "ts"),
|
adamc@798
|
277 ("attrifyFloat", "ts"),
|
adamc@820
|
278 ("attrifyBool", "bs"),
|
adamc@821
|
279 ("boolToString", "ts"),
|
adamc@1057
|
280 ("str1", "id"),
|
adamc@821
|
281 ("strsub", "sub"),
|
adamc@828
|
282 ("strsuffix", "suf"),
|
adamc@829
|
283 ("strlen", "slen"),
|
adamc@829
|
284 ("strindex", "sidx"),
|
adamc@829
|
285 ("strchr", "schr"),
|
adamc@831
|
286 ("substring", "ssub"),
|
adamc@895
|
287 ("strcspn", "sspn"),
|
adam@1624
|
288 ("strlenGe", "strlenGe"),
|
adam@1783
|
289 ("mouseEvent", "uw_mouseEvent"),
|
adam@1783
|
290 ("keyEvent", "uw_keyEvent"),
|
adam@1404
|
291 ("minTime", "0"),
|
adamc@1061
|
292
|
adamc@1061
|
293 ("islower", "isLower"),
|
adamc@1061
|
294 ("isupper", "isUpper"),
|
adamc@1061
|
295 ("isalpha", "isAlpha"),
|
adamc@1061
|
296 ("isdigit", "isDigit"),
|
adamc@1061
|
297 ("isalnum", "isAlnum"),
|
adamc@1061
|
298 ("isblank", "isBlank"),
|
adamc@1061
|
299 ("isspace", "isSpace"),
|
adamc@1061
|
300 ("isxdigit", "isXdigit"),
|
adamc@1061
|
301 ("tolower", "toLower"),
|
adamc@1323
|
302 ("toupper", "toUpper"),
|
adamc@1323
|
303
|
adamc@1323
|
304 ("checkUrl", "checkUrl"),
|
adam@1366
|
305 ("bless", "bless"),
|
adam@1366
|
306
|
adam@1366
|
307 ("eq_time", "eq"),
|
adam@1366
|
308 ("lt_time", "lt"),
|
adam@1430
|
309 ("le_time", "le"),
|
adam@1430
|
310
|
adam@1625
|
311 ("debug", "uw_debug"),
|
adam@1625
|
312 ("naughtyDebug", "uw_debug"),
|
adam@1487
|
313
|
adam@1571
|
314 ("floatFromInt", "float"),
|
adam@1571
|
315 ("ceil", "ceil"),
|
adam@1571
|
316 ("trunc", "trunc"),
|
adam@1571
|
317 ("round", "round"),
|
adam@1571
|
318
|
adam@1487
|
319 ("now", "now"),
|
adam@1487
|
320 ("timeToString", "showTime"),
|
adam@1629
|
321 ("htmlifyTime", "showTimeHtml"),
|
adam@1514
|
322 ("toSeconds", "toSeconds"),
|
adam@1518
|
323 ("addSeconds", "addSeconds"),
|
adam@1555
|
324 ("diffInSeconds", "diffInSeconds"),
|
adam@1685
|
325 ("toMilliseconds", "toMilliseconds"),
|
adam@1685
|
326 ("diffInMilliseconds", "diffInMilliseconds"),
|
adam@1555
|
327
|
adam@1555
|
328 ("onClick", "uw_onClick"),
|
adam@1555
|
329 ("onDblclick", "uw_onDblclick"),
|
adam@1555
|
330 ("onKeydown", "uw_onKeydown"),
|
adam@1555
|
331 ("onKeypress", "uw_onKeypress"),
|
adam@1555
|
332 ("onKeyup", "uw_onKeyup"),
|
adam@1555
|
333 ("onMousedown", "uw_onMousedown"),
|
adam@1791
|
334 ("onMousemove", "uw_onMousemove"),
|
adam@1791
|
335 ("onMouseout", "uw_onMouseout"),
|
adam@1791
|
336 ("onMouseover", "uw_onMouseover"),
|
adam@1556
|
337 ("onMouseup", "uw_onMouseup"),
|
adam@1559
|
338 ("preventDefault", "uw_preventDefault"),
|
adam@1559
|
339 ("stopPropagation", "uw_stopPropagation"),
|
adam@1556
|
340
|
adam@1755
|
341 ("fresh", "fresh"),
|
adam@1755
|
342
|
adam@1755
|
343 ("atom", "atom"),
|
adam@1755
|
344 ("css_url", "css_url"),
|
adam@1785
|
345 ("property", "property"),
|
adam@1785
|
346 ("giveFocus", "giveFocus")]
|
adamc@765
|
347 val jsFuncs = ref jsFuncsBase
|
adamc@765
|
348 fun setJsFuncs ls = jsFuncs := foldl (fn ((k, v), m) => M.insert (m, k, v)) jsFuncsBase ls
|
adamc@765
|
349 fun jsFunc x = M.find (!jsFuncs, x)
|
adam@1433
|
350 fun allJsFuncs () = M.listItemsi (!jsFuncs)
|
adamc@765
|
351
|
adamc@768
|
352 datatype pattern_kind = Exact | Prefix
|
adamc@768
|
353 datatype action = Allow | Deny
|
adamc@768
|
354 type rule = { action : action, kind : pattern_kind, pattern : string }
|
adamc@768
|
355
|
adamc@768
|
356 datatype path_kind = Any | Url | Table | Sequence | View | Relation | Cookie | Style
|
adam@1752
|
357 type rewrite = { pkind : path_kind, kind : pattern_kind, from : string, to : string, hyphenate : bool }
|
adamc@768
|
358
|
adamc@768
|
359 val rewrites = ref ([] : rewrite list)
|
adamc@768
|
360
|
adamc@768
|
361 fun subsume (pk1, pk2) =
|
adamc@768
|
362 pk1 = pk2
|
adamc@768
|
363 orelse pk2 = Any
|
adamc@768
|
364 orelse pk2 = Relation andalso (pk1 = Table orelse pk1 = Sequence orelse pk1 = View)
|
adamc@768
|
365
|
adamc@768
|
366 fun setRewriteRules ls = rewrites := ls
|
adamc@768
|
367 fun rewrite pk s =
|
adamc@768
|
368 let
|
adamc@768
|
369 fun rew (ls : rewrite list) =
|
adamc@768
|
370 case ls of
|
adamc@768
|
371 [] => s
|
adamc@768
|
372 | rewr :: ls =>
|
adamc@768
|
373 let
|
adamc@768
|
374 fun match () =
|
adamc@768
|
375 case #kind rewr of
|
adamc@768
|
376 Exact => if #from rewr = s then
|
adamc@768
|
377 SOME (size s)
|
adamc@768
|
378 else
|
adamc@768
|
379 NONE
|
adamc@768
|
380 | Prefix => if String.isPrefix (#from rewr) s then
|
adamc@768
|
381 SOME (size (#from rewr))
|
adamc@768
|
382 else
|
adamc@768
|
383 NONE
|
adamc@768
|
384 in
|
adamc@768
|
385 if subsume (pk, #pkind rewr) then
|
adamc@768
|
386 case match () of
|
adamc@768
|
387 NONE => rew ls
|
adam@1752
|
388 | SOME suffixStart =>
|
adam@1752
|
389 let
|
adam@1752
|
390 val s = #to rewr ^ String.extract (s, suffixStart, NONE)
|
adam@1752
|
391 in
|
adam@1752
|
392 if #hyphenate rewr then
|
adam@1752
|
393 String.translate (fn #"_" => "-" | ch => str ch) s
|
adam@1752
|
394 else
|
adam@1752
|
395 s
|
adam@1752
|
396 end
|
adamc@768
|
397 else
|
adamc@768
|
398 rew ls
|
adamc@768
|
399 end
|
adamc@768
|
400 in
|
adamc@768
|
401 rew (!rewrites)
|
adamc@768
|
402 end
|
adamc@768
|
403
|
adamc@769
|
404 val url = ref ([] : rule list)
|
adamc@769
|
405 val mime = ref ([] : rule list)
|
adam@1465
|
406 val request = ref ([] : rule list)
|
adam@1465
|
407 val response = ref ([] : rule list)
|
adam@1799
|
408 val env = ref ([] : rule list)
|
adamc@769
|
409
|
adamc@769
|
410 fun setUrlRules ls = url := ls
|
adamc@769
|
411 fun setMimeRules ls = mime := ls
|
adam@1465
|
412 fun setRequestHeaderRules ls = request := ls
|
adam@1465
|
413 fun setResponseHeaderRules ls = response := ls
|
adam@1799
|
414 fun setEnvVarRules ls = env := ls
|
adamc@769
|
415
|
adamc@770
|
416 fun getUrlRules () = !url
|
adamc@770
|
417 fun getMimeRules () = !mime
|
adam@1465
|
418 fun getRequestHeaderRules () = !request
|
adam@1465
|
419 fun getResponseHeaderRules () = !response
|
adam@1799
|
420 fun getEnvVarRules () = !env
|
adamc@770
|
421
|
adamc@769
|
422 fun check f rules s =
|
adamc@769
|
423 let
|
adamc@769
|
424 fun chk (ls : rule list) =
|
adamc@769
|
425 case ls of
|
adamc@769
|
426 [] => false
|
adamc@769
|
427 | rule :: ls =>
|
adamc@769
|
428 let
|
adamc@769
|
429 val matches =
|
adamc@769
|
430 case #kind rule of
|
adamc@769
|
431 Exact => #pattern rule = s
|
adamc@769
|
432 | Prefix => String.isPrefix (#pattern rule) s
|
adamc@769
|
433 in
|
adamc@769
|
434 if matches then
|
adamc@769
|
435 case #action rule of
|
adamc@769
|
436 Allow => true
|
adamc@769
|
437 | Deny => false
|
adamc@769
|
438 else
|
adamc@769
|
439 chk ls
|
adamc@769
|
440 end
|
adamc@769
|
441 in
|
adamc@769
|
442 f s andalso chk (!rules)
|
adamc@769
|
443 end
|
adamc@769
|
444
|
adamc@769
|
445 val checkUrl = check (fn _ => true) url
|
adam@1465
|
446
|
adam@1465
|
447 val validMime = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"/" orelse ch = #"-" orelse ch = #".")
|
adam@1799
|
448 val validEnv = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"_" orelse ch = #".")
|
adam@1465
|
449
|
adam@1465
|
450 val checkMime = check validMime mime
|
adam@1465
|
451 val checkRequestHeader = check validMime request
|
adam@1465
|
452 val checkResponseHeader = check validMime response
|
adam@1799
|
453 val checkEnvVar = check validEnv env
|
adamc@769
|
454
|
adamc@855
|
455
|
adamc@855
|
456 type protocol = {
|
adamc@855
|
457 name : string,
|
adamc@1096
|
458 compile : string,
|
adamc@1095
|
459 linkStatic : string,
|
adamc@1095
|
460 linkDynamic : string,
|
adamc@1164
|
461 persistent : bool,
|
adamc@1164
|
462 code : unit -> Print.PD.pp_desc
|
adamc@855
|
463 }
|
adamc@855
|
464 val protocols = ref ([] : protocol list)
|
adamc@855
|
465 fun addProtocol p = protocols := p :: !protocols
|
adamc@855
|
466 fun getProtocol s = List.find (fn p => #name p = s) (!protocols)
|
adamc@855
|
467
|
ezyang@1739
|
468 fun clibFile s = OS.Path.joinDirFile {dir = libC (),
|
adamc@855
|
469 file = s}
|
adamc@855
|
470
|
adamc@865
|
471 val curProto = ref {name = "",
|
adamc@1096
|
472 compile = "",
|
adamc@1095
|
473 linkStatic = "",
|
adamc@1095
|
474 linkDynamic = "",
|
adamc@1164
|
475 persistent = false,
|
adamc@1164
|
476 code = fn () => Print.box []}
|
adamc@856
|
477 fun setProtocol name =
|
adamc@856
|
478 case getProtocol name of
|
adamc@856
|
479 NONE => raise Fail ("Unknown protocol " ^ name)
|
adamc@856
|
480 | SOME p => curProto := p
|
adamc@855
|
481 fun currentProtocol () = !curProto
|
adamc@855
|
482
|
adamc@857
|
483 val debug = ref false
|
adamc@857
|
484 fun setDebug b = debug := b
|
adamc@857
|
485 fun getDebug () = !debug
|
adamc@857
|
486
|
adamc@867
|
487 datatype sql_type =
|
adamc@867
|
488 Int
|
adamc@867
|
489 | Float
|
adamc@867
|
490 | String
|
adamc@1011
|
491 | Char
|
adamc@867
|
492 | Bool
|
adamc@867
|
493 | Time
|
adamc@867
|
494 | Blob
|
adamc@867
|
495 | Channel
|
adamc@867
|
496 | Client
|
adamc@867
|
497 | Nullable of sql_type
|
adamc@867
|
498
|
adamc@873
|
499 fun p_sql_ctype t =
|
adamc@867
|
500 let
|
adamc@867
|
501 open Print.PD
|
adamc@867
|
502 open Print
|
adamc@867
|
503 in
|
adamc@867
|
504 case t of
|
adamc@870
|
505 Int => "uw_Basis_int"
|
adamc@870
|
506 | Float => "uw_Basis_float"
|
adamc@870
|
507 | String => "uw_Basis_string"
|
adamc@1011
|
508 | Char => "uw_Basis_char"
|
adamc@870
|
509 | Bool => "uw_Basis_bool"
|
adamc@870
|
510 | Time => "uw_Basis_time"
|
adamc@870
|
511 | Blob => "uw_Basis_blob"
|
adamc@870
|
512 | Channel => "uw_Basis_channel"
|
adamc@870
|
513 | Client => "uw_Basis_client"
|
adamc@870
|
514 | Nullable String => "uw_Basis_string"
|
adamc@873
|
515 | Nullable t => p_sql_ctype t ^ "*"
|
adamc@867
|
516 end
|
adamc@867
|
517
|
adamc@867
|
518 fun isBlob Blob = true
|
adamc@867
|
519 | isBlob (Nullable t) = isBlob t
|
adamc@867
|
520 | isBlob _ = false
|
adamc@867
|
521
|
adamc@870
|
522 fun isNotNull (Nullable _) = false
|
adamc@870
|
523 | isNotNull _ = true
|
adamc@870
|
524
|
adam@1293
|
525 datatype failure_mode = Error | None
|
adam@1293
|
526
|
adamc@866
|
527 type dbms = {
|
adamc@866
|
528 name : string,
|
adam@1682
|
529 randomFunction : string,
|
adamc@866
|
530 header : string,
|
adamc@866
|
531 link : string,
|
adamc@873
|
532 p_sql_type : sql_type -> string,
|
adamc@870
|
533 init : {dbstring : string,
|
adamc@870
|
534 prepared : (string * int) list,
|
adamc@870
|
535 tables : (string * (string * sql_type) list) list,
|
adamc@872
|
536 views : (string * (string * sql_type) list) list,
|
adamc@870
|
537 sequences : string list} -> Print.PD.pp_desc,
|
adamc@873
|
538 query : {loc : ErrorMsg.span, cols : sql_type list,
|
adamc@880
|
539 doCols : ({loc : ErrorMsg.span, wontLeakStrings : bool, col : int, typ : sql_type} -> Print.PD.pp_desc)
|
adamc@867
|
540 -> Print.PD.pp_desc}
|
adamc@867
|
541 -> Print.PD.pp_desc,
|
adamc@867
|
542 queryPrepared : {loc : ErrorMsg.span, id : int, query : string,
|
adamc@873
|
543 inputs : sql_type list, cols : sql_type list,
|
adamc@880
|
544 doCols : ({loc : ErrorMsg.span, wontLeakStrings : bool, col : int,
|
adamc@880
|
545 typ : sql_type} -> Print.PD.pp_desc)
|
adamc@879
|
546 -> Print.PD.pp_desc,
|
adamc@879
|
547 nested : bool}
|
adamc@868
|
548 -> Print.PD.pp_desc,
|
adam@1293
|
549 dml : ErrorMsg.span * failure_mode -> Print.PD.pp_desc,
|
adamc@868
|
550 dmlPrepared : {loc : ErrorMsg.span, id : int, dml : string,
|
adam@1293
|
551 inputs : sql_type list, mode : failure_mode} -> Print.PD.pp_desc,
|
adamc@878
|
552 nextval : {loc : ErrorMsg.span, seqName : string option, seqE : Print.PD.pp_desc} -> Print.PD.pp_desc,
|
adamc@874
|
553 nextvalPrepared : {loc : ErrorMsg.span, id : int, query : string} -> Print.PD.pp_desc,
|
adamc@1073
|
554 setval : {loc : ErrorMsg.span, seqE : Print.PD.pp_desc, count : Print.PD.pp_desc} -> Print.PD.pp_desc,
|
adamc@874
|
555 sqlifyString : string -> string,
|
adamc@874
|
556 p_cast : string * sql_type -> string,
|
adamc@874
|
557 p_blank : int * sql_type -> string,
|
adamc@877
|
558 supportsDeleteAs : bool,
|
adamc@886
|
559 supportsUpdateAs : bool,
|
adamc@877
|
560 createSequence : string -> string,
|
adamc@878
|
561 textKeysNeedLengths : bool,
|
adamc@879
|
562 supportsNextval : bool,
|
adamc@882
|
563 supportsNestedPrepared : bool,
|
adamc@890
|
564 sqlPrefix : string,
|
adamc@1014
|
565 supportsOctetLength : bool,
|
adamc@1014
|
566 trueString : string,
|
adamc@1196
|
567 falseString : string,
|
adamc@1196
|
568 onlyUnion : bool,
|
adam@1777
|
569 nestedRelops : bool,
|
adam@1778
|
570 windowFunctions: bool
|
adamc@866
|
571 }
|
adamc@866
|
572
|
adamc@866
|
573 val dbmses = ref ([] : dbms list)
|
adamc@866
|
574 val curDb = ref ({name = "",
|
adam@1682
|
575 randomFunction = "",
|
adamc@866
|
576 header = "",
|
adamc@866
|
577 link = "",
|
adamc@873
|
578 p_sql_type = fn _ => "",
|
adamc@867
|
579 init = fn _ => Print.box [],
|
adamc@867
|
580 query = fn _ => Print.box [],
|
adamc@868
|
581 queryPrepared = fn _ => Print.box [],
|
adamc@868
|
582 dml = fn _ => Print.box [],
|
adamc@869
|
583 dmlPrepared = fn _ => Print.box [],
|
adamc@869
|
584 nextval = fn _ => Print.box [],
|
adamc@874
|
585 nextvalPrepared = fn _ => Print.box [],
|
adamc@1073
|
586 setval = fn _ => Print.box [],
|
adamc@874
|
587 sqlifyString = fn s => s,
|
adamc@874
|
588 p_cast = fn _ => "",
|
adamc@874
|
589 p_blank = fn _ => "",
|
adamc@877
|
590 supportsDeleteAs = false,
|
adamc@886
|
591 supportsUpdateAs = false,
|
adamc@877
|
592 createSequence = fn _ => "",
|
adamc@878
|
593 textKeysNeedLengths = false,
|
adamc@879
|
594 supportsNextval = false,
|
adamc@882
|
595 supportsNestedPrepared = false,
|
adamc@890
|
596 sqlPrefix = "",
|
adamc@1014
|
597 supportsOctetLength = false,
|
adamc@1014
|
598 trueString = "",
|
adamc@1196
|
599 falseString = "",
|
adamc@1196
|
600 onlyUnion = false,
|
adam@1777
|
601 nestedRelops = false,
|
adam@1777
|
602 windowFunctions = false} : dbms)
|
adamc@866
|
603
|
adamc@866
|
604 fun addDbms v = dbmses := v :: !dbmses
|
adamc@866
|
605 fun setDbms s =
|
adamc@866
|
606 case List.find (fn db => #name db = s) (!dbmses) of
|
adamc@866
|
607 NONE => raise Fail ("Unknown DBMS " ^ s)
|
adamc@866
|
608 | SOME db => curDb := db
|
adamc@866
|
609 fun currentDbms () = !curDb
|
adamc@866
|
610
|
adamc@891
|
611 val dbstring = ref (NONE : string option)
|
adamc@891
|
612 fun setDbstring so = dbstring := so
|
adamc@891
|
613 fun getDbstring () = !dbstring
|
adamc@891
|
614
|
adamc@891
|
615 val exe = ref (NONE : string option)
|
adamc@891
|
616 fun setExe so = exe := so
|
adamc@891
|
617 fun getExe () = !exe
|
adamc@891
|
618
|
adamc@891
|
619 val sql = ref (NONE : string option)
|
adamc@891
|
620 fun setSql so = sql := so
|
adamc@891
|
621 fun getSql () = !sql
|
adamc@891
|
622
|
adam@1820
|
623 val coreInline = ref 5
|
adamc@1016
|
624 fun setCoreInline n = coreInline := n
|
adamc@1016
|
625 fun getCoreInline () = !coreInline
|
adamc@1016
|
626
|
adam@1820
|
627 val monoInline = ref 5
|
adamc@1016
|
628 fun setMonoInline n = monoInline := n
|
adamc@1016
|
629 fun getMonoInline () = !monoInline
|
adamc@1016
|
630
|
adamc@1095
|
631 val staticLinking = ref false
|
adamc@1095
|
632 fun setStaticLinking b = staticLinking := b
|
adamc@1095
|
633 fun getStaticLinking () = !staticLinking
|
adamc@1095
|
634
|
adamc@1114
|
635 val deadlines = ref false
|
adamc@1114
|
636 fun setDeadlines b = deadlines := b
|
adamc@1114
|
637 fun getDeadlines () = !deadlines
|
adamc@1114
|
638
|
adamc@1164
|
639 val sigFile = ref (NONE : string option)
|
adamc@1164
|
640 fun setSigFile v = sigFile := v
|
adamc@1164
|
641 fun getSigFile () = !sigFile
|
adamc@1164
|
642
|
adamc@1183
|
643 structure SS = BinarySetFn(struct
|
adamc@1183
|
644 type ord_key = string
|
adamc@1183
|
645 val compare = String.compare
|
adamc@1183
|
646 end)
|
adamc@1183
|
647
|
adamc@1183
|
648 val safeGet = ref SS.empty
|
adamc@1183
|
649 fun setSafeGets ls = safeGet := SS.addList (SS.empty, ls)
|
adamc@1183
|
650 fun isSafeGet x = SS.member (!safeGet, x)
|
adamc@1183
|
651
|
adam@1294
|
652 val onError = ref (NONE : (string * string list * string) option)
|
adam@1294
|
653 fun setOnError x = onError := x
|
adam@1294
|
654 fun getOnError () = !onError
|
adam@1294
|
655
|
adam@1307
|
656 val limits = ["messages", "clients", "headers", "page", "heap", "script",
|
adam@1307
|
657 "inputs", "subinputs", "cleanup", "deltas", "transactionals",
|
adam@1308
|
658 "globals", "database", "time"]
|
adam@1307
|
659
|
adam@1307
|
660 val limitsList = ref ([] : (string * int) list)
|
adam@1307
|
661 fun addLimit (v as (name, _)) =
|
adam@1307
|
662 if List.exists (fn name' => name' = name) limits then
|
adam@1308
|
663 (limitsList := v :: !limitsList;
|
adam@1308
|
664 if name = "time" then
|
adam@1308
|
665 setDeadlines true
|
adam@1308
|
666 else
|
adam@1308
|
667 ())
|
adam@1307
|
668 else
|
adam@1307
|
669 raise Fail ("Unknown limit category '" ^ name ^ "'")
|
adam@1307
|
670 fun limits () = !limitsList
|
adam@1307
|
671
|
adam@1332
|
672 val minHeap = ref 0
|
adam@1332
|
673 fun setMinHeap n = if n >= 0 then minHeap := n else raise Fail "Trying to set negative minHeap"
|
adam@1332
|
674 fun getMinHeap () = !minHeap
|
adam@1332
|
675
|
adam@1393
|
676 structure SS = BinarySetFn(struct
|
adam@1393
|
677 type ord_key = string
|
adam@1393
|
678 val compare = String.compare
|
adam@1393
|
679 end)
|
adam@1393
|
680
|
adam@1393
|
681 val alwaysInline = ref SS.empty
|
adam@1393
|
682 fun addAlwaysInline s = alwaysInline := SS.add (!alwaysInline, s)
|
adam@1393
|
683 fun checkAlwaysInline s = SS.member (!alwaysInline, s)
|
adam@1393
|
684
|
adam@1478
|
685 val noXsrfProtection = ref SS.empty
|
adam@1478
|
686 fun addNoXsrfProtection s = noXsrfProtection := SS.add (!noXsrfProtection, s)
|
adam@1478
|
687 fun checkNoXsrfProtection s = SS.member (!noXsrfProtection, s)
|
adam@1478
|
688
|
adam@1629
|
689 val timeFormat = ref "%c"
|
adam@1629
|
690 fun setTimeFormat v = timeFormat := v
|
adam@1629
|
691 fun getTimeFormat () = !timeFormat
|
adam@1629
|
692
|
adamc@765
|
693 end
|