Mercurial > urweb

annotate src/settings.sml @ 2067:88841212f0ba

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
In computing command lines, put filenames inside of quotes, to support spaces and other funky characters nicely
author Adam Chlipala <adam@chlipala.net>
date Thu, 04 Sep 2014 08:40:14 -0400
parents ced78ef1c82f
children 6b7749da1ddc 365727ff68f4
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"),
dukhovni@2045 292 ("strsindex", "ssidx"),
adamc@829 293 ("strchr", "schr"),
adamc@831 294 ("substring", "ssub"),
adamc@895 295 ("strcspn", "sspn"),
adam@1624 296 ("strlenGe", "strlenGe"),
adam@1783 297 ("mouseEvent", "uw_mouseEvent"),
adam@1783 298 ("keyEvent", "uw_keyEvent"),
adam@1404 299 ("minTime", "0"),
adamc@1061 300
adamc@1061 301 ("islower", "isLower"),
adamc@1061 302 ("isupper", "isUpper"),
adamc@1061 303 ("isalpha", "isAlpha"),
adamc@1061 304 ("isdigit", "isDigit"),
adamc@1061 305 ("isalnum", "isAlnum"),
adamc@1061 306 ("isblank", "isBlank"),
adamc@1061 307 ("isspace", "isSpace"),
adamc@1061 308 ("isxdigit", "isXdigit"),
adam@1927 309 ("isprint", "isPrint"),
adamc@1061 310 ("tolower", "toLower"),
adamc@1323 311 ("toupper", "toUpper"),
adam@1927 312 ("ord", "ord"),
adamc@1323 313
adamc@1323 314 ("checkUrl", "checkUrl"),
adam@1366 315 ("bless", "bless"),
adam@2008 316 ("blessData", "blessData"),
adam@1366 317
adam@1366 318 ("eq_time", "eq"),
adam@1366 319 ("lt_time", "lt"),
adam@1430 320 ("le_time", "le"),
adam@1430 321
adam@1625 322 ("debug", "uw_debug"),
adam@1625 323 ("naughtyDebug", "uw_debug"),
adam@1487 324
adam@1571 325 ("floatFromInt", "float"),
adam@1571 326 ("ceil", "ceil"),
adam@1571 327 ("trunc", "trunc"),
adam@1571 328 ("round", "round"),
adam@1571 329
adam@1487 330 ("now", "now"),
adam@1487 331 ("timeToString", "showTime"),
adam@1629 332 ("htmlifyTime", "showTimeHtml"),
adam@1514 333 ("toSeconds", "toSeconds"),
adam@1518 334 ("addSeconds", "addSeconds"),
adam@1555 335 ("diffInSeconds", "diffInSeconds"),
adam@1685 336 ("toMilliseconds", "toMilliseconds"),
adam@1685 337 ("diffInMilliseconds", "diffInMilliseconds"),
adam@1555 338
phurst@1986 339 ("fromDatetime", "fromDatetime"),
phurst@1986 340 ("datetimeYear", "datetimeYear"),
phurst@1986 341 ("datetimeMonth", "datetimeMonth"),
phurst@1986 342 ("datetimeDay", "datetimeDay"),
phurst@1986 343 ("datetimeHour", "datetimeHour"),
phurst@1986 344 ("datetimeMinute", "datetimeMinute"),
phurst@1986 345 ("datetimeSecond", "datetimeSecond"),
phurst@1986 346 ("datetimeDayOfWeek", "datetimeDayOfWeek"),
phurst@1986 347
phurst@1986 348
adam@1555 349 ("onClick", "uw_onClick"),
adam@1555 350 ("onDblclick", "uw_onDblclick"),
adam@1555 351 ("onKeydown", "uw_onKeydown"),
adam@1555 352 ("onKeypress", "uw_onKeypress"),
adam@1555 353 ("onKeyup", "uw_onKeyup"),
adam@1555 354 ("onMousedown", "uw_onMousedown"),
adam@1791 355 ("onMousemove", "uw_onMousemove"),
adam@1791 356 ("onMouseout", "uw_onMouseout"),
adam@1791 357 ("onMouseover", "uw_onMouseover"),
adam@1556 358 ("onMouseup", "uw_onMouseup"),
adam@1559 359 ("preventDefault", "uw_preventDefault"),
adam@1559 360 ("stopPropagation", "uw_stopPropagation"),
adam@1556 361
adam@1755 362 ("fresh", "fresh"),
adam@1755 363
adam@1755 364 ("atom", "atom"),
adam@1755 365 ("css_url", "css_url"),
adam@1785 366 ("property", "property"),
adam@1785 367 ("giveFocus", "giveFocus")]
adamc@765 368 val jsFuncs = ref jsFuncsBase
adamc@765 369 fun setJsFuncs ls = jsFuncs := foldl (fn ((k, v), m) => M.insert (m, k, v)) jsFuncsBase ls
adamc@765 370 fun jsFunc x = M.find (!jsFuncs, x)
adam@2010 371 fun addJsFunc (k, v) = jsFuncs := M.insert (!jsFuncs, k, v)
adam@1433 372 fun allJsFuncs () = M.listItemsi (!jsFuncs)
adamc@765 373
adamc@768 374 datatype pattern_kind = Exact | Prefix
adamc@768 375 datatype action = Allow | Deny
adamc@768 376 type rule = { action : action, kind : pattern_kind, pattern : string }
adamc@768 377
adamc@768 378 datatype path_kind = Any | Url | Table | Sequence | View | Relation | Cookie | Style
adam@1752 379 type rewrite = { pkind : path_kind, kind : pattern_kind, from : string, to : string, hyphenate : bool }
adamc@768 380
adamc@768 381 val rewrites = ref ([] : rewrite list)
adamc@768 382
adamc@768 383 fun subsume (pk1, pk2) =
adamc@768 384 pk1 = pk2
adamc@768 385 orelse pk2 = Any
adamc@768 386 orelse pk2 = Relation andalso (pk1 = Table orelse pk1 = Sequence orelse pk1 = View)
adamc@768 387
adamc@768 388 fun setRewriteRules ls = rewrites := ls
adamc@768 389 fun rewrite pk s =
adamc@768 390 let
adamc@768 391 fun rew (ls : rewrite list) =
adamc@768 392 case ls of
adamc@768 393 [] => s
adamc@768 394 | rewr :: ls =>
adamc@768 395 let
adamc@768 396 fun match () =
adamc@768 397 case #kind rewr of
adamc@768 398 Exact => if #from rewr = s then
adamc@768 399 SOME (size s)
adamc@768 400 else
adamc@768 401 NONE
adamc@768 402 | Prefix => if String.isPrefix (#from rewr) s then
adamc@768 403 SOME (size (#from rewr))
adamc@768 404 else
adamc@768 405 NONE
adamc@768 406 in
adamc@768 407 if subsume (pk, #pkind rewr) then
adamc@768 408 case match () of
adamc@768 409 NONE => rew ls
adam@1752 410 | SOME suffixStart =>
adam@1752 411 let
adam@1752 412 val s = #to rewr ^ String.extract (s, suffixStart, NONE)
adam@1752 413 in
adam@1752 414 if #hyphenate rewr then
adam@1752 415 String.translate (fn #"_" => "-" | ch => str ch) s
adam@1752 416 else
adam@1752 417 s
adam@1752 418 end
adamc@768 419 else
adamc@768 420 rew ls
adamc@768 421 end
adamc@768 422 in
adamc@768 423 rew (!rewrites)
adamc@768 424 end
adamc@768 425
adamc@769 426 val url = ref ([] : rule list)
adamc@769 427 val mime = ref ([] : rule list)
adam@1465 428 val request = ref ([] : rule list)
adam@1465 429 val response = ref ([] : rule list)
adam@1799 430 val env = ref ([] : rule list)
adamc@769 431
adamc@769 432 fun setUrlRules ls = url := ls
adamc@769 433 fun setMimeRules ls = mime := ls
adam@1465 434 fun setRequestHeaderRules ls = request := ls
adam@1465 435 fun setResponseHeaderRules ls = response := ls
adam@1799 436 fun setEnvVarRules ls = env := ls
adamc@769 437
adamc@770 438 fun getUrlRules () = !url
adamc@770 439 fun getMimeRules () = !mime
adam@1465 440 fun getRequestHeaderRules () = !request
adam@1465 441 fun getResponseHeaderRules () = !response
adam@1799 442 fun getEnvVarRules () = !env
adamc@770 443
adamc@769 444 fun check f rules s =
adamc@769 445 let
adamc@769 446 fun chk (ls : rule list) =
adamc@769 447 case ls of
adamc@769 448 [] => false
adamc@769 449 | rule :: ls =>
adamc@769 450 let
adamc@769 451 val matches =
adamc@769 452 case #kind rule of
adamc@769 453 Exact => #pattern rule = s
adamc@769 454 | Prefix => String.isPrefix (#pattern rule) s
adamc@769 455 in
adamc@769 456 if matches then
adamc@769 457 case #action rule of
adamc@769 458 Allow => true
adamc@769 459 | Deny => false
adamc@769 460 else
adamc@769 461 chk ls
adamc@769 462 end
adamc@769 463 in
adamc@769 464 f s andalso chk (!rules)
adamc@769 465 end
adamc@769 466
adamc@769 467 val checkUrl = check (fn _ => true) url
adam@1465 468
grrwlf@2024 469 val validMime = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"/" orelse ch = #"-" orelse ch = #"." orelse ch = #"+")
adam@1799 470 val validEnv = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"_" orelse ch = #".")
adam@1465 471
adam@1465 472 val checkMime = check validMime mime
adam@1465 473 val checkRequestHeader = check validMime request
adam@1465 474 val checkResponseHeader = check validMime response
adam@1799 475 val checkEnvVar = check validEnv env
adamc@769 476
adamc@855 477
adamc@855 478 type protocol = {
adamc@855 479 name : string,
adamc@1096 480 compile : string,
adamc@1095 481 linkStatic : string,
adamc@1095 482 linkDynamic : string,
adamc@1164 483 persistent : bool,
adamc@1164 484 code : unit -> Print.PD.pp_desc
adamc@855 485 }
adamc@855 486 val protocols = ref ([] : protocol list)
adamc@855 487 fun addProtocol p = protocols := p :: !protocols
adamc@855 488 fun getProtocol s = List.find (fn p => #name p = s) (!protocols)
adamc@855 489
ezyang@1739 490 fun clibFile s = OS.Path.joinDirFile {dir = libC (),
adamc@855 491 file = s}
adamc@855 492
adamc@865 493 val curProto = ref {name = "",
adamc@1096 494 compile = "",
adamc@1095 495 linkStatic = "",
adamc@1095 496 linkDynamic = "",
adamc@1164 497 persistent = false,
adamc@1164 498 code = fn () => Print.box []}
adamc@856 499 fun setProtocol name =
adamc@856 500 case getProtocol name of
adamc@856 501 NONE => raise Fail ("Unknown protocol " ^ name)
adamc@856 502 | SOME p => curProto := p
adamc@855 503 fun currentProtocol () = !curProto
adamc@855 504
adamc@857 505 val debug = ref false
adamc@857 506 fun setDebug b = debug := b
adamc@857 507 fun getDebug () = !debug
adamc@857 508
adamc@867 509 datatype sql_type =
adamc@867 510 Int
adamc@867 511 | Float
adamc@867 512 | String
adamc@1011 513 | Char
adamc@867 514 | Bool
adamc@867 515 | Time
adamc@867 516 | Blob
adamc@867 517 | Channel
adamc@867 518 | Client
adamc@867 519 | Nullable of sql_type
adamc@867 520
adamc@873 521 fun p_sql_ctype t =
adamc@867 522 let
adamc@867 523 open Print.PD
adamc@867 524 open Print
adamc@867 525 in
adamc@867 526 case t of
adamc@870 527 Int => "uw_Basis_int"
adamc@870 528 | Float => "uw_Basis_float"
adamc@870 529 | String => "uw_Basis_string"
adamc@1011 530 | Char => "uw_Basis_char"
adamc@870 531 | Bool => "uw_Basis_bool"
adamc@870 532 | Time => "uw_Basis_time"
adamc@870 533 | Blob => "uw_Basis_blob"
adamc@870 534 | Channel => "uw_Basis_channel"
adamc@870 535 | Client => "uw_Basis_client"
adamc@870 536 | Nullable String => "uw_Basis_string"
adamc@873 537 | Nullable t => p_sql_ctype t ^ "*"
adamc@867 538 end
adamc@867 539
adamc@867 540 fun isBlob Blob = true
adamc@867 541 | isBlob (Nullable t) = isBlob t
adamc@867 542 | isBlob _ = false
adamc@867 543
adamc@870 544 fun isNotNull (Nullable _) = false
adamc@870 545 | isNotNull _ = true
adamc@870 546
adam@1293 547 datatype failure_mode = Error | None
adam@1293 548
adamc@866 549 type dbms = {
adamc@866 550 name : string,
adam@1682 551 randomFunction : string,
adamc@866 552 header : string,
adamc@866 553 link : string,
adamc@873 554 p_sql_type : sql_type -> string,
adamc@870 555 init : {dbstring : string,
adamc@870 556 prepared : (string * int) list,
adamc@870 557 tables : (string * (string * sql_type) list) list,
adamc@872 558 views : (string * (string * sql_type) list) list,
adamc@870 559 sequences : string list} -> Print.PD.pp_desc,
adamc@873 560 query : {loc : ErrorMsg.span, cols : sql_type list,
adamc@880 561 doCols : ({loc : ErrorMsg.span, wontLeakStrings : bool, col : int, typ : sql_type} -> Print.PD.pp_desc)
adamc@867 562 -> Print.PD.pp_desc}
adamc@867 563 -> Print.PD.pp_desc,
adamc@867 564 queryPrepared : {loc : ErrorMsg.span, id : int, query : string,
adamc@873 565 inputs : sql_type list, cols : sql_type list,
adamc@880 566 doCols : ({loc : ErrorMsg.span, wontLeakStrings : bool, col : int,
adamc@880 567 typ : sql_type} -> Print.PD.pp_desc)
adamc@879 568 -> Print.PD.pp_desc,
adamc@879 569 nested : bool}
adamc@868 570 -> Print.PD.pp_desc,
adam@1293 571 dml : ErrorMsg.span * failure_mode -> Print.PD.pp_desc,
adamc@868 572 dmlPrepared : {loc : ErrorMsg.span, id : int, dml : string,
adam@1293 573 inputs : sql_type list, mode : failure_mode} -> Print.PD.pp_desc,
adamc@878 574 nextval : {loc : ErrorMsg.span, seqName : string option, seqE : Print.PD.pp_desc} -> Print.PD.pp_desc,
adamc@874 575 nextvalPrepared : {loc : ErrorMsg.span, id : int, query : string} -> Print.PD.pp_desc,
adamc@1073 576 setval : {loc : ErrorMsg.span, seqE : Print.PD.pp_desc, count : Print.PD.pp_desc} -> Print.PD.pp_desc,
adamc@874 577 sqlifyString : string -> string,
adamc@874 578 p_cast : string * sql_type -> string,
adamc@874 579 p_blank : int * sql_type -> string,
adamc@877 580 supportsDeleteAs : bool,
adamc@886 581 supportsUpdateAs : bool,
adamc@877 582 createSequence : string -> string,
adamc@878 583 textKeysNeedLengths : bool,
adamc@879 584 supportsNextval : bool,
adamc@882 585 supportsNestedPrepared : bool,
adamc@890 586 sqlPrefix : string,
adamc@1014 587 supportsOctetLength : bool,
adamc@1014 588 trueString : string,
adamc@1196 589 falseString : string,
adamc@1196 590 onlyUnion : bool,
adam@1777 591 nestedRelops : bool,
adam@1778 592 windowFunctions: bool
adamc@866 593 }
adamc@866 594
adamc@866 595 val dbmses = ref ([] : dbms list)
adamc@866 596 val curDb = ref ({name = "",
adam@1682 597 randomFunction = "",
adamc@866 598 header = "",
adamc@866 599 link = "",
adamc@873 600 p_sql_type = fn _ => "",
adamc@867 601 init = fn _ => Print.box [],
adamc@867 602 query = fn _ => Print.box [],
adamc@868 603 queryPrepared = fn _ => Print.box [],
adamc@868 604 dml = fn _ => Print.box [],
adamc@869 605 dmlPrepared = fn _ => Print.box [],
adamc@869 606 nextval = fn _ => Print.box [],
adamc@874 607 nextvalPrepared = fn _ => Print.box [],
adamc@1073 608 setval = fn _ => Print.box [],
adamc@874 609 sqlifyString = fn s => s,
adamc@874 610 p_cast = fn _ => "",
adamc@874 611 p_blank = fn _ => "",
adamc@877 612 supportsDeleteAs = false,
adamc@886 613 supportsUpdateAs = false,
adamc@877 614 createSequence = fn _ => "",
adamc@878 615 textKeysNeedLengths = false,
adamc@879 616 supportsNextval = false,
adamc@882 617 supportsNestedPrepared = false,
adamc@890 618 sqlPrefix = "",
adamc@1014 619 supportsOctetLength = false,
adamc@1014 620 trueString = "",
adamc@1196 621 falseString = "",
adamc@1196 622 onlyUnion = false,
adam@1777 623 nestedRelops = false,
adam@1777 624 windowFunctions = false} : dbms)
adamc@866 625
adamc@866 626 fun addDbms v = dbmses := v :: !dbmses
adamc@866 627 fun setDbms s =
adamc@866 628 case List.find (fn db => #name db = s) (!dbmses) of
adamc@866 629 NONE => raise Fail ("Unknown DBMS " ^ s)
adamc@866 630 | SOME db => curDb := db
adamc@866 631 fun currentDbms () = !curDb
adamc@866 632
adamc@891 633 val dbstring = ref (NONE : string option)
adamc@891 634 fun setDbstring so = dbstring := so
adamc@891 635 fun getDbstring () = !dbstring
adamc@891 636
adamc@891 637 val exe = ref (NONE : string option)
adamc@891 638 fun setExe so = exe := so
adamc@891 639 fun getExe () = !exe
adamc@891 640
adamc@891 641 val sql = ref (NONE : string option)
adamc@891 642 fun setSql so = sql := so
adamc@891 643 fun getSql () = !sql
adamc@891 644
adam@1820 645 val coreInline = ref 5
adamc@1016 646 fun setCoreInline n = coreInline := n
adamc@1016 647 fun getCoreInline () = !coreInline
adamc@1016 648
adam@1820 649 val monoInline = ref 5
adamc@1016 650 fun setMonoInline n = monoInline := n
adamc@1016 651 fun getMonoInline () = !monoInline
adamc@1016 652
adamc@1095 653 val staticLinking = ref false
adamc@1095 654 fun setStaticLinking b = staticLinking := b
adamc@1095 655 fun getStaticLinking () = !staticLinking
adamc@1095 656
adamc@1114 657 val deadlines = ref false
adamc@1114 658 fun setDeadlines b = deadlines := b
adamc@1114 659 fun getDeadlines () = !deadlines
adamc@1114 660
adamc@1164 661 val sigFile = ref (NONE : string option)
adamc@1164 662 fun setSigFile v = sigFile := v
adamc@1164 663 fun getSigFile () = !sigFile
adamc@1164 664
adamc@1183 665 structure SS = BinarySetFn(struct
adamc@1183 666 type ord_key = string
adamc@1183 667 val compare = String.compare
adamc@1183 668 end)
adamc@1183 669
adamc@1183 670 val safeGet = ref SS.empty
adamc@1183 671 fun setSafeGets ls = safeGet := SS.addList (SS.empty, ls)
adamc@1183 672 fun isSafeGet x = SS.member (!safeGet, x)
adamc@1183 673
adam@1294 674 val onError = ref (NONE : (string * string list * string) option)
adam@1294 675 fun setOnError x = onError := x
adam@1294 676 fun getOnError () = !onError
adam@1294 677
adam@1307 678 val limits = ["messages", "clients", "headers", "page", "heap", "script",
adam@1307 679 "inputs", "subinputs", "cleanup", "deltas", "transactionals",
adam@1308 680 "globals", "database", "time"]
adam@1307 681
adam@1307 682 val limitsList = ref ([] : (string * int) list)
adam@1307 683 fun addLimit (v as (name, _)) =
adam@1307 684 if List.exists (fn name' => name' = name) limits then
adam@1308 685 (limitsList := v :: !limitsList;
adam@1308 686 if name = "time" then
adam@1308 687 setDeadlines true
adam@1308 688 else
adam@1308 689 ())
adam@1307 690 else
adam@1307 691 raise Fail ("Unknown limit category '" ^ name ^ "'")
adam@1307 692 fun limits () = !limitsList
adam@1307 693
adam@1332 694 val minHeap = ref 0
adam@1332 695 fun setMinHeap n = if n >= 0 then minHeap := n else raise Fail "Trying to set negative minHeap"
adam@1332 696 fun getMinHeap () = !minHeap
adam@1332 697
adam@1393 698 structure SS = BinarySetFn(struct
adam@1393 699 type ord_key = string
adam@1393 700 val compare = String.compare
adam@1393 701 end)
adam@1393 702
adam@1393 703 val alwaysInline = ref SS.empty
adam@1393 704 fun addAlwaysInline s = alwaysInline := SS.add (!alwaysInline, s)
adam@1393 705 fun checkAlwaysInline s = SS.member (!alwaysInline, s)
adam@1393 706
adam@1966 707 val neverInline = ref SS.empty
adam@1966 708 fun addNeverInline s = neverInline := SS.add (!neverInline, s)
adam@1966 709 fun checkNeverInline s = SS.member (!neverInline, s)
adam@1966 710
adam@1478 711 val noXsrfProtection = ref SS.empty
adam@1478 712 fun addNoXsrfProtection s = noXsrfProtection := SS.add (!noXsrfProtection, s)
adam@1478 713 fun checkNoXsrfProtection s = SS.member (!noXsrfProtection, s)
adam@1478 714
adam@1629 715 val timeFormat = ref "%c"
adam@1629 716 fun setTimeFormat v = timeFormat := v
adam@1629 717 fun getTimeFormat () = !timeFormat
adam@1629 718
adam@1953 719 fun lowercase s =
adam@1953 720 case s of
adam@1953 721 "" => ""
adam@1953 722 | _ => str (Char.toLower (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
adam@1953 723
adam@1953 724 fun capitalize s =
adam@1953 725 case s of
adam@1953 726 "" => ""
adam@1953 727 | _ => str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
adam@1953 728
adam@1953 729 val mangle = ref true
adam@1953 730 fun setMangleSql x = mangle := x
adam@1953 731 fun mangleSqlTable s = if !mangle then "uw_" ^ capitalize s
adam@1953 732 else if #name (currentDbms ()) = "mysql" then capitalize s
adam@1959 733 else lowercase s
adam@1953 734 fun mangleSql s = if !mangle then "uw_" ^ s
adam@1953 735 else if #name (currentDbms ()) = "mysql" then lowercase s
adam@1959 736 else lowercase s
adam@1953 737 fun mangleSqlCatalog s = if !mangle then "uw_" ^ s else lowercase s
adam@1953 738
adam@1956 739 val html5 = ref false
adam@1956 740 fun setIsHtml5 b = html5 := b
adam@1956 741 fun getIsHtml5 () = !html5
adam@1956 742
adam@2010 743 val less = ref false
adam@2010 744 fun setLessSafeFfi b = less := b
adam@2010 745 fun getLessSafeFfi () = !less
adam@2010 746
adam@2046 747 structure SM = BinaryMapFn(struct
adam@2046 748 type ord_key = string
adam@2046 749 val compare = String.compare
adam@2046 750 end)
adam@2046 751
adam@2046 752 val noMimeFile = ref false
adam@2046 753
adam@2046 754 fun noMime () =
adam@2046 755 (TextIO.output (TextIO.stdErr, "WARNING: Error opening /etc/mime.types. Static files will be served with no suggested MIME types.\n");
adam@2046 756 noMimeFile := true;
adam@2046 757 SM.empty)
adam@2046 758
adam@2046 759 fun readMimeTypes () =
adam@2046 760 let
adam@2046 761 val inf = TextIO.openIn "/etc/mime.types"
adam@2046 762
adam@2046 763 fun loop m =
adam@2046 764 case TextIO.inputLine inf of
adam@2046 765 NONE => m
adam@2046 766 | SOME line =>
adam@2046 767 if size line > 0 andalso String.sub (line, 0) = #"#" then
adam@2046 768 loop m
adam@2046 769 else
adam@2046 770 case String.tokens Char.isSpace line of
adam@2046 771 typ :: exts =>
adam@2046 772 loop (foldl (fn (ext, m) => SM.insert (m, ext, typ)) m exts)
adam@2046 773 | _ => loop m
adam@2046 774 in
adam@2046 775 loop SM.empty
adam@2046 776 before TextIO.closeIn inf
adam@2046 777 end handle IO.Io _ => noMime ()
adam@2046 778 | OS.SysErr _ => noMime ()
adam@2046 779
adam@2046 780 val mimeTypes = ref (NONE : string SM.map option)
adam@2046 781
adam@2046 782 fun getMimeTypes () =
adam@2046 783 case !mimeTypes of
adam@2046 784 SOME m => m
adam@2046 785 | NONE =>
adam@2046 786 let
adam@2046 787 val m = readMimeTypes ()
adam@2046 788 in
adam@2046 789 mimeTypes := SOME m;
adam@2046 790 m
adam@2046 791 end
adam@2046 792
adam@2046 793 fun mimeTypeOf filename =
adam@2046 794 case OS.Path.ext filename of
adam@2046 795 NONE => (if !noMimeFile then
adam@2046 796 ()
adam@2046 797 else
adam@2046 798 TextIO.output (TextIO.stdErr, "WARNING: No extension found in filename '" ^ filename ^ "'. Header 'Content-Type' will be omitted in HTTP responses.\n");
adam@2046 799 NONE)
adam@2046 800 | SOME ext =>
adam@2046 801 let
adam@2046 802 val to = SM.find (getMimeTypes (), ext)
adam@2046 803 in
adam@2046 804 case to of
adam@2046 805 NONE => if !noMimeFile then
adam@2046 806 ()
adam@2046 807 else
adam@2046 808 TextIO.output (TextIO.stdErr, "WARNING: No MIME type known for extension '" ^ ext ^ "'. Header 'Content-Type' will be omitted in HTTP responses.\n")
adam@2046 809 | _ => ();
adam@2046 810 to
adam@2046 811 end
adam@2046 812
adam@2046 813 val files = ref (SM.empty : (string * {Uri : string, ContentType : string option, LastModified : Time.time, Bytes : Word8Vector.vector}) SM.map)
adam@2046 814
adam@2046 815 val filePath = ref "."
adam@2046 816
adam@2046 817 fun setFilePath path = filePath := path
adam@2046 818
adam@2046 819 fun addFile {Uri, LoadFromFilename} =
adam@2046 820 let
adam@2046 821 val path = OS.Path.joinDirFile {dir = !filePath, file = LoadFromFilename}
adam@2046 822 in
adam@2046 823 case SM.find (!files, Uri) of
adam@2046 824 SOME (path', _) =>
adam@2046 825 if path' = path then
adam@2046 826 ()
adam@2046 827 else
adam@2046 828 ErrorMsg.error ("Two different files requested for URI " ^ Uri)
adam@2046 829 | NONE =>
adam@2046 830 let
adam@2046 831 val inf = BinIO.openIn path
adam@2046 832 in
adam@2046 833 files := SM.insert (!files,
adam@2046 834 Uri,
adam@2046 835 (path,
adam@2046 836 {Uri = Uri,
adam@2046 837 ContentType = mimeTypeOf path,
adam@2046 838 LastModified = OS.FileSys.modTime path,
adam@2046 839 Bytes = BinIO.inputAll inf}));
adam@2046 840 BinIO.closeIn inf
adam@2046 841 end
adam@2046 842 end handle IO.Io _ =>
adam@2046 843 ErrorMsg.error ("Error loading file " ^ LoadFromFilename)
adam@2046 844 | OS.SysErr (s, _) =>
adam@2046 845 ErrorMsg.error ("Error loading file " ^ LoadFromFilename ^ " (" ^ s ^ ")")
adam@2046 846
adam@2046 847 fun listFiles () = map #2 (SM.listItems (!files))
adam@2046 848
adamc@765 849 end