Mercurial > urweb

annotate src/settings.sml @ 1512:dcc8abbc6dfd

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Change cookie signature comparison to resist timing attacks (based on code suggested by Robin Green and Austin Seipp)
author Adam Chlipala <adam@chlipala.net>
date Tue, 19 Jul 2011 09:18:50 -0400
parents 290de2dcecf6
children 3c0803c1acd7
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@1465 150 "setHeader"]
adamc@1171 151
adamc@1171 152 val benign = ref benignBase
adamc@1171 153 fun setBenignEffectful ls = benign := S.addList (benignBase, ls)
adamc@1171 154 fun isBenignEffectful x = S.member (!benign, x)
adamc@1171 155
adamc@765 156 val clientBase = basis ["get",
adamc@765 157 "set",
adamc@841 158 "current",
adamc@765 159 "alert",
adam@1290 160 "confirm",
adamc@765 161 "recv",
adamc@765 162 "sleep",
adamc@765 163 "spawn",
adamc@765 164 "onError",
adamc@765 165 "onFail",
adamc@765 166 "onConnectFail",
adamc@765 167 "onDisconnect",
adamc@895 168 "onServerError",
adamc@895 169 "kc"]
adamc@765 170 val client = ref clientBase
adamc@765 171 fun setClientOnly ls = client := S.addList (clientBase, ls)
adamc@765 172 fun isClientOnly x = S.member (!client, x)
adamc@765 173
adamc@765 174 val serverBase = basis ["requestHeader",
adamc@765 175 "query",
adamc@765 176 "dml",
adamc@765 177 "nextval",
adamc@1073 178 "setval",
adamc@765 179 "channel",
adamc@765 180 "send"]
adamc@765 181 val server = ref serverBase
adamc@765 182 fun setServerOnly ls = server := S.addList (serverBase, ls)
adamc@765 183 fun isServerOnly x = S.member (!server, x)
adamc@765 184
adamc@765 185 val basisM = foldl (fn ((k, v : string), m) => M.insert (m, ("Basis", k), v)) M.empty
adamc@765 186
adamc@765 187 val jsFuncsBase = basisM [("alert", "alert"),
adam@1290 188 ("confirm", "confrm"),
adamc@765 189 ("get_client_source", "sg"),
adamc@841 190 ("current", "scur"),
adamc@765 191 ("htmlifyBool", "bs"),
adamc@765 192 ("htmlifyFloat", "ts"),
adamc@765 193 ("htmlifyInt", "ts"),
adamc@765 194 ("htmlifyString", "eh"),
adamc@765 195 ("new_client_source", "sc"),
adamc@765 196 ("set_client_source", "sv"),
adamc@838 197 ("stringToFloat", "pflo"),
adamc@838 198 ("stringToInt", "pio"),
adamc@765 199 ("stringToFloat_error", "pfl"),
adamc@765 200 ("stringToInt_error", "pi"),
adamc@765 201 ("urlifyInt", "ts"),
adamc@765 202 ("urlifyFloat", "ts"),
adam@1360 203 ("urlifyTime", "ts"),
adamc@765 204 ("urlifyString", "uf"),
adamc@912 205 ("urlifyBool", "ub"),
adamc@765 206 ("recv", "rv"),
adamc@765 207 ("strcat", "cat"),
adamc@765 208 ("intToString", "ts"),
adamc@765 209 ("floatToString", "ts"),
adamc@821 210 ("charToString", "ts"),
adamc@765 211 ("onError", "onError"),
adamc@765 212 ("onFail", "onFail"),
adamc@765 213 ("onConnectFail", "onConnectFail"),
adamc@765 214 ("onDisconnect", "onDisconnect"),
adamc@798 215 ("onServerError", "onServerError"),
adamc@1108 216 ("attrifyString", "atr"),
adamc@798 217 ("attrifyInt", "ts"),
adamc@798 218 ("attrifyFloat", "ts"),
adamc@820 219 ("attrifyBool", "bs"),
adamc@821 220 ("boolToString", "ts"),
adamc@1057 221 ("str1", "id"),
adamc@821 222 ("strsub", "sub"),
adamc@828 223 ("strsuffix", "suf"),
adamc@829 224 ("strlen", "slen"),
adamc@829 225 ("strindex", "sidx"),
adamc@829 226 ("strchr", "schr"),
adamc@831 227 ("substring", "ssub"),
adamc@895 228 ("strcspn", "sspn"),
adamc@1061 229 ("kc", "kc"),
adam@1404 230 ("minTime", "0"),
adamc@1061 231
adamc@1061 232 ("islower", "isLower"),
adamc@1061 233 ("isupper", "isUpper"),
adamc@1061 234 ("isalpha", "isAlpha"),
adamc@1061 235 ("isdigit", "isDigit"),
adamc@1061 236 ("isalnum", "isAlnum"),
adamc@1061 237 ("isblank", "isBlank"),
adamc@1061 238 ("isspace", "isSpace"),
adamc@1061 239 ("isxdigit", "isXdigit"),
adamc@1061 240 ("tolower", "toLower"),
adamc@1323 241 ("toupper", "toUpper"),
adamc@1323 242
adamc@1323 243 ("checkUrl", "checkUrl"),
adam@1366 244 ("bless", "bless"),
adam@1366 245
adam@1366 246 ("eq_time", "eq"),
adam@1366 247 ("lt_time", "lt"),
adam@1430 248 ("le_time", "le"),
adam@1430 249
adam@1430 250 ("debug", "alert"),
adam@1487 251 ("naughtyDebug", "alert"),
adam@1487 252
adam@1487 253 ("now", "now"),
adam@1487 254 ("timeToString", "showTime"),
adam@1487 255 ("htmlifyTime", "showTime")]
adamc@765 256 val jsFuncs = ref jsFuncsBase
adamc@765 257 fun setJsFuncs ls = jsFuncs := foldl (fn ((k, v), m) => M.insert (m, k, v)) jsFuncsBase ls
adamc@765 258 fun jsFunc x = M.find (!jsFuncs, x)
adam@1433 259 fun allJsFuncs () = M.listItemsi (!jsFuncs)
adamc@765 260
adamc@768 261 datatype pattern_kind = Exact | Prefix
adamc@768 262 datatype action = Allow | Deny
adamc@768 263 type rule = { action : action, kind : pattern_kind, pattern : string }
adamc@768 264
adamc@768 265 datatype path_kind = Any | Url | Table | Sequence | View | Relation | Cookie | Style
adamc@768 266 type rewrite = { pkind : path_kind, kind : pattern_kind, from : string, to : string }
adamc@768 267
adamc@768 268 val rewrites = ref ([] : rewrite list)
adamc@768 269
adamc@768 270 fun subsume (pk1, pk2) =
adamc@768 271 pk1 = pk2
adamc@768 272 orelse pk2 = Any
adamc@768 273 orelse pk2 = Relation andalso (pk1 = Table orelse pk1 = Sequence orelse pk1 = View)
adamc@768 274
adamc@768 275 fun setRewriteRules ls = rewrites := ls
adamc@768 276 fun rewrite pk s =
adamc@768 277 let
adamc@768 278 fun rew (ls : rewrite list) =
adamc@768 279 case ls of
adamc@768 280 [] => s
adamc@768 281 | rewr :: ls =>
adamc@768 282 let
adamc@768 283 fun match () =
adamc@768 284 case #kind rewr of
adamc@768 285 Exact => if #from rewr = s then
adamc@768 286 SOME (size s)
adamc@768 287 else
adamc@768 288 NONE
adamc@768 289 | Prefix => if String.isPrefix (#from rewr) s then
adamc@768 290 SOME (size (#from rewr))
adamc@768 291 else
adamc@768 292 NONE
adamc@768 293 in
adamc@768 294 if subsume (pk, #pkind rewr) then
adamc@768 295 case match () of
adamc@768 296 NONE => rew ls
adamc@768 297 | SOME suffixStart => #to rewr ^ String.extract (s, suffixStart, NONE)
adamc@768 298 else
adamc@768 299 rew ls
adamc@768 300 end
adamc@768 301 in
adamc@768 302 rew (!rewrites)
adamc@768 303 end
adamc@768 304
adamc@769 305 val url = ref ([] : rule list)
adamc@769 306 val mime = ref ([] : rule list)
adam@1465 307 val request = ref ([] : rule list)
adam@1465 308 val response = ref ([] : rule list)
adamc@769 309
adamc@769 310 fun setUrlRules ls = url := ls
adamc@769 311 fun setMimeRules ls = mime := ls
adam@1465 312 fun setRequestHeaderRules ls = request := ls
adam@1465 313 fun setResponseHeaderRules ls = response := ls
adamc@769 314
adamc@770 315 fun getUrlRules () = !url
adamc@770 316 fun getMimeRules () = !mime
adam@1465 317 fun getRequestHeaderRules () = !request
adam@1465 318 fun getResponseHeaderRules () = !response
adamc@770 319
adamc@769 320 fun check f rules s =
adamc@769 321 let
adamc@769 322 fun chk (ls : rule list) =
adamc@769 323 case ls of
adamc@769 324 [] => false
adamc@769 325 | rule :: ls =>
adamc@769 326 let
adamc@769 327 val matches =
adamc@769 328 case #kind rule of
adamc@769 329 Exact => #pattern rule = s
adamc@769 330 | Prefix => String.isPrefix (#pattern rule) s
adamc@769 331 in
adamc@769 332 if matches then
adamc@769 333 case #action rule of
adamc@769 334 Allow => true
adamc@769 335 | Deny => false
adamc@769 336 else
adamc@769 337 chk ls
adamc@769 338 end
adamc@769 339 in
adamc@769 340 f s andalso chk (!rules)
adamc@769 341 end
adamc@769 342
adamc@769 343 val checkUrl = check (fn _ => true) url
adam@1465 344
adam@1465 345 val validMime = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"/" orelse ch = #"-" orelse ch = #".")
adam@1465 346
adam@1465 347 val checkMime = check validMime mime
adam@1465 348 val checkRequestHeader = check validMime request
adam@1465 349 val checkResponseHeader = check validMime response
adamc@769 350
adamc@855 351
adamc@855 352 type protocol = {
adamc@855 353 name : string,
adamc@1096 354 compile : string,
adamc@1095 355 linkStatic : string,
adamc@1095 356 linkDynamic : string,
adamc@1164 357 persistent : bool,
adamc@1164 358 code : unit -> Print.PD.pp_desc
adamc@855 359 }
adamc@855 360 val protocols = ref ([] : protocol list)
adamc@855 361 fun addProtocol p = protocols := p :: !protocols
adamc@855 362 fun getProtocol s = List.find (fn p => #name p = s) (!protocols)
adamc@855 363
adamc@855 364 fun clibFile s = OS.Path.joinDirFile {dir = Config.libC,
adamc@855 365 file = s}
adamc@855 366
adamc@865 367 val curProto = ref {name = "",
adamc@1096 368 compile = "",
adamc@1095 369 linkStatic = "",
adamc@1095 370 linkDynamic = "",
adamc@1164 371 persistent = false,
adamc@1164 372 code = fn () => Print.box []}
adamc@856 373 fun setProtocol name =
adamc@856 374 case getProtocol name of
adamc@856 375 NONE => raise Fail ("Unknown protocol " ^ name)
adamc@856 376 | SOME p => curProto := p
adamc@855 377 fun currentProtocol () = !curProto
adamc@855 378
adamc@857 379 val debug = ref false
adamc@857 380 fun setDebug b = debug := b
adamc@857 381 fun getDebug () = !debug
adamc@857 382
adamc@867 383 datatype sql_type =
adamc@867 384 Int
adamc@867 385 | Float
adamc@867 386 | String
adamc@1011 387 | Char
adamc@867 388 | Bool
adamc@867 389 | Time
adamc@867 390 | Blob
adamc@867 391 | Channel
adamc@867 392 | Client
adamc@867 393 | Nullable of sql_type
adamc@867 394
adamc@873 395 fun p_sql_ctype t =
adamc@867 396 let
adamc@867 397 open Print.PD
adamc@867 398 open Print
adamc@867 399 in
adamc@867 400 case t of
adamc@870 401 Int => "uw_Basis_int"
adamc@870 402 | Float => "uw_Basis_float"
adamc@870 403 | String => "uw_Basis_string"
adamc@1011 404 | Char => "uw_Basis_char"
adamc@870 405 | Bool => "uw_Basis_bool"
adamc@870 406 | Time => "uw_Basis_time"
adamc@870 407 | Blob => "uw_Basis_blob"
adamc@870 408 | Channel => "uw_Basis_channel"
adamc@870 409 | Client => "uw_Basis_client"
adamc@870 410 | Nullable String => "uw_Basis_string"
adamc@873 411 | Nullable t => p_sql_ctype t ^ "*"
adamc@867 412 end
adamc@867 413
adamc@867 414 fun isBlob Blob = true
adamc@867 415 | isBlob (Nullable t) = isBlob t
adamc@867 416 | isBlob _ = false
adamc@867 417
adamc@870 418 fun isNotNull (Nullable _) = false
adamc@870 419 | isNotNull _ = true
adamc@870 420
adam@1293 421 datatype failure_mode = Error | None
adam@1293 422
adamc@866 423 type dbms = {
adamc@866 424 name : string,
adamc@866 425 header : string,
adamc@866 426 link : string,
adamc@873 427 p_sql_type : sql_type -> string,
adamc@870 428 init : {dbstring : string,
adamc@870 429 prepared : (string * int) list,
adamc@870 430 tables : (string * (string * sql_type) list) list,
adamc@872 431 views : (string * (string * sql_type) list) list,
adamc@870 432 sequences : string list} -> Print.PD.pp_desc,
adamc@873 433 query : {loc : ErrorMsg.span, cols : sql_type list,
adamc@880 434 doCols : ({loc : ErrorMsg.span, wontLeakStrings : bool, col : int, typ : sql_type} -> Print.PD.pp_desc)
adamc@867 435 -> Print.PD.pp_desc}
adamc@867 436 -> Print.PD.pp_desc,
adamc@867 437 queryPrepared : {loc : ErrorMsg.span, id : int, query : string,
adamc@873 438 inputs : sql_type list, cols : sql_type list,
adamc@880 439 doCols : ({loc : ErrorMsg.span, wontLeakStrings : bool, col : int,
adamc@880 440 typ : sql_type} -> Print.PD.pp_desc)
adamc@879 441 -> Print.PD.pp_desc,
adamc@879 442 nested : bool}
adamc@868 443 -> Print.PD.pp_desc,
adam@1293 444 dml : ErrorMsg.span * failure_mode -> Print.PD.pp_desc,
adamc@868 445 dmlPrepared : {loc : ErrorMsg.span, id : int, dml : string,
adam@1293 446 inputs : sql_type list, mode : failure_mode} -> Print.PD.pp_desc,
adamc@878 447 nextval : {loc : ErrorMsg.span, seqName : string option, seqE : Print.PD.pp_desc} -> Print.PD.pp_desc,
adamc@874 448 nextvalPrepared : {loc : ErrorMsg.span, id : int, query : string} -> Print.PD.pp_desc,
adamc@1073 449 setval : {loc : ErrorMsg.span, seqE : Print.PD.pp_desc, count : Print.PD.pp_desc} -> Print.PD.pp_desc,
adamc@874 450 sqlifyString : string -> string,
adamc@874 451 p_cast : string * sql_type -> string,
adamc@874 452 p_blank : int * sql_type -> string,
adamc@877 453 supportsDeleteAs : bool,
adamc@886 454 supportsUpdateAs : bool,
adamc@877 455 createSequence : string -> string,
adamc@878 456 textKeysNeedLengths : bool,
adamc@879 457 supportsNextval : bool,
adamc@882 458 supportsNestedPrepared : bool,
adamc@890 459 sqlPrefix : string,
adamc@1014 460 supportsOctetLength : bool,
adamc@1014 461 trueString : string,
adamc@1196 462 falseString : string,
adamc@1196 463 onlyUnion : bool,
adamc@1196 464 nestedRelops : bool
adamc@866 465 }
adamc@866 466
adamc@866 467 val dbmses = ref ([] : dbms list)
adamc@866 468 val curDb = ref ({name = "",
adamc@866 469 header = "",
adamc@866 470 link = "",
adamc@873 471 p_sql_type = fn _ => "",
adamc@867 472 init = fn _ => Print.box [],
adamc@867 473 query = fn _ => Print.box [],
adamc@868 474 queryPrepared = fn _ => Print.box [],
adamc@868 475 dml = fn _ => Print.box [],
adamc@869 476 dmlPrepared = fn _ => Print.box [],
adamc@869 477 nextval = fn _ => Print.box [],
adamc@874 478 nextvalPrepared = fn _ => Print.box [],
adamc@1073 479 setval = fn _ => Print.box [],
adamc@874 480 sqlifyString = fn s => s,
adamc@874 481 p_cast = fn _ => "",
adamc@874 482 p_blank = fn _ => "",
adamc@877 483 supportsDeleteAs = false,
adamc@886 484 supportsUpdateAs = false,
adamc@877 485 createSequence = fn _ => "",
adamc@878 486 textKeysNeedLengths = false,
adamc@879 487 supportsNextval = false,
adamc@882 488 supportsNestedPrepared = false,
adamc@890 489 sqlPrefix = "",
adamc@1014 490 supportsOctetLength = false,
adamc@1014 491 trueString = "",
adamc@1196 492 falseString = "",
adamc@1196 493 onlyUnion = false,
adamc@1196 494 nestedRelops = false} : dbms)
adamc@866 495
adamc@866 496 fun addDbms v = dbmses := v :: !dbmses
adamc@866 497 fun setDbms s =
adamc@866 498 case List.find (fn db => #name db = s) (!dbmses) of
adamc@866 499 NONE => raise Fail ("Unknown DBMS " ^ s)
adamc@866 500 | SOME db => curDb := db
adamc@866 501 fun currentDbms () = !curDb
adamc@866 502
adamc@891 503 val dbstring = ref (NONE : string option)
adamc@891 504 fun setDbstring so = dbstring := so
adamc@891 505 fun getDbstring () = !dbstring
adamc@891 506
adamc@891 507 val exe = ref (NONE : string option)
adamc@891 508 fun setExe so = exe := so
adamc@891 509 fun getExe () = !exe
adamc@891 510
adamc@891 511 val sql = ref (NONE : string option)
adamc@891 512 fun setSql so = sql := so
adamc@891 513 fun getSql () = !sql
adamc@891 514
adamc@1016 515 val coreInline = ref 20
adamc@1016 516 fun setCoreInline n = coreInline := n
adamc@1016 517 fun getCoreInline () = !coreInline
adamc@1016 518
adam@1351 519 val monoInline = ref 100
adamc@1016 520 fun setMonoInline n = monoInline := n
adamc@1016 521 fun getMonoInline () = !monoInline
adamc@1016 522
adamc@1095 523 val staticLinking = ref false
adamc@1095 524 fun setStaticLinking b = staticLinking := b
adamc@1095 525 fun getStaticLinking () = !staticLinking
adamc@1095 526
adamc@1114 527 val deadlines = ref false
adamc@1114 528 fun setDeadlines b = deadlines := b
adamc@1114 529 fun getDeadlines () = !deadlines
adamc@1114 530
adamc@1164 531 val sigFile = ref (NONE : string option)
adamc@1164 532 fun setSigFile v = sigFile := v
adamc@1164 533 fun getSigFile () = !sigFile
adamc@1164 534
adamc@1183 535 structure SS = BinarySetFn(struct
adamc@1183 536 type ord_key = string
adamc@1183 537 val compare = String.compare
adamc@1183 538 end)
adamc@1183 539
adamc@1183 540 val safeGet = ref SS.empty
adamc@1183 541 fun setSafeGets ls = safeGet := SS.addList (SS.empty, ls)
adamc@1183 542 fun isSafeGet x = SS.member (!safeGet, x)
adamc@1183 543
adam@1294 544 val onError = ref (NONE : (string * string list * string) option)
adam@1294 545 fun setOnError x = onError := x
adam@1294 546 fun getOnError () = !onError
adam@1294 547
adam@1307 548 val limits = ["messages", "clients", "headers", "page", "heap", "script",
adam@1307 549 "inputs", "subinputs", "cleanup", "deltas", "transactionals",
adam@1308 550 "globals", "database", "time"]
adam@1307 551
adam@1307 552 val limitsList = ref ([] : (string * int) list)
adam@1307 553 fun addLimit (v as (name, _)) =
adam@1307 554 if List.exists (fn name' => name' = name) limits then
adam@1308 555 (limitsList := v :: !limitsList;
adam@1308 556 if name = "time" then
adam@1308 557 setDeadlines true
adam@1308 558 else
adam@1308 559 ())
adam@1307 560 else
adam@1307 561 raise Fail ("Unknown limit category '" ^ name ^ "'")
adam@1307 562 fun limits () = !limitsList
adam@1307 563
adam@1332 564 val minHeap = ref 0
adam@1332 565 fun setMinHeap n = if n >= 0 then minHeap := n else raise Fail "Trying to set negative minHeap"
adam@1332 566 fun getMinHeap () = !minHeap
adam@1332 567
adam@1393 568 structure SS = BinarySetFn(struct
adam@1393 569 type ord_key = string
adam@1393 570 val compare = String.compare
adam@1393 571 end)
adam@1393 572
adam@1393 573 val alwaysInline = ref SS.empty
adam@1393 574 fun addAlwaysInline s = alwaysInline := SS.add (!alwaysInline, s)
adam@1393 575 fun checkAlwaysInline s = SS.member (!alwaysInline, s)
adam@1393 576
adam@1478 577 val noXsrfProtection = ref SS.empty
adam@1478 578 fun addNoXsrfProtection s = noXsrfProtection := SS.add (!noXsrfProtection, s)
adam@1478 579 fun checkNoXsrfProtection s = SS.member (!noXsrfProtection, s)
adam@1478 580
adamc@765 581 end