Mercurial > urweb

annotate src/settings.sml @ 1591:20f898c29525

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Tweaks to choices of source positions to use in error messages, including for subSgn
author Adam Chlipala <adam@chlipala.net>
date Sat, 05 Nov 2011 13:12:07 -0400
parents f403e129c276
children 154cfe2eb366
rev   line source
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@1571 273 ("floatFromInt", "float"),
adam@1571 274 ("ceil", "ceil"),
adam@1571 275 ("trunc", "trunc"),
adam@1571 276 ("round", "round"),
adam@1571 277
adam@1487 278 ("now", "now"),
adam@1487 279 ("timeToString", "showTime"),
adam@1514 280 ("htmlifyTime", "showTime"),
adam@1514 281 ("toSeconds", "toSeconds"),
adam@1518 282 ("addSeconds", "addSeconds"),
adam@1555 283 ("diffInSeconds", "diffInSeconds"),
adam@1555 284
adam@1555 285 ("onClick", "uw_onClick"),
adam@1555 286 ("onDblclick", "uw_onDblclick"),
adam@1555 287 ("onKeydown", "uw_onKeydown"),
adam@1555 288 ("onKeypress", "uw_onKeypress"),
adam@1555 289 ("onKeyup", "uw_onKeyup"),
adam@1555 290 ("onMousedown", "uw_onMousedown"),
adam@1556 291 ("onMouseup", "uw_onMouseup"),
adam@1559 292 ("preventDefault", "uw_preventDefault"),
adam@1559 293 ("stopPropagation", "uw_stopPropagation"),
adam@1556 294
adam@1556 295 ("fresh", "fresh")]
adamc@765 296 val jsFuncs = ref jsFuncsBase
adamc@765 297 fun setJsFuncs ls = jsFuncs := foldl (fn ((k, v), m) => M.insert (m, k, v)) jsFuncsBase ls
adamc@765 298 fun jsFunc x = M.find (!jsFuncs, x)
adam@1433 299 fun allJsFuncs () = M.listItemsi (!jsFuncs)
adamc@765 300
adamc@768 301 datatype pattern_kind = Exact | Prefix
adamc@768 302 datatype action = Allow | Deny
adamc@768 303 type rule = { action : action, kind : pattern_kind, pattern : string }
adamc@768 304
adamc@768 305 datatype path_kind = Any | Url | Table | Sequence | View | Relation | Cookie | Style
adamc@768 306 type rewrite = { pkind : path_kind, kind : pattern_kind, from : string, to : string }
adamc@768 307
adamc@768 308 val rewrites = ref ([] : rewrite list)
adamc@768 309
adamc@768 310 fun subsume (pk1, pk2) =
adamc@768 311 pk1 = pk2
adamc@768 312 orelse pk2 = Any
adamc@768 313 orelse pk2 = Relation andalso (pk1 = Table orelse pk1 = Sequence orelse pk1 = View)
adamc@768 314
adamc@768 315 fun setRewriteRules ls = rewrites := ls
adamc@768 316 fun rewrite pk s =
adamc@768 317 let
adamc@768 318 fun rew (ls : rewrite list) =
adamc@768 319 case ls of
adamc@768 320 [] => s
adamc@768 321 | rewr :: ls =>
adamc@768 322 let
adamc@768 323 fun match () =
adamc@768 324 case #kind rewr of
adamc@768 325 Exact => if #from rewr = s then
adamc@768 326 SOME (size s)
adamc@768 327 else
adamc@768 328 NONE
adamc@768 329 | Prefix => if String.isPrefix (#from rewr) s then
adamc@768 330 SOME (size (#from rewr))
adamc@768 331 else
adamc@768 332 NONE
adamc@768 333 in
adamc@768 334 if subsume (pk, #pkind rewr) then
adamc@768 335 case match () of
adamc@768 336 NONE => rew ls
adamc@768 337 | SOME suffixStart => #to rewr ^ String.extract (s, suffixStart, NONE)
adamc@768 338 else
adamc@768 339 rew ls
adamc@768 340 end
adamc@768 341 in
adamc@768 342 rew (!rewrites)
adamc@768 343 end
adamc@768 344
adamc@769 345 val url = ref ([] : rule list)
adamc@769 346 val mime = ref ([] : rule list)
adam@1465 347 val request = ref ([] : rule list)
adam@1465 348 val response = ref ([] : rule list)
adamc@769 349
adamc@769 350 fun setUrlRules ls = url := ls
adamc@769 351 fun setMimeRules ls = mime := ls
adam@1465 352 fun setRequestHeaderRules ls = request := ls
adam@1465 353 fun setResponseHeaderRules ls = response := ls
adamc@769 354
adamc@770 355 fun getUrlRules () = !url
adamc@770 356 fun getMimeRules () = !mime
adam@1465 357 fun getRequestHeaderRules () = !request
adam@1465 358 fun getResponseHeaderRules () = !response
adamc@770 359
adamc@769 360 fun check f rules s =
adamc@769 361 let
adamc@769 362 fun chk (ls : rule list) =
adamc@769 363 case ls of
adamc@769 364 [] => false
adamc@769 365 | rule :: ls =>
adamc@769 366 let
adamc@769 367 val matches =
adamc@769 368 case #kind rule of
adamc@769 369 Exact => #pattern rule = s
adamc@769 370 | Prefix => String.isPrefix (#pattern rule) s
adamc@769 371 in
adamc@769 372 if matches then
adamc@769 373 case #action rule of
adamc@769 374 Allow => true
adamc@769 375 | Deny => false
adamc@769 376 else
adamc@769 377 chk ls
adamc@769 378 end
adamc@769 379 in
adamc@769 380 f s andalso chk (!rules)
adamc@769 381 end
adamc@769 382
adamc@769 383 val checkUrl = check (fn _ => true) url
adam@1465 384
adam@1465 385 val validMime = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"/" orelse ch = #"-" orelse ch = #".")
adam@1465 386
adam@1465 387 val checkMime = check validMime mime
adam@1465 388 val checkRequestHeader = check validMime request
adam@1465 389 val checkResponseHeader = check validMime response
adamc@769 390
adamc@855 391
adamc@855 392 type protocol = {
adamc@855 393 name : string,
adamc@1096 394 compile : string,
adamc@1095 395 linkStatic : string,
adamc@1095 396 linkDynamic : string,
adamc@1164 397 persistent : bool,
adamc@1164 398 code : unit -> Print.PD.pp_desc
adamc@855 399 }
adamc@855 400 val protocols = ref ([] : protocol list)
adamc@855 401 fun addProtocol p = protocols := p :: !protocols
adamc@855 402 fun getProtocol s = List.find (fn p => #name p = s) (!protocols)
adamc@855 403
adamc@855 404 fun clibFile s = OS.Path.joinDirFile {dir = Config.libC,
adamc@855 405 file = s}
adamc@855 406
adamc@865 407 val curProto = ref {name = "",
adamc@1096 408 compile = "",
adamc@1095 409 linkStatic = "",
adamc@1095 410 linkDynamic = "",
adamc@1164 411 persistent = false,
adamc@1164 412 code = fn () => Print.box []}
adamc@856 413 fun setProtocol name =
adamc@856 414 case getProtocol name of
adamc@856 415 NONE => raise Fail ("Unknown protocol " ^ name)
adamc@856 416 | SOME p => curProto := p
adamc@855 417 fun currentProtocol () = !curProto
adamc@855 418
adamc@857 419 val debug = ref false
adamc@857 420 fun setDebug b = debug := b
adamc@857 421 fun getDebug () = !debug
adamc@857 422
adamc@867 423 datatype sql_type =
adamc@867 424 Int
adamc@867 425 | Float
adamc@867 426 | String
adamc@1011 427 | Char
adamc@867 428 | Bool
adamc@867 429 | Time
adamc@867 430 | Blob
adamc@867 431 | Channel
adamc@867 432 | Client
adamc@867 433 | Nullable of sql_type
adamc@867 434
adamc@873 435 fun p_sql_ctype t =
adamc@867 436 let
adamc@867 437 open Print.PD
adamc@867 438 open Print
adamc@867 439 in
adamc@867 440 case t of
adamc@870 441 Int => "uw_Basis_int"
adamc@870 442 | Float => "uw_Basis_float"
adamc@870 443 | String => "uw_Basis_string"
adamc@1011 444 | Char => "uw_Basis_char"
adamc@870 445 | Bool => "uw_Basis_bool"
adamc@870 446 | Time => "uw_Basis_time"
adamc@870 447 | Blob => "uw_Basis_blob"
adamc@870 448 | Channel => "uw_Basis_channel"
adamc@870 449 | Client => "uw_Basis_client"
adamc@870 450 | Nullable String => "uw_Basis_string"
adamc@873 451 | Nullable t => p_sql_ctype t ^ "*"
adamc@867 452 end
adamc@867 453
adamc@867 454 fun isBlob Blob = true
adamc@867 455 | isBlob (Nullable t) = isBlob t
adamc@867 456 | isBlob _ = false
adamc@867 457
adamc@870 458 fun isNotNull (Nullable _) = false
adamc@870 459 | isNotNull _ = true
adamc@870 460
adam@1293 461 datatype failure_mode = Error | None
adam@1293 462
adamc@866 463 type dbms = {
adamc@866 464 name : string,
adamc@866 465 header : string,
adamc@866 466 link : string,
adamc@873 467 p_sql_type : sql_type -> string,
adamc@870 468 init : {dbstring : string,
adamc@870 469 prepared : (string * int) list,
adamc@870 470 tables : (string * (string * sql_type) list) list,
adamc@872 471 views : (string * (string * sql_type) list) list,
adamc@870 472 sequences : string list} -> Print.PD.pp_desc,
adamc@873 473 query : {loc : ErrorMsg.span, cols : sql_type list,
adamc@880 474 doCols : ({loc : ErrorMsg.span, wontLeakStrings : bool, col : int, typ : sql_type} -> Print.PD.pp_desc)
adamc@867 475 -> Print.PD.pp_desc}
adamc@867 476 -> Print.PD.pp_desc,
adamc@867 477 queryPrepared : {loc : ErrorMsg.span, id : int, query : string,
adamc@873 478 inputs : sql_type list, cols : sql_type list,
adamc@880 479 doCols : ({loc : ErrorMsg.span, wontLeakStrings : bool, col : int,
adamc@880 480 typ : sql_type} -> Print.PD.pp_desc)
adamc@879 481 -> Print.PD.pp_desc,
adamc@879 482 nested : bool}
adamc@868 483 -> Print.PD.pp_desc,
adam@1293 484 dml : ErrorMsg.span * failure_mode -> Print.PD.pp_desc,
adamc@868 485 dmlPrepared : {loc : ErrorMsg.span, id : int, dml : string,
adam@1293 486 inputs : sql_type list, mode : failure_mode} -> Print.PD.pp_desc,
adamc@878 487 nextval : {loc : ErrorMsg.span, seqName : string option, seqE : Print.PD.pp_desc} -> Print.PD.pp_desc,
adamc@874 488 nextvalPrepared : {loc : ErrorMsg.span, id : int, query : string} -> Print.PD.pp_desc,
adamc@1073 489 setval : {loc : ErrorMsg.span, seqE : Print.PD.pp_desc, count : Print.PD.pp_desc} -> Print.PD.pp_desc,
adamc@874 490 sqlifyString : string -> string,
adamc@874 491 p_cast : string * sql_type -> string,
adamc@874 492 p_blank : int * sql_type -> string,
adamc@877 493 supportsDeleteAs : bool,
adamc@886 494 supportsUpdateAs : bool,
adamc@877 495 createSequence : string -> string,
adamc@878 496 textKeysNeedLengths : bool,
adamc@879 497 supportsNextval : bool,
adamc@882 498 supportsNestedPrepared : bool,
adamc@890 499 sqlPrefix : string,
adamc@1014 500 supportsOctetLength : bool,
adamc@1014 501 trueString : string,
adamc@1196 502 falseString : string,
adamc@1196 503 onlyUnion : bool,
adamc@1196 504 nestedRelops : bool
adamc@866 505 }
adamc@866 506
adamc@866 507 val dbmses = ref ([] : dbms list)
adamc@866 508 val curDb = ref ({name = "",
adamc@866 509 header = "",
adamc@866 510 link = "",
adamc@873 511 p_sql_type = fn _ => "",
adamc@867 512 init = fn _ => Print.box [],
adamc@867 513 query = fn _ => Print.box [],
adamc@868 514 queryPrepared = fn _ => Print.box [],
adamc@868 515 dml = fn _ => Print.box [],
adamc@869 516 dmlPrepared = fn _ => Print.box [],
adamc@869 517 nextval = fn _ => Print.box [],
adamc@874 518 nextvalPrepared = fn _ => Print.box [],
adamc@1073 519 setval = fn _ => Print.box [],
adamc@874 520 sqlifyString = fn s => s,
adamc@874 521 p_cast = fn _ => "",
adamc@874 522 p_blank = fn _ => "",
adamc@877 523 supportsDeleteAs = false,
adamc@886 524 supportsUpdateAs = false,
adamc@877 525 createSequence = fn _ => "",
adamc@878 526 textKeysNeedLengths = false,
adamc@879 527 supportsNextval = false,
adamc@882 528 supportsNestedPrepared = false,
adamc@890 529 sqlPrefix = "",
adamc@1014 530 supportsOctetLength = false,
adamc@1014 531 trueString = "",
adamc@1196 532 falseString = "",
adamc@1196 533 onlyUnion = false,
adamc@1196 534 nestedRelops = false} : dbms)
adamc@866 535
adamc@866 536 fun addDbms v = dbmses := v :: !dbmses
adamc@866 537 fun setDbms s =
adamc@866 538 case List.find (fn db => #name db = s) (!dbmses) of
adamc@866 539 NONE => raise Fail ("Unknown DBMS " ^ s)
adamc@866 540 | SOME db => curDb := db
adamc@866 541 fun currentDbms () = !curDb
adamc@866 542
adamc@891 543 val dbstring = ref (NONE : string option)
adamc@891 544 fun setDbstring so = dbstring := so
adamc@891 545 fun getDbstring () = !dbstring
adamc@891 546
adamc@891 547 val exe = ref (NONE : string option)
adamc@891 548 fun setExe so = exe := so
adamc@891 549 fun getExe () = !exe
adamc@891 550
adamc@891 551 val sql = ref (NONE : string option)
adamc@891 552 fun setSql so = sql := so
adamc@891 553 fun getSql () = !sql
adamc@891 554
adamc@1016 555 val coreInline = ref 20
adamc@1016 556 fun setCoreInline n = coreInline := n
adamc@1016 557 fun getCoreInline () = !coreInline
adamc@1016 558
adam@1351 559 val monoInline = ref 100
adamc@1016 560 fun setMonoInline n = monoInline := n
adamc@1016 561 fun getMonoInline () = !monoInline
adamc@1016 562
adamc@1095 563 val staticLinking = ref false
adamc@1095 564 fun setStaticLinking b = staticLinking := b
adamc@1095 565 fun getStaticLinking () = !staticLinking
adamc@1095 566
adamc@1114 567 val deadlines = ref false
adamc@1114 568 fun setDeadlines b = deadlines := b
adamc@1114 569 fun getDeadlines () = !deadlines
adamc@1114 570
adamc@1164 571 val sigFile = ref (NONE : string option)
adamc@1164 572 fun setSigFile v = sigFile := v
adamc@1164 573 fun getSigFile () = !sigFile
adamc@1164 574
adamc@1183 575 structure SS = BinarySetFn(struct
adamc@1183 576 type ord_key = string
adamc@1183 577 val compare = String.compare
adamc@1183 578 end)
adamc@1183 579
adamc@1183 580 val safeGet = ref SS.empty
adamc@1183 581 fun setSafeGets ls = safeGet := SS.addList (SS.empty, ls)
adamc@1183 582 fun isSafeGet x = SS.member (!safeGet, x)
adamc@1183 583
adam@1294 584 val onError = ref (NONE : (string * string list * string) option)
adam@1294 585 fun setOnError x = onError := x
adam@1294 586 fun getOnError () = !onError
adam@1294 587
adam@1307 588 val limits = ["messages", "clients", "headers", "page", "heap", "script",
adam@1307 589 "inputs", "subinputs", "cleanup", "deltas", "transactionals",
adam@1308 590 "globals", "database", "time"]
adam@1307 591
adam@1307 592 val limitsList = ref ([] : (string * int) list)
adam@1307 593 fun addLimit (v as (name, _)) =
adam@1307 594 if List.exists (fn name' => name' = name) limits then
adam@1308 595 (limitsList := v :: !limitsList;
adam@1308 596 if name = "time" then
adam@1308 597 setDeadlines true
adam@1308 598 else
adam@1308 599 ())
adam@1307 600 else
adam@1307 601 raise Fail ("Unknown limit category '" ^ name ^ "'")
adam@1307 602 fun limits () = !limitsList
adam@1307 603
adam@1332 604 val minHeap = ref 0
adam@1332 605 fun setMinHeap n = if n >= 0 then minHeap := n else raise Fail "Trying to set negative minHeap"
adam@1332 606 fun getMinHeap () = !minHeap
adam@1332 607
adam@1393 608 structure SS = BinarySetFn(struct
adam@1393 609 type ord_key = string
adam@1393 610 val compare = String.compare
adam@1393 611 end)
adam@1393 612
adam@1393 613 val alwaysInline = ref SS.empty
adam@1393 614 fun addAlwaysInline s = alwaysInline := SS.add (!alwaysInline, s)
adam@1393 615 fun checkAlwaysInline s = SS.member (!alwaysInline, s)
adam@1393 616
adam@1478 617 val noXsrfProtection = ref SS.empty
adam@1478 618 fun addNoXsrfProtection s = noXsrfProtection := SS.add (!noXsrfProtection, s)
adam@1478 619 fun checkNoXsrfProtection s = SS.member (!noXsrfProtection, s)
adam@1478 620
adamc@765 621 end