Mercurial > urweb

annotate src/settings.sml @ 1327:1cc67fdac4d3

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