Mercurial > urweb

annotate src/settings.sml @ 1642:c3627f317bfd

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