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