Mercurial > urweb

annotate src/settings.sml @ 1856:3683d1a8c1c8

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Add Sigcheck phase to avoid issues with signatures in global initializers
author Adam Chlipala <adam@chlipala.net>
date Sat, 15 Jun 2013 08:18:47 -0400
parents 3c56aa6a0f55
children c3119c263bd3
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
ezyang@1739 30 val configBin = ref Config.bin
ezyang@1739 31 val configLib = ref Config.lib
ezyang@1739 32 val configSrcLib = ref Config.srclib
ezyang@1739 33 val configInclude = ref Config.includ
ezyang@1739 34 val configSitelisp = ref Config.sitelisp
ezyang@1739 35
ezyang@1739 36 fun libUr () = OS.Path.joinDirFile {dir = !configSrcLib,
ezyang@1739 37 file = "ur"}
ezyang@1739 38 fun libC () = OS.Path.joinDirFile {dir = !configSrcLib,
ezyang@1739 39 file = "c"}
ezyang@1739 40 fun libJs () = OS.Path.joinDirFile {dir = !configSrcLib,
ezyang@1739 41 file = "js"}
ezyang@1739 42
ezyang@1739 43 fun libFile s = OS.Path.joinDirFile {dir = libUr (),
ezyang@1739 44 file = s}
ezyang@1739 45
adam@1637 46 val urlPrefixFull = ref "/"
adamc@764 47 val urlPrefix = ref "/"
adam@1370 48 val urlPrePrefix = ref ""
adamc@764 49 val timeout = ref 0
adamc@764 50 val headers = ref ([] : string list)
adamc@766 51 val scripts = ref ([] : string list)
adamc@764 52
adam@1637 53 fun getUrlPrefixFull () = !urlPrefixFull
adamc@764 54 fun getUrlPrefix () = !urlPrefix
adam@1370 55 fun getUrlPrePrefix () = !urlPrePrefix
adamc@764 56 fun setUrlPrefix p =
adam@1370 57 let
adam@1370 58 val prefix = if p = "" then
adam@1370 59 "/"
adam@1370 60 else if String.sub (p, size p - 1) <> #"/" then
adam@1370 61 p ^ "/"
adam@1370 62 else
adam@1370 63 p
adam@1370 64
adam@1470 65 fun findPrefix n =
adam@1470 66 let
adam@1470 67 val (befor, after) = Substring.splitl (fn ch => ch <> #"/") (Substring.extract (prefix, n, NONE))
adam@1470 68 in
adam@1470 69 if Substring.isEmpty after then
adam@1470 70 ("", prefix)
adam@1470 71 else
adam@1470 72 (String.substring (prefix, 0, n) ^ Substring.string befor, Substring.string after)
rmbruijn@1597 73 end
adam@1470 74
adam@1370 75 val (prepre, prefix) =
adam@1370 76 if String.isPrefix "http://" prefix then
adam@1470 77 findPrefix 7
adam@1470 78 else if String.isPrefix "https://" prefix then
adam@1470 79 findPrefix 8
adam@1370 80 else
adam@1370 81 ("", prefix)
adam@1370 82 in
adam@1637 83 urlPrefixFull := p;
adam@1370 84 urlPrePrefix := prepre;
adam@1370 85 urlPrefix := prefix
adam@1370 86 end
adamc@764 87
adamc@764 88 fun getTimeout () = !timeout
adamc@764 89 fun setTimeout n = timeout := n
adamc@764 90
adamc@764 91 fun getHeaders () = !headers
adamc@764 92 fun setHeaders ls = headers := ls
adamc@764 93
adamc@766 94 fun getScripts () = !scripts
adamc@766 95 fun setScripts ls = scripts := ls
adamc@766 96
adamc@765 97 type ffi = string * string
adamc@765 98
adamc@765 99 structure K = struct
adamc@765 100 type ord_key = ffi
adamc@765 101 fun compare ((m1, x1), (m2, x2)) =
adamc@765 102 Order.join (String.compare (m1, m2),
adamc@765 103 fn () => String.compare (x1, x2))
adamc@764 104 end
adamc@765 105
adamc@765 106 structure S = BinarySetFn(K)
adamc@765 107 structure M = BinaryMapFn(K)
adamc@765 108
adamc@765 109 fun basis x = S.addList (S.empty, map (fn x : string => ("Basis", x)) x)
adamc@765 110
adamc@765 111 val clientToServerBase = basis ["int",
adamc@765 112 "float",
adamc@765 113 "string",
adamc@765 114 "time",
adamc@765 115 "file",
adamc@765 116 "unit",
adamc@765 117 "option",
adamc@765 118 "list",
adam@1288 119 "bool",
adam@1288 120 "variant"]
adamc@765 121 val clientToServer = ref clientToServerBase
adamc@765 122 fun setClientToServer ls = clientToServer := S.addList (clientToServerBase, ls)
adamc@765 123 fun mayClientToServer x = S.member (!clientToServer, x)
adamc@765 124
adamc@779 125 val effectfulBase = basis ["dml",
adamc@779 126 "nextval",
adamc@1073 127 "setval",
adamc@779 128 "set_cookie",
adamc@1050 129 "clear_cookie",
adamc@765 130 "new_channel",
adamc@1200 131 "send",
adamc@1200 132 "htmlifyInt_w",
adamc@1200 133 "htmlifyFloat_w",
adamc@1200 134 "htmlifyString_w",
adamc@1200 135 "htmlifyBool_w",
adamc@1200 136 "htmlifyTime_w",
adamc@1200 137 "attrifyInt_w",
adamc@1200 138 "attrifyFloat_w",
adamc@1200 139 "attrifyString_w",
adamc@1200 140 "attrifyChar_w",
adamc@1200 141 "urlifyInt_w",
adamc@1200 142 "urlifyFloat_w",
adamc@1200 143 "urlifyString_w",
adamc@1200 144 "urlifyBool_w",
adamc@1200 145 "urlifyChannel_w"]
adamc@765 146
adamc@765 147 val effectful = ref effectfulBase
adamc@765 148 fun setEffectful ls = effectful := S.addList (effectfulBase, ls)
adamc@765 149 fun isEffectful x = S.member (!effectful, x)
adamc@765 150
adamc@1171 151 val benignBase = basis ["get_cookie",
adamc@1171 152 "new_client_source",
adamc@1171 153 "get_client_source",
adamc@1171 154 "set_client_source",
adamc@1171 155 "current",
adamc@1171 156 "alert",
adam@1290 157 "confirm",
adamc@1171 158 "onError",
adamc@1171 159 "onFail",
adamc@1171 160 "onConnectFail",
adamc@1171 161 "onDisconnect",
adamc@1171 162 "onServerError",
adam@1783 163 "mouseEvent",
adam@1783 164 "keyEvent",
adamc@1250 165 "debug",
adam@1422 166 "rand",
adam@1465 167 "now",
adam@1465 168 "getHeader",
adam@1555 169 "setHeader",
adam@1555 170 "spawn",
adam@1555 171 "onClick",
adam@1555 172 "onDblclick",
adam@1555 173 "onKeydown",
adam@1555 174 "onKeypress",
adam@1555 175 "onKeyup",
adam@1555 176 "onMousedown",
adam@1791 177 "onMousemove",
adam@1791 178 "onMouseout",
adam@1791 179 "onMouseover",
adam@1556 180 "onMouseup",
adam@1559 181 "preventDefault",
adam@1559 182 "stopPropagation",
adam@1785 183 "fresh",
adam@1785 184 "giveFocus"]
adamc@1171 185
adamc@1171 186 val benign = ref benignBase
adamc@1171 187 fun setBenignEffectful ls = benign := S.addList (benignBase, ls)
adamc@1171 188 fun isBenignEffectful x = S.member (!benign, x)
adamc@1171 189
adam@1595 190 val clientBase = basis ["get_client_source",
adamc@841 191 "current",
adamc@765 192 "alert",
adam@1290 193 "confirm",
adamc@765 194 "recv",
adamc@765 195 "sleep",
adamc@765 196 "spawn",
adamc@765 197 "onError",
adamc@765 198 "onFail",
adamc@765 199 "onConnectFail",
adamc@765 200 "onDisconnect",
adamc@895 201 "onServerError",
adam@1783 202 "mouseEvent",
adam@1783 203 "keyEvent",
adam@1555 204 "onClick",
adam@1555 205 "onDblclick",
adam@1555 206 "onKeydown",
adam@1555 207 "onKeypress",
adam@1555 208 "onKeyup",
adam@1555 209 "onMousedown",
adam@1791 210 "onMousemove",
adam@1791 211 "onMouseout",
adam@1791 212 "onMouseover",
adam@1559 213 "onMouseup",
adam@1559 214 "preventDefault",
adam@1785 215 "stopPropagation",
adam@1785 216 "giveFocus"]
adamc@765 217 val client = ref clientBase
adamc@765 218 fun setClientOnly ls = client := S.addList (clientBase, ls)
adamc@765 219 fun isClientOnly x = S.member (!client, x)
adamc@765 220
adamc@765 221 val serverBase = basis ["requestHeader",
adamc@765 222 "query",
adamc@765 223 "dml",
adamc@765 224 "nextval",
adamc@1073 225 "setval",
adamc@765 226 "channel",
adam@1787 227 "send",
adam@1787 228 "fieldName",
adam@1787 229 "fieldValue",
adam@1787 230 "remainingFields",
adam@1787 231 "firstFormField"]
adamc@765 232 val server = ref serverBase
adamc@765 233 fun setServerOnly ls = server := S.addList (serverBase, ls)
adamc@765 234 fun isServerOnly x = S.member (!server, x)
adamc@765 235
adamc@765 236 val basisM = foldl (fn ((k, v : string), m) => M.insert (m, ("Basis", k), v)) M.empty
adamc@765 237
adamc@765 238 val jsFuncsBase = basisM [("alert", "alert"),
adam@1599 239 ("stringToTime", "stringToTime"),
adam@1599 240 ("stringToTime_error", "stringToTime_error"),
adam@1609 241 ("timef", "strftime"),
adam@1290 242 ("confirm", "confrm"),
adamc@765 243 ("get_client_source", "sg"),
adamc@841 244 ("current", "scur"),
adamc@765 245 ("htmlifyBool", "bs"),
adamc@765 246 ("htmlifyFloat", "ts"),
adamc@765 247 ("htmlifyInt", "ts"),
adamc@765 248 ("htmlifyString", "eh"),
adamc@765 249 ("new_client_source", "sc"),
adamc@765 250 ("set_client_source", "sv"),
adamc@838 251 ("stringToFloat", "pflo"),
adamc@838 252 ("stringToInt", "pio"),
adamc@765 253 ("stringToFloat_error", "pfl"),
adamc@765 254 ("stringToInt_error", "pi"),
adamc@765 255 ("urlifyInt", "ts"),
adamc@765 256 ("urlifyFloat", "ts"),
adam@1360 257 ("urlifyTime", "ts"),
adamc@765 258 ("urlifyString", "uf"),
adamc@912 259 ("urlifyBool", "ub"),
adamc@765 260 ("recv", "rv"),
adamc@765 261 ("strcat", "cat"),
adamc@765 262 ("intToString", "ts"),
adamc@765 263 ("floatToString", "ts"),
adamc@821 264 ("charToString", "ts"),
adamc@765 265 ("onError", "onError"),
adamc@765 266 ("onFail", "onFail"),
adamc@765 267 ("onConnectFail", "onConnectFail"),
adamc@765 268 ("onDisconnect", "onDisconnect"),
adamc@798 269 ("onServerError", "onServerError"),
adamc@1108 270 ("attrifyString", "atr"),
adamc@798 271 ("attrifyInt", "ts"),
adamc@798 272 ("attrifyFloat", "ts"),
adamc@820 273 ("attrifyBool", "bs"),
adamc@821 274 ("boolToString", "ts"),
adamc@1057 275 ("str1", "id"),
adamc@821 276 ("strsub", "sub"),
adamc@828 277 ("strsuffix", "suf"),
adamc@829 278 ("strlen", "slen"),
adamc@829 279 ("strindex", "sidx"),
adamc@829 280 ("strchr", "schr"),
adamc@831 281 ("substring", "ssub"),
adamc@895 282 ("strcspn", "sspn"),
adam@1624 283 ("strlenGe", "strlenGe"),
adam@1783 284 ("mouseEvent", "uw_mouseEvent"),
adam@1783 285 ("keyEvent", "uw_keyEvent"),
adam@1404 286 ("minTime", "0"),
adamc@1061 287
adamc@1061 288 ("islower", "isLower"),
adamc@1061 289 ("isupper", "isUpper"),
adamc@1061 290 ("isalpha", "isAlpha"),
adamc@1061 291 ("isdigit", "isDigit"),
adamc@1061 292 ("isalnum", "isAlnum"),
adamc@1061 293 ("isblank", "isBlank"),
adamc@1061 294 ("isspace", "isSpace"),
adamc@1061 295 ("isxdigit", "isXdigit"),
adamc@1061 296 ("tolower", "toLower"),
adamc@1323 297 ("toupper", "toUpper"),
adamc@1323 298
adamc@1323 299 ("checkUrl", "checkUrl"),
adam@1366 300 ("bless", "bless"),
adam@1366 301
adam@1366 302 ("eq_time", "eq"),
adam@1366 303 ("lt_time", "lt"),
adam@1430 304 ("le_time", "le"),
adam@1430 305
adam@1625 306 ("debug", "uw_debug"),
adam@1625 307 ("naughtyDebug", "uw_debug"),
adam@1487 308
adam@1571 309 ("floatFromInt", "float"),
adam@1571 310 ("ceil", "ceil"),
adam@1571 311 ("trunc", "trunc"),
adam@1571 312 ("round", "round"),
adam@1571 313
adam@1487 314 ("now", "now"),
adam@1487 315 ("timeToString", "showTime"),
adam@1629 316 ("htmlifyTime", "showTimeHtml"),
adam@1514 317 ("toSeconds", "toSeconds"),
adam@1518 318 ("addSeconds", "addSeconds"),
adam@1555 319 ("diffInSeconds", "diffInSeconds"),
adam@1685 320 ("toMilliseconds", "toMilliseconds"),
adam@1685 321 ("diffInMilliseconds", "diffInMilliseconds"),
adam@1555 322
adam@1555 323 ("onClick", "uw_onClick"),
adam@1555 324 ("onDblclick", "uw_onDblclick"),
adam@1555 325 ("onKeydown", "uw_onKeydown"),
adam@1555 326 ("onKeypress", "uw_onKeypress"),
adam@1555 327 ("onKeyup", "uw_onKeyup"),
adam@1555 328 ("onMousedown", "uw_onMousedown"),
adam@1791 329 ("onMousemove", "uw_onMousemove"),
adam@1791 330 ("onMouseout", "uw_onMouseout"),
adam@1791 331 ("onMouseover", "uw_onMouseover"),
adam@1556 332 ("onMouseup", "uw_onMouseup"),
adam@1559 333 ("preventDefault", "uw_preventDefault"),
adam@1559 334 ("stopPropagation", "uw_stopPropagation"),
adam@1556 335
adam@1755 336 ("fresh", "fresh"),
adam@1755 337
adam@1755 338 ("atom", "atom"),
adam@1755 339 ("css_url", "css_url"),
adam@1785 340 ("property", "property"),
adam@1785 341 ("giveFocus", "giveFocus")]
adamc@765 342 val jsFuncs = ref jsFuncsBase
adamc@765 343 fun setJsFuncs ls = jsFuncs := foldl (fn ((k, v), m) => M.insert (m, k, v)) jsFuncsBase ls
adamc@765 344 fun jsFunc x = M.find (!jsFuncs, x)
adam@1433 345 fun allJsFuncs () = M.listItemsi (!jsFuncs)
adamc@765 346
adamc@768 347 datatype pattern_kind = Exact | Prefix
adamc@768 348 datatype action = Allow | Deny
adamc@768 349 type rule = { action : action, kind : pattern_kind, pattern : string }
adamc@768 350
adamc@768 351 datatype path_kind = Any | Url | Table | Sequence | View | Relation | Cookie | Style
adam@1752 352 type rewrite = { pkind : path_kind, kind : pattern_kind, from : string, to : string, hyphenate : bool }
adamc@768 353
adamc@768 354 val rewrites = ref ([] : rewrite list)
adamc@768 355
adamc@768 356 fun subsume (pk1, pk2) =
adamc@768 357 pk1 = pk2
adamc@768 358 orelse pk2 = Any
adamc@768 359 orelse pk2 = Relation andalso (pk1 = Table orelse pk1 = Sequence orelse pk1 = View)
adamc@768 360
adamc@768 361 fun setRewriteRules ls = rewrites := ls
adamc@768 362 fun rewrite pk s =
adamc@768 363 let
adamc@768 364 fun rew (ls : rewrite list) =
adamc@768 365 case ls of
adamc@768 366 [] => s
adamc@768 367 | rewr :: ls =>
adamc@768 368 let
adamc@768 369 fun match () =
adamc@768 370 case #kind rewr of
adamc@768 371 Exact => if #from rewr = s then
adamc@768 372 SOME (size s)
adamc@768 373 else
adamc@768 374 NONE
adamc@768 375 | Prefix => if String.isPrefix (#from rewr) s then
adamc@768 376 SOME (size (#from rewr))
adamc@768 377 else
adamc@768 378 NONE
adamc@768 379 in
adamc@768 380 if subsume (pk, #pkind rewr) then
adamc@768 381 case match () of
adamc@768 382 NONE => rew ls
adam@1752 383 | SOME suffixStart =>
adam@1752 384 let
adam@1752 385 val s = #to rewr ^ String.extract (s, suffixStart, NONE)
adam@1752 386 in
adam@1752 387 if #hyphenate rewr then
adam@1752 388 String.translate (fn #"_" => "-" | ch => str ch) s
adam@1752 389 else
adam@1752 390 s
adam@1752 391 end
adamc@768 392 else
adamc@768 393 rew ls
adamc@768 394 end
adamc@768 395 in
adamc@768 396 rew (!rewrites)
adamc@768 397 end
adamc@768 398
adamc@769 399 val url = ref ([] : rule list)
adamc@769 400 val mime = ref ([] : rule list)
adam@1465 401 val request = ref ([] : rule list)
adam@1465 402 val response = ref ([] : rule list)
adam@1799 403 val env = ref ([] : rule list)
adamc@769 404
adamc@769 405 fun setUrlRules ls = url := ls
adamc@769 406 fun setMimeRules ls = mime := ls
adam@1465 407 fun setRequestHeaderRules ls = request := ls
adam@1465 408 fun setResponseHeaderRules ls = response := ls
adam@1799 409 fun setEnvVarRules ls = env := ls
adamc@769 410
adamc@770 411 fun getUrlRules () = !url
adamc@770 412 fun getMimeRules () = !mime
adam@1465 413 fun getRequestHeaderRules () = !request
adam@1465 414 fun getResponseHeaderRules () = !response
adam@1799 415 fun getEnvVarRules () = !env
adamc@770 416
adamc@769 417 fun check f rules s =
adamc@769 418 let
adamc@769 419 fun chk (ls : rule list) =
adamc@769 420 case ls of
adamc@769 421 [] => false
adamc@769 422 | rule :: ls =>
adamc@769 423 let
adamc@769 424 val matches =
adamc@769 425 case #kind rule of
adamc@769 426 Exact => #pattern rule = s
adamc@769 427 | Prefix => String.isPrefix (#pattern rule) s
adamc@769 428 in
adamc@769 429 if matches then
adamc@769 430 case #action rule of
adamc@769 431 Allow => true
adamc@769 432 | Deny => false
adamc@769 433 else
adamc@769 434 chk ls
adamc@769 435 end
adamc@769 436 in
adamc@769 437 f s andalso chk (!rules)
adamc@769 438 end
adamc@769 439
adamc@769 440 val checkUrl = check (fn _ => true) url
adam@1465 441
adam@1465 442 val validMime = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"/" orelse ch = #"-" orelse ch = #".")
adam@1799 443 val validEnv = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"_" orelse ch = #".")
adam@1465 444
adam@1465 445 val checkMime = check validMime mime
adam@1465 446 val checkRequestHeader = check validMime request
adam@1465 447 val checkResponseHeader = check validMime response
adam@1799 448 val checkEnvVar = check validEnv env
adamc@769 449
adamc@855 450
adamc@855 451 type protocol = {
adamc@855 452 name : string,
adamc@1096 453 compile : string,
adamc@1095 454 linkStatic : string,
adamc@1095 455 linkDynamic : string,
adamc@1164 456 persistent : bool,
adamc@1164 457 code : unit -> Print.PD.pp_desc
adamc@855 458 }
adamc@855 459 val protocols = ref ([] : protocol list)
adamc@855 460 fun addProtocol p = protocols := p :: !protocols
adamc@855 461 fun getProtocol s = List.find (fn p => #name p = s) (!protocols)
adamc@855 462
ezyang@1739 463 fun clibFile s = OS.Path.joinDirFile {dir = libC (),
adamc@855 464 file = s}
adamc@855 465
adamc@865 466 val curProto = ref {name = "",
adamc@1096 467 compile = "",
adamc@1095 468 linkStatic = "",
adamc@1095 469 linkDynamic = "",
adamc@1164 470 persistent = false,
adamc@1164 471 code = fn () => Print.box []}
adamc@856 472 fun setProtocol name =
adamc@856 473 case getProtocol name of
adamc@856 474 NONE => raise Fail ("Unknown protocol " ^ name)
adamc@856 475 | SOME p => curProto := p
adamc@855 476 fun currentProtocol () = !curProto
adamc@855 477
adamc@857 478 val debug = ref false
adamc@857 479 fun setDebug b = debug := b
adamc@857 480 fun getDebug () = !debug
adamc@857 481
adamc@867 482 datatype sql_type =
adamc@867 483 Int
adamc@867 484 | Float
adamc@867 485 | String
adamc@1011 486 | Char
adamc@867 487 | Bool
adamc@867 488 | Time
adamc@867 489 | Blob
adamc@867 490 | Channel
adamc@867 491 | Client
adamc@867 492 | Nullable of sql_type
adamc@867 493
adamc@873 494 fun p_sql_ctype t =
adamc@867 495 let
adamc@867 496 open Print.PD
adamc@867 497 open Print
adamc@867 498 in
adamc@867 499 case t of
adamc@870 500 Int => "uw_Basis_int"
adamc@870 501 | Float => "uw_Basis_float"
adamc@870 502 | String => "uw_Basis_string"
adamc@1011 503 | Char => "uw_Basis_char"
adamc@870 504 | Bool => "uw_Basis_bool"
adamc@870 505 | Time => "uw_Basis_time"
adamc@870 506 | Blob => "uw_Basis_blob"
adamc@870 507 | Channel => "uw_Basis_channel"
adamc@870 508 | Client => "uw_Basis_client"
adamc@870 509 | Nullable String => "uw_Basis_string"
adamc@873 510 | Nullable t => p_sql_ctype t ^ "*"
adamc@867 511 end
adamc@867 512
adamc@867 513 fun isBlob Blob = true
adamc@867 514 | isBlob (Nullable t) = isBlob t
adamc@867 515 | isBlob _ = false
adamc@867 516
adamc@870 517 fun isNotNull (Nullable _) = false
adamc@870 518 | isNotNull _ = true
adamc@870 519
adam@1293 520 datatype failure_mode = Error | None
adam@1293 521
adamc@866 522 type dbms = {
adamc@866 523 name : string,
adam@1682 524 randomFunction : string,
adamc@866 525 header : string,
adamc@866 526 link : string,
adamc@873 527 p_sql_type : sql_type -> string,
adamc@870 528 init : {dbstring : string,
adamc@870 529 prepared : (string * int) list,
adamc@870 530 tables : (string * (string * sql_type) list) list,
adamc@872 531 views : (string * (string * sql_type) list) list,
adamc@870 532 sequences : string list} -> Print.PD.pp_desc,
adamc@873 533 query : {loc : ErrorMsg.span, cols : sql_type list,
adamc@880 534 doCols : ({loc : ErrorMsg.span, wontLeakStrings : bool, col : int, typ : sql_type} -> Print.PD.pp_desc)
adamc@867 535 -> Print.PD.pp_desc}
adamc@867 536 -> Print.PD.pp_desc,
adamc@867 537 queryPrepared : {loc : ErrorMsg.span, id : int, query : string,
adamc@873 538 inputs : sql_type list, cols : sql_type list,
adamc@880 539 doCols : ({loc : ErrorMsg.span, wontLeakStrings : bool, col : int,
adamc@880 540 typ : sql_type} -> Print.PD.pp_desc)
adamc@879 541 -> Print.PD.pp_desc,
adamc@879 542 nested : bool}
adamc@868 543 -> Print.PD.pp_desc,
adam@1293 544 dml : ErrorMsg.span * failure_mode -> Print.PD.pp_desc,
adamc@868 545 dmlPrepared : {loc : ErrorMsg.span, id : int, dml : string,
adam@1293 546 inputs : sql_type list, mode : failure_mode} -> Print.PD.pp_desc,
adamc@878 547 nextval : {loc : ErrorMsg.span, seqName : string option, seqE : Print.PD.pp_desc} -> Print.PD.pp_desc,
adamc@874 548 nextvalPrepared : {loc : ErrorMsg.span, id : int, query : string} -> Print.PD.pp_desc,
adamc@1073 549 setval : {loc : ErrorMsg.span, seqE : Print.PD.pp_desc, count : Print.PD.pp_desc} -> Print.PD.pp_desc,
adamc@874 550 sqlifyString : string -> string,
adamc@874 551 p_cast : string * sql_type -> string,
adamc@874 552 p_blank : int * sql_type -> string,
adamc@877 553 supportsDeleteAs : bool,
adamc@886 554 supportsUpdateAs : bool,
adamc@877 555 createSequence : string -> string,
adamc@878 556 textKeysNeedLengths : bool,
adamc@879 557 supportsNextval : bool,
adamc@882 558 supportsNestedPrepared : bool,
adamc@890 559 sqlPrefix : string,
adamc@1014 560 supportsOctetLength : bool,
adamc@1014 561 trueString : string,
adamc@1196 562 falseString : string,
adamc@1196 563 onlyUnion : bool,
adam@1777 564 nestedRelops : bool,
adam@1778 565 windowFunctions: bool
adamc@866 566 }
adamc@866 567
adamc@866 568 val dbmses = ref ([] : dbms list)
adamc@866 569 val curDb = ref ({name = "",
adam@1682 570 randomFunction = "",
adamc@866 571 header = "",
adamc@866 572 link = "",
adamc@873 573 p_sql_type = fn _ => "",
adamc@867 574 init = fn _ => Print.box [],
adamc@867 575 query = fn _ => Print.box [],
adamc@868 576 queryPrepared = fn _ => Print.box [],
adamc@868 577 dml = fn _ => Print.box [],
adamc@869 578 dmlPrepared = fn _ => Print.box [],
adamc@869 579 nextval = fn _ => Print.box [],
adamc@874 580 nextvalPrepared = fn _ => Print.box [],
adamc@1073 581 setval = fn _ => Print.box [],
adamc@874 582 sqlifyString = fn s => s,
adamc@874 583 p_cast = fn _ => "",
adamc@874 584 p_blank = fn _ => "",
adamc@877 585 supportsDeleteAs = false,
adamc@886 586 supportsUpdateAs = false,
adamc@877 587 createSequence = fn _ => "",
adamc@878 588 textKeysNeedLengths = false,
adamc@879 589 supportsNextval = false,
adamc@882 590 supportsNestedPrepared = false,
adamc@890 591 sqlPrefix = "",
adamc@1014 592 supportsOctetLength = false,
adamc@1014 593 trueString = "",
adamc@1196 594 falseString = "",
adamc@1196 595 onlyUnion = false,
adam@1777 596 nestedRelops = false,
adam@1777 597 windowFunctions = false} : dbms)
adamc@866 598
adamc@866 599 fun addDbms v = dbmses := v :: !dbmses
adamc@866 600 fun setDbms s =
adamc@866 601 case List.find (fn db => #name db = s) (!dbmses) of
adamc@866 602 NONE => raise Fail ("Unknown DBMS " ^ s)
adamc@866 603 | SOME db => curDb := db
adamc@866 604 fun currentDbms () = !curDb
adamc@866 605
adamc@891 606 val dbstring = ref (NONE : string option)
adamc@891 607 fun setDbstring so = dbstring := so
adamc@891 608 fun getDbstring () = !dbstring
adamc@891 609
adamc@891 610 val exe = ref (NONE : string option)
adamc@891 611 fun setExe so = exe := so
adamc@891 612 fun getExe () = !exe
adamc@891 613
adamc@891 614 val sql = ref (NONE : string option)
adamc@891 615 fun setSql so = sql := so
adamc@891 616 fun getSql () = !sql
adamc@891 617
adam@1820 618 val coreInline = ref 5
adamc@1016 619 fun setCoreInline n = coreInline := n
adamc@1016 620 fun getCoreInline () = !coreInline
adamc@1016 621
adam@1820 622 val monoInline = ref 5
adamc@1016 623 fun setMonoInline n = monoInline := n
adamc@1016 624 fun getMonoInline () = !monoInline
adamc@1016 625
adamc@1095 626 val staticLinking = ref false
adamc@1095 627 fun setStaticLinking b = staticLinking := b
adamc@1095 628 fun getStaticLinking () = !staticLinking
adamc@1095 629
adamc@1114 630 val deadlines = ref false
adamc@1114 631 fun setDeadlines b = deadlines := b
adamc@1114 632 fun getDeadlines () = !deadlines
adamc@1114 633
adamc@1164 634 val sigFile = ref (NONE : string option)
adamc@1164 635 fun setSigFile v = sigFile := v
adamc@1164 636 fun getSigFile () = !sigFile
adamc@1164 637
adamc@1183 638 structure SS = BinarySetFn(struct
adamc@1183 639 type ord_key = string
adamc@1183 640 val compare = String.compare
adamc@1183 641 end)
adamc@1183 642
adamc@1183 643 val safeGet = ref SS.empty
adamc@1183 644 fun setSafeGets ls = safeGet := SS.addList (SS.empty, ls)
adamc@1183 645 fun isSafeGet x = SS.member (!safeGet, x)
adamc@1183 646
adam@1294 647 val onError = ref (NONE : (string * string list * string) option)
adam@1294 648 fun setOnError x = onError := x
adam@1294 649 fun getOnError () = !onError
adam@1294 650
adam@1307 651 val limits = ["messages", "clients", "headers", "page", "heap", "script",
adam@1307 652 "inputs", "subinputs", "cleanup", "deltas", "transactionals",
adam@1308 653 "globals", "database", "time"]
adam@1307 654
adam@1307 655 val limitsList = ref ([] : (string * int) list)
adam@1307 656 fun addLimit (v as (name, _)) =
adam@1307 657 if List.exists (fn name' => name' = name) limits then
adam@1308 658 (limitsList := v :: !limitsList;
adam@1308 659 if name = "time" then
adam@1308 660 setDeadlines true
adam@1308 661 else
adam@1308 662 ())
adam@1307 663 else
adam@1307 664 raise Fail ("Unknown limit category '" ^ name ^ "'")
adam@1307 665 fun limits () = !limitsList
adam@1307 666
adam@1332 667 val minHeap = ref 0
adam@1332 668 fun setMinHeap n = if n >= 0 then minHeap := n else raise Fail "Trying to set negative minHeap"
adam@1332 669 fun getMinHeap () = !minHeap
adam@1332 670
adam@1393 671 structure SS = BinarySetFn(struct
adam@1393 672 type ord_key = string
adam@1393 673 val compare = String.compare
adam@1393 674 end)
adam@1393 675
adam@1393 676 val alwaysInline = ref SS.empty
adam@1393 677 fun addAlwaysInline s = alwaysInline := SS.add (!alwaysInline, s)
adam@1393 678 fun checkAlwaysInline s = SS.member (!alwaysInline, s)
adam@1393 679
adam@1478 680 val noXsrfProtection = ref SS.empty
adam@1478 681 fun addNoXsrfProtection s = noXsrfProtection := SS.add (!noXsrfProtection, s)
adam@1478 682 fun checkNoXsrfProtection s = SS.member (!noXsrfProtection, s)
adam@1478 683
adam@1629 684 val timeFormat = ref "%c"
adam@1629 685 fun setTimeFormat v = timeFormat := v
adam@1629 686 fun getTimeFormat () = !timeFormat
adam@1629 687
adamc@765 688 end