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