Mercurial > urweb

annotate src/settings.sml @ 1726:4df4521fbd3b

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