Mercurial > urweb

annotate src/settings.sml @ 2043:e762c96fffb7

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