Mercurial > urweb

annotate src/settings.sml @ 2191:849404a3af27

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Change behavior of SQL equality to do the intuitive thing for nullable types
author Adam Chlipala <adam@chlipala.net>
date Sun, 01 Nov 2015 17:02:16 -0500
parents 43393a4a66ce
children fb113569519e 985c8016b592
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",
ziv@2130 179 "onContextmenu",
adam@1555 180 "onKeydown",
adam@1555 181 "onKeypress",
adam@1555 182 "onKeyup",
adam@1555 183 "onMousedown",
ziv@2130 184 "onMouseenter",
ziv@2130 185 "onMouseleave",
adam@1791 186 "onMousemove",
adam@1791 187 "onMouseout",
adam@1791 188 "onMouseover",
adam@1556 189 "onMouseup",
adam@1559 190 "preventDefault",
adam@1559 191 "stopPropagation",
adam@1785 192 "fresh",
adam@1952 193 "giveFocus",
adam@1952 194 "currentUrlHasPost",
adam@1952 195 "currentUrlHasQueryString",
adam@1952 196 "currentUrl"]
adamc@1171 197
adamc@1171 198 val benign = ref benignBase
adamc@1171 199 fun setBenignEffectful ls = benign := S.addList (benignBase, ls)
adam@2010 200 fun addBenignEffectful x = benign := S.add (!benign, x)
adamc@1171 201 fun isBenignEffectful x = S.member (!benign, x)
adamc@1171 202
adam@1595 203 val clientBase = basis ["get_client_source",
adamc@841 204 "current",
adamc@765 205 "alert",
adam@1290 206 "confirm",
adamc@765 207 "recv",
adamc@765 208 "sleep",
adamc@765 209 "spawn",
adamc@765 210 "onError",
adamc@765 211 "onFail",
adamc@765 212 "onConnectFail",
adamc@765 213 "onDisconnect",
adamc@895 214 "onServerError",
adam@1783 215 "mouseEvent",
adam@1783 216 "keyEvent",
adam@1555 217 "onClick",
ziv@2130 218 "onContextmenu",
adam@1555 219 "onDblclick",
adam@1555 220 "onKeydown",
adam@1555 221 "onKeypress",
adam@1555 222 "onKeyup",
adam@1555 223 "onMousedown",
ziv@2130 224 "onMouseenter",
ziv@2130 225 "onMouseleave",
adam@1791 226 "onMousemove",
adam@1791 227 "onMouseout",
adam@1791 228 "onMouseover",
adam@1559 229 "onMouseup",
adam@1559 230 "preventDefault",
adam@1785 231 "stopPropagation",
adam@1785 232 "giveFocus"]
adamc@765 233 val client = ref clientBase
adamc@765 234 fun setClientOnly ls = client := S.addList (clientBase, ls)
adam@2010 235 fun addClientOnly x = client := S.add (!client, x)
adamc@765 236 fun isClientOnly x = S.member (!client, x)
adamc@765 237
adamc@765 238 val serverBase = basis ["requestHeader",
adamc@765 239 "query",
adamc@765 240 "dml",
adamc@765 241 "nextval",
adamc@1073 242 "setval",
adamc@765 243 "channel",
adam@1787 244 "send",
adam@1787 245 "fieldName",
adam@1787 246 "fieldValue",
adam@1787 247 "remainingFields",
adam@1787 248 "firstFormField"]
adamc@765 249 val server = ref serverBase
adamc@765 250 fun setServerOnly ls = server := S.addList (serverBase, ls)
adam@2010 251 fun addServerOnly x = server := S.add (!server, x)
adamc@765 252 fun isServerOnly x = S.member (!server, x)
adamc@765 253
adamc@765 254 val basisM = foldl (fn ((k, v : string), m) => M.insert (m, ("Basis", k), v)) M.empty
adamc@765 255
adamc@765 256 val jsFuncsBase = basisM [("alert", "alert"),
adam@1599 257 ("stringToTime", "stringToTime"),
adam@1599 258 ("stringToTime_error", "stringToTime_error"),
adam@1609 259 ("timef", "strftime"),
adam@1290 260 ("confirm", "confrm"),
adamc@765 261 ("get_client_source", "sg"),
adamc@841 262 ("current", "scur"),
adamc@765 263 ("htmlifyBool", "bs"),
adamc@765 264 ("htmlifyFloat", "ts"),
adamc@765 265 ("htmlifyInt", "ts"),
adamc@765 266 ("htmlifyString", "eh"),
adamc@765 267 ("new_client_source", "sc"),
adamc@765 268 ("set_client_source", "sv"),
adamc@838 269 ("stringToFloat", "pflo"),
adamc@838 270 ("stringToInt", "pio"),
adamc@765 271 ("stringToFloat_error", "pfl"),
adamc@765 272 ("stringToInt_error", "pi"),
adamc@765 273 ("urlifyInt", "ts"),
adamc@765 274 ("urlifyFloat", "ts"),
adam@1360 275 ("urlifyTime", "ts"),
adamc@765 276 ("urlifyString", "uf"),
adamc@912 277 ("urlifyBool", "ub"),
adamc@765 278 ("recv", "rv"),
adamc@765 279 ("strcat", "cat"),
adamc@765 280 ("intToString", "ts"),
adamc@765 281 ("floatToString", "ts"),
adamc@821 282 ("charToString", "ts"),
adamc@765 283 ("onError", "onError"),
adamc@765 284 ("onFail", "onFail"),
adamc@765 285 ("onConnectFail", "onConnectFail"),
adamc@765 286 ("onDisconnect", "onDisconnect"),
adamc@798 287 ("onServerError", "onServerError"),
adamc@1108 288 ("attrifyString", "atr"),
adamc@798 289 ("attrifyInt", "ts"),
adamc@798 290 ("attrifyFloat", "ts"),
adamc@820 291 ("attrifyBool", "bs"),
adamc@821 292 ("boolToString", "ts"),
adamc@1057 293 ("str1", "id"),
adamc@821 294 ("strsub", "sub"),
adamc@828 295 ("strsuffix", "suf"),
adamc@829 296 ("strlen", "slen"),
adamc@829 297 ("strindex", "sidx"),
dukhovni@2045 298 ("strsindex", "ssidx"),
adamc@829 299 ("strchr", "schr"),
adamc@831 300 ("substring", "ssub"),
adamc@895 301 ("strcspn", "sspn"),
adam@1624 302 ("strlenGe", "strlenGe"),
adam@1783 303 ("mouseEvent", "uw_mouseEvent"),
adam@1783 304 ("keyEvent", "uw_keyEvent"),
adam@1404 305 ("minTime", "0"),
adam@2097 306 ("stringToBool_error", "s2be"),
adam@2097 307 ("stringToBool", "s2b"),
adamc@1061 308
adamc@1061 309 ("islower", "isLower"),
adamc@1061 310 ("isupper", "isUpper"),
adamc@1061 311 ("isalpha", "isAlpha"),
adamc@1061 312 ("isdigit", "isDigit"),
adamc@1061 313 ("isalnum", "isAlnum"),
adamc@1061 314 ("isblank", "isBlank"),
adamc@1061 315 ("isspace", "isSpace"),
adamc@1061 316 ("isxdigit", "isXdigit"),
adam@1927 317 ("isprint", "isPrint"),
adamc@1061 318 ("tolower", "toLower"),
adamc@1323 319 ("toupper", "toUpper"),
adam@1927 320 ("ord", "ord"),
adamc@1323 321
adamc@1323 322 ("checkUrl", "checkUrl"),
adam@1366 323 ("bless", "bless"),
adam@2008 324 ("blessData", "blessData"),
adam@1366 325
adam@1366 326 ("eq_time", "eq"),
adam@1366 327 ("lt_time", "lt"),
adam@1430 328 ("le_time", "le"),
adam@1430 329
adam@1625 330 ("debug", "uw_debug"),
adam@1625 331 ("naughtyDebug", "uw_debug"),
adam@1487 332
adam@1571 333 ("floatFromInt", "float"),
adam@1571 334 ("ceil", "ceil"),
adam@1571 335 ("trunc", "trunc"),
adam@1571 336 ("round", "round"),
adam@1571 337
adam@1487 338 ("now", "now"),
adam@1487 339 ("timeToString", "showTime"),
adam@1629 340 ("htmlifyTime", "showTimeHtml"),
adam@1514 341 ("toSeconds", "toSeconds"),
adam@1518 342 ("addSeconds", "addSeconds"),
adam@1555 343 ("diffInSeconds", "diffInSeconds"),
adam@1685 344 ("toMilliseconds", "toMilliseconds"),
adam@2187 345 ("fromMilliseconds", "fromMilliseconds"),
adam@1685 346 ("diffInMilliseconds", "diffInMilliseconds"),
adam@1555 347
phurst@1986 348 ("fromDatetime", "fromDatetime"),
phurst@1986 349 ("datetimeYear", "datetimeYear"),
phurst@1986 350 ("datetimeMonth", "datetimeMonth"),
phurst@1986 351 ("datetimeDay", "datetimeDay"),
phurst@1986 352 ("datetimeHour", "datetimeHour"),
phurst@1986 353 ("datetimeMinute", "datetimeMinute"),
phurst@1986 354 ("datetimeSecond", "datetimeSecond"),
phurst@1986 355 ("datetimeDayOfWeek", "datetimeDayOfWeek"),
phurst@1986 356
phurst@1986 357
adam@1555 358 ("onClick", "uw_onClick"),
ziv@2130 359 ("onContextmenu", "uw_onContextmenu"),
adam@1555 360 ("onDblclick", "uw_onDblclick"),
adam@1555 361 ("onKeydown", "uw_onKeydown"),
adam@1555 362 ("onKeypress", "uw_onKeypress"),
adam@1555 363 ("onKeyup", "uw_onKeyup"),
adam@1555 364 ("onMousedown", "uw_onMousedown"),
ziv@2130 365 ("onMouseenter", "uw_onMouseenter"),
ziv@2130 366 ("onMouseleave", "uw_onMouseleave"),
adam@1791 367 ("onMousemove", "uw_onMousemove"),
adam@1791 368 ("onMouseout", "uw_onMouseout"),
adam@1791 369 ("onMouseover", "uw_onMouseover"),
adam@1556 370 ("onMouseup", "uw_onMouseup"),
adam@1559 371 ("preventDefault", "uw_preventDefault"),
adam@1559 372 ("stopPropagation", "uw_stopPropagation"),
adam@1556 373
adam@1755 374 ("fresh", "fresh"),
adam@1755 375
adam@1755 376 ("atom", "atom"),
adam@1755 377 ("css_url", "css_url"),
adam@1785 378 ("property", "property"),
adam@2189 379 ("giveFocus", "giveFocus"),
adam@2189 380
adam@2189 381 ("htmlifySpecialChar", "htmlifySpecialChar"),
adam@2189 382 ("chr", "chr")]
adamc@765 383 val jsFuncs = ref jsFuncsBase
adamc@765 384 fun setJsFuncs ls = jsFuncs := foldl (fn ((k, v), m) => M.insert (m, k, v)) jsFuncsBase ls
adamc@765 385 fun jsFunc x = M.find (!jsFuncs, x)
adam@2010 386 fun addJsFunc (k, v) = jsFuncs := M.insert (!jsFuncs, k, v)
adam@1433 387 fun allJsFuncs () = M.listItemsi (!jsFuncs)
adamc@765 388
adamc@768 389 datatype pattern_kind = Exact | Prefix
adamc@768 390 datatype action = Allow | Deny
adamc@768 391 type rule = { action : action, kind : pattern_kind, pattern : string }
adamc@768 392
adamc@768 393 datatype path_kind = Any | Url | Table | Sequence | View | Relation | Cookie | Style
adam@1752 394 type rewrite = { pkind : path_kind, kind : pattern_kind, from : string, to : string, hyphenate : bool }
adamc@768 395
adam@2096 396 fun pak2s pak =
adam@2096 397 case pak of
adam@2096 398 Exact => "Exact"
adam@2096 399 | Prefix => "Prefix"
adam@2096 400 fun pk2s pk =
adam@2096 401 case pk of
adam@2096 402 Any => "Any"
adam@2096 403 | Url => "Url"
adam@2096 404 | Table => "Table"
adam@2096 405 | Sequence => "Sequence"
adam@2096 406 | View => "View"
adam@2096 407 | Relation => "Relation"
adam@2096 408 | Cookie => "Cookie"
adam@2096 409 | Style => "Style"
adam@2096 410 fun r2s (r : rewrite) = pak2s (#kind r) ^ " " ^ pk2s (#pkind r) ^ ", from<" ^ #from r ^ ">, to<" ^ #to r ^ ">"
adam@2096 411
adamc@768 412 val rewrites = ref ([] : rewrite list)
adamc@768 413
adamc@768 414 fun subsume (pk1, pk2) =
adamc@768 415 pk1 = pk2
adamc@768 416 orelse pk2 = Any
adamc@768 417 orelse pk2 = Relation andalso (pk1 = Table orelse pk1 = Sequence orelse pk1 = View)
adamc@768 418
adamc@768 419 fun setRewriteRules ls = rewrites := ls
adamc@768 420 fun rewrite pk s =
adamc@768 421 let
adamc@768 422 fun rew (ls : rewrite list) =
adamc@768 423 case ls of
adamc@768 424 [] => s
adamc@768 425 | rewr :: ls =>
adamc@768 426 let
adamc@768 427 fun match () =
adamc@768 428 case #kind rewr of
adamc@768 429 Exact => if #from rewr = s then
adamc@768 430 SOME (size s)
adamc@768 431 else
adamc@768 432 NONE
adamc@768 433 | Prefix => if String.isPrefix (#from rewr) s then
adamc@768 434 SOME (size (#from rewr))
adamc@768 435 else
adamc@768 436 NONE
adamc@768 437 in
adamc@768 438 if subsume (pk, #pkind rewr) then
adamc@768 439 case match () of
adamc@768 440 NONE => rew ls
adam@1752 441 | SOME suffixStart =>
adam@1752 442 let
adam@1752 443 val s = #to rewr ^ String.extract (s, suffixStart, NONE)
adam@1752 444 in
adam@1752 445 if #hyphenate rewr then
adam@1752 446 String.translate (fn #"_" => "-" | ch => str ch) s
adam@1752 447 else
adam@1752 448 s
adam@1752 449 end
adamc@768 450 else
adamc@768 451 rew ls
adamc@768 452 end
adamc@768 453 in
adamc@768 454 rew (!rewrites)
adamc@768 455 end
adamc@768 456
adamc@769 457 val url = ref ([] : rule list)
adamc@769 458 val mime = ref ([] : rule list)
adam@1465 459 val request = ref ([] : rule list)
adam@1465 460 val response = ref ([] : rule list)
adam@1799 461 val env = ref ([] : rule list)
adamc@769 462
adamc@769 463 fun setUrlRules ls = url := ls
adamc@769 464 fun setMimeRules ls = mime := ls
adam@1465 465 fun setRequestHeaderRules ls = request := ls
adam@1465 466 fun setResponseHeaderRules ls = response := ls
adam@1799 467 fun setEnvVarRules ls = env := ls
adamc@769 468
adamc@770 469 fun getUrlRules () = !url
adamc@770 470 fun getMimeRules () = !mime
adam@1465 471 fun getRequestHeaderRules () = !request
adam@1465 472 fun getResponseHeaderRules () = !response
adam@1799 473 fun getEnvVarRules () = !env
adamc@770 474
adamc@769 475 fun check f rules s =
adamc@769 476 let
adamc@769 477 fun chk (ls : rule list) =
adamc@769 478 case ls of
adamc@769 479 [] => false
adamc@769 480 | rule :: ls =>
adamc@769 481 let
adamc@769 482 val matches =
adamc@769 483 case #kind rule of
adamc@769 484 Exact => #pattern rule = s
adamc@769 485 | Prefix => String.isPrefix (#pattern rule) s
adamc@769 486 in
adamc@769 487 if matches then
adamc@769 488 case #action rule of
adamc@769 489 Allow => true
adamc@769 490 | Deny => false
adamc@769 491 else
adamc@769 492 chk ls
adamc@769 493 end
adamc@769 494 in
adamc@769 495 f s andalso chk (!rules)
adamc@769 496 end
adamc@769 497
adamc@769 498 val checkUrl = check (fn _ => true) url
adam@1465 499
grrwlf@2024 500 val validMime = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"/" orelse ch = #"-" orelse ch = #"." orelse ch = #"+")
adam@1799 501 val validEnv = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"_" orelse ch = #".")
adam@1465 502
adam@1465 503 val checkMime = check validMime mime
adam@1465 504 val checkRequestHeader = check validMime request
adam@1465 505 val checkResponseHeader = check validMime response
adam@1799 506 val checkEnvVar = check validEnv env
adamc@769 507
adamc@855 508
adamc@855 509 type protocol = {
adamc@855 510 name : string,
adamc@1096 511 compile : string,
adamc@1095 512 linkStatic : string,
adamc@1095 513 linkDynamic : string,
adamc@1164 514 persistent : bool,
adamc@1164 515 code : unit -> Print.PD.pp_desc
adamc@855 516 }
adamc@855 517 val protocols = ref ([] : protocol list)
adamc@855 518 fun addProtocol p = protocols := p :: !protocols
adamc@855 519 fun getProtocol s = List.find (fn p => #name p = s) (!protocols)
adamc@855 520
ezyang@1739 521 fun clibFile s = OS.Path.joinDirFile {dir = libC (),
adamc@855 522 file = s}
adamc@855 523
adamc@865 524 val curProto = ref {name = "",
adamc@1096 525 compile = "",
adamc@1095 526 linkStatic = "",
adamc@1095 527 linkDynamic = "",
adamc@1164 528 persistent = false,
adamc@1164 529 code = fn () => Print.box []}
adamc@856 530 fun setProtocol name =
adamc@856 531 case getProtocol name of
adamc@856 532 NONE => raise Fail ("Unknown protocol " ^ name)
adamc@856 533 | SOME p => curProto := p
adamc@855 534 fun currentProtocol () = !curProto
adamc@855 535
adamc@857 536 val debug = ref false
adamc@857 537 fun setDebug b = debug := b
adamc@857 538 fun getDebug () = !debug
adamc@857 539
adamc@867 540 datatype sql_type =
adamc@867 541 Int
adamc@867 542 | Float
adamc@867 543 | String
adamc@1011 544 | Char
adamc@867 545 | Bool
adamc@867 546 | Time
adamc@867 547 | Blob
adamc@867 548 | Channel
adamc@867 549 | Client
adamc@867 550 | Nullable of sql_type
adamc@867 551
adamc@873 552 fun p_sql_ctype t =
adamc@867 553 let
adamc@867 554 open Print.PD
adamc@867 555 open Print
adamc@867 556 in
adamc@867 557 case t of
adamc@870 558 Int => "uw_Basis_int"
adamc@870 559 | Float => "uw_Basis_float"
adamc@870 560 | String => "uw_Basis_string"
adamc@1011 561 | Char => "uw_Basis_char"
adamc@870 562 | Bool => "uw_Basis_bool"
adamc@870 563 | Time => "uw_Basis_time"
adamc@870 564 | Blob => "uw_Basis_blob"
adamc@870 565 | Channel => "uw_Basis_channel"
adamc@870 566 | Client => "uw_Basis_client"
adamc@870 567 | Nullable String => "uw_Basis_string"
adamc@873 568 | Nullable t => p_sql_ctype t ^ "*"
adamc@867 569 end
adamc@867 570
adamc@867 571 fun isBlob Blob = true
adamc@867 572 | isBlob (Nullable t) = isBlob t
adamc@867 573 | isBlob _ = false
adamc@867 574
adamc@870 575 fun isNotNull (Nullable _) = false
adamc@870 576 | isNotNull _ = true
adamc@870 577
adam@1293 578 datatype failure_mode = Error | None
adam@1293 579
adamc@866 580 type dbms = {
adamc@866 581 name : string,
adam@1682 582 randomFunction : string,
adamc@866 583 header : string,
adamc@866 584 link : string,
adamc@873 585 p_sql_type : sql_type -> string,
adamc@870 586 init : {dbstring : string,
adamc@870 587 prepared : (string * int) list,
adamc@870 588 tables : (string * (string * sql_type) list) list,
adamc@872 589 views : (string * (string * sql_type) list) list,
adamc@870 590 sequences : string list} -> Print.PD.pp_desc,
adamc@873 591 query : {loc : ErrorMsg.span, cols : sql_type list,
adamc@880 592 doCols : ({loc : ErrorMsg.span, wontLeakStrings : bool, col : int, typ : sql_type} -> Print.PD.pp_desc)
adamc@867 593 -> Print.PD.pp_desc}
adamc@867 594 -> Print.PD.pp_desc,
adamc@867 595 queryPrepared : {loc : ErrorMsg.span, id : int, query : string,
adamc@873 596 inputs : sql_type list, cols : sql_type list,
adamc@880 597 doCols : ({loc : ErrorMsg.span, wontLeakStrings : bool, col : int,
adamc@880 598 typ : sql_type} -> Print.PD.pp_desc)
adamc@879 599 -> Print.PD.pp_desc,
adamc@879 600 nested : bool}
adamc@868 601 -> Print.PD.pp_desc,
adam@1293 602 dml : ErrorMsg.span * failure_mode -> Print.PD.pp_desc,
adamc@868 603 dmlPrepared : {loc : ErrorMsg.span, id : int, dml : string,
adam@1293 604 inputs : sql_type list, mode : failure_mode} -> Print.PD.pp_desc,
adamc@878 605 nextval : {loc : ErrorMsg.span, seqName : string option, seqE : Print.PD.pp_desc} -> Print.PD.pp_desc,
adamc@874 606 nextvalPrepared : {loc : ErrorMsg.span, id : int, query : string} -> Print.PD.pp_desc,
adamc@1073 607 setval : {loc : ErrorMsg.span, seqE : Print.PD.pp_desc, count : Print.PD.pp_desc} -> Print.PD.pp_desc,
adamc@874 608 sqlifyString : string -> string,
adamc@874 609 p_cast : string * sql_type -> string,
adamc@874 610 p_blank : int * sql_type -> string,
adamc@877 611 supportsDeleteAs : bool,
adamc@886 612 supportsUpdateAs : bool,
adamc@877 613 createSequence : string -> string,
adamc@878 614 textKeysNeedLengths : bool,
adamc@879 615 supportsNextval : bool,
adamc@882 616 supportsNestedPrepared : bool,
adamc@890 617 sqlPrefix : string,
adamc@1014 618 supportsOctetLength : bool,
adamc@1014 619 trueString : string,
adamc@1196 620 falseString : string,
adamc@1196 621 onlyUnion : bool,
adam@1777 622 nestedRelops : bool,
adam@1778 623 windowFunctions: bool
adamc@866 624 }
adamc@866 625
adamc@866 626 val dbmses = ref ([] : dbms list)
adamc@866 627 val curDb = ref ({name = "",
adam@1682 628 randomFunction = "",
adamc@866 629 header = "",
adamc@866 630 link = "",
adamc@873 631 p_sql_type = fn _ => "",
adamc@867 632 init = fn _ => Print.box [],
adamc@867 633 query = fn _ => Print.box [],
adamc@868 634 queryPrepared = fn _ => Print.box [],
adamc@868 635 dml = fn _ => Print.box [],
adamc@869 636 dmlPrepared = fn _ => Print.box [],
adamc@869 637 nextval = fn _ => Print.box [],
adamc@874 638 nextvalPrepared = fn _ => Print.box [],
adamc@1073 639 setval = fn _ => Print.box [],
adamc@874 640 sqlifyString = fn s => s,
adamc@874 641 p_cast = fn _ => "",
adamc@874 642 p_blank = fn _ => "",
adamc@877 643 supportsDeleteAs = false,
adamc@886 644 supportsUpdateAs = false,
adamc@877 645 createSequence = fn _ => "",
adamc@878 646 textKeysNeedLengths = false,
adamc@879 647 supportsNextval = false,
adamc@882 648 supportsNestedPrepared = false,
adamc@890 649 sqlPrefix = "",
adamc@1014 650 supportsOctetLength = false,
adamc@1014 651 trueString = "",
adamc@1196 652 falseString = "",
adamc@1196 653 onlyUnion = false,
adam@1777 654 nestedRelops = false,
adam@1777 655 windowFunctions = false} : dbms)
adamc@866 656
adamc@866 657 fun addDbms v = dbmses := v :: !dbmses
adamc@866 658 fun setDbms s =
adamc@866 659 case List.find (fn db => #name db = s) (!dbmses) of
adamc@866 660 NONE => raise Fail ("Unknown DBMS " ^ s)
adamc@866 661 | SOME db => curDb := db
adamc@866 662 fun currentDbms () = !curDb
adamc@866 663
adamc@891 664 val dbstring = ref (NONE : string option)
adamc@891 665 fun setDbstring so = dbstring := so
adamc@891 666 fun getDbstring () = !dbstring
adamc@891 667
adamc@891 668 val exe = ref (NONE : string option)
adamc@891 669 fun setExe so = exe := so
adamc@891 670 fun getExe () = !exe
adamc@891 671
adamc@891 672 val sql = ref (NONE : string option)
adamc@891 673 fun setSql so = sql := so
adamc@891 674 fun getSql () = !sql
adamc@891 675
adam@1820 676 val coreInline = ref 5
adamc@1016 677 fun setCoreInline n = coreInline := n
adamc@1016 678 fun getCoreInline () = !coreInline
adamc@1016 679
adam@1820 680 val monoInline = ref 5
adamc@1016 681 fun setMonoInline n = monoInline := n
adamc@1016 682 fun getMonoInline () = !monoInline
adamc@1016 683
adamc@1095 684 val staticLinking = ref false
adamc@1095 685 fun setStaticLinking b = staticLinking := b
adamc@1095 686 fun getStaticLinking () = !staticLinking
adamc@1095 687
adamc@1114 688 val deadlines = ref false
adamc@1114 689 fun setDeadlines b = deadlines := b
adamc@1114 690 fun getDeadlines () = !deadlines
adamc@1114 691
adamc@1164 692 val sigFile = ref (NONE : string option)
adamc@1164 693 fun setSigFile v = sigFile := v
adamc@1164 694 fun getSigFile () = !sigFile
adamc@1164 695
adamc@1183 696 structure SS = BinarySetFn(struct
adamc@1183 697 type ord_key = string
adamc@1183 698 val compare = String.compare
adamc@1183 699 end)
adamc@1183 700
adamc@1183 701 val safeGet = ref SS.empty
adamc@1183 702 fun setSafeGets ls = safeGet := SS.addList (SS.empty, ls)
adamc@1183 703 fun isSafeGet x = SS.member (!safeGet, x)
adamc@1183 704
adam@1294 705 val onError = ref (NONE : (string * string list * string) option)
adam@1294 706 fun setOnError x = onError := x
adam@1294 707 fun getOnError () = !onError
adam@1294 708
adam@1307 709 val limits = ["messages", "clients", "headers", "page", "heap", "script",
adam@1307 710 "inputs", "subinputs", "cleanup", "deltas", "transactionals",
adam@1308 711 "globals", "database", "time"]
adam@1307 712
adam@1307 713 val limitsList = ref ([] : (string * int) list)
adam@1307 714 fun addLimit (v as (name, _)) =
adam@1307 715 if List.exists (fn name' => name' = name) limits then
adam@1308 716 (limitsList := v :: !limitsList;
adam@1308 717 if name = "time" then
adam@1308 718 setDeadlines true
adam@1308 719 else
adam@1308 720 ())
adam@1307 721 else
adam@1307 722 raise Fail ("Unknown limit category '" ^ name ^ "'")
adam@1307 723 fun limits () = !limitsList
adam@1307 724
adam@1332 725 val minHeap = ref 0
adam@1332 726 fun setMinHeap n = if n >= 0 then minHeap := n else raise Fail "Trying to set negative minHeap"
adam@1332 727 fun getMinHeap () = !minHeap
adam@1332 728
adam@1393 729 structure SS = BinarySetFn(struct
adam@1393 730 type ord_key = string
adam@1393 731 val compare = String.compare
adam@1393 732 end)
adam@1393 733
adam@1393 734 val alwaysInline = ref SS.empty
adam@1393 735 fun addAlwaysInline s = alwaysInline := SS.add (!alwaysInline, s)
adam@1393 736 fun checkAlwaysInline s = SS.member (!alwaysInline, s)
adam@1393 737
adam@1966 738 val neverInline = ref SS.empty
adam@1966 739 fun addNeverInline s = neverInline := SS.add (!neverInline, s)
adam@1966 740 fun checkNeverInline s = SS.member (!neverInline, s)
adam@1966 741
adam@1478 742 val noXsrfProtection = ref SS.empty
adam@1478 743 fun addNoXsrfProtection s = noXsrfProtection := SS.add (!noXsrfProtection, s)
adam@1478 744 fun checkNoXsrfProtection s = SS.member (!noXsrfProtection, s)
adam@1478 745
adam@1629 746 val timeFormat = ref "%c"
adam@1629 747 fun setTimeFormat v = timeFormat := v
adam@1629 748 fun getTimeFormat () = !timeFormat
adam@1629 749
adam@1953 750 fun lowercase s =
adam@1953 751 case s of
adam@1953 752 "" => ""
adam@1953 753 | _ => str (Char.toLower (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
adam@1953 754
adam@1953 755 fun capitalize s =
adam@1953 756 case s of
adam@1953 757 "" => ""
adam@1953 758 | _ => str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
adam@1953 759
adam@2108 760 val allLower = CharVector.map Char.toLower
adam@2108 761
adam@1953 762 val mangle = ref true
adam@1953 763 fun setMangleSql x = mangle := x
adam@2108 764
adam@2108 765 fun mangleSqlTable s =
adam@2108 766 if #name (currentDbms ()) = "mysql" then
adam@2108 767 if !mangle then
adam@2108 768 "uw_" ^ allLower s
adam@2108 769 else
adam@2108 770 allLower s
adam@2108 771 else
adam@2108 772 if !mangle then
adam@2108 773 "uw_" ^ capitalize s
adam@2108 774 else
adam@2108 775 lowercase s
adam@2108 776
adam@2108 777 fun mangleSql s =
adam@2108 778 if #name (currentDbms ()) = "mysql" then
adam@2108 779 if !mangle then
ziv@2130 780 "uw_" ^ allLower s
adam@2108 781 else
adam@2108 782 allLower s
adam@2108 783 else
adam@2108 784 if !mangle then
adam@2108 785 "uw_" ^ s
adam@2108 786 else
adam@2108 787 lowercase s
adam@2108 788
adam@2108 789 fun mangleSqlCatalog s =
adam@2108 790 if #name (currentDbms ()) = "mysql" then
adam@2108 791 if !mangle then
adam@2108 792 "uw_" ^ allLower s
adam@2108 793 else
adam@2108 794 allLower s
adam@2108 795 else
adam@2108 796 if !mangle then
adam@2108 797 "uw_" ^ s
adam@2108 798 else
adam@2108 799 lowercase s
adam@1953 800
adam@1956 801 val html5 = ref false
adam@1956 802 fun setIsHtml5 b = html5 := b
adam@1956 803 fun getIsHtml5 () = !html5
adam@1956 804
adam@2010 805 val less = ref false
adam@2010 806 fun setLessSafeFfi b = less := b
adam@2010 807 fun getLessSafeFfi () = !less
adam@2010 808
adam@2046 809 structure SM = BinaryMapFn(struct
adam@2046 810 type ord_key = string
adam@2046 811 val compare = String.compare
adam@2046 812 end)
adam@2046 813
adam@2046 814 val noMimeFile = ref false
adam@2046 815
adam@2046 816 fun noMime () =
adam@2046 817 (TextIO.output (TextIO.stdErr, "WARNING: Error opening /etc/mime.types. Static files will be served with no suggested MIME types.\n");
adam@2046 818 noMimeFile := true;
adam@2046 819 SM.empty)
adam@2046 820
adam@2046 821 fun readMimeTypes () =
adam@2046 822 let
adam@2046 823 val inf = TextIO.openIn "/etc/mime.types"
adam@2046 824
adam@2046 825 fun loop m =
adam@2046 826 case TextIO.inputLine inf of
adam@2046 827 NONE => m
adam@2046 828 | SOME line =>
adam@2046 829 if size line > 0 andalso String.sub (line, 0) = #"#" then
adam@2046 830 loop m
adam@2046 831 else
adam@2046 832 case String.tokens Char.isSpace line of
adam@2046 833 typ :: exts =>
adam@2046 834 loop (foldl (fn (ext, m) => SM.insert (m, ext, typ)) m exts)
adam@2046 835 | _ => loop m
adam@2046 836 in
adam@2046 837 loop SM.empty
adam@2046 838 before TextIO.closeIn inf
adam@2046 839 end handle IO.Io _ => noMime ()
adam@2046 840 | OS.SysErr _ => noMime ()
adam@2046 841
adam@2046 842 val mimeTypes = ref (NONE : string SM.map option)
adam@2046 843
adam@2046 844 fun getMimeTypes () =
adam@2046 845 case !mimeTypes of
adam@2046 846 SOME m => m
adam@2046 847 | NONE =>
adam@2046 848 let
adam@2046 849 val m = readMimeTypes ()
adam@2046 850 in
adam@2046 851 mimeTypes := SOME m;
adam@2046 852 m
adam@2046 853 end
adam@2046 854
adam@2046 855 fun mimeTypeOf filename =
adam@2046 856 case OS.Path.ext filename of
adam@2046 857 NONE => (if !noMimeFile then
adam@2046 858 ()
adam@2046 859 else
adam@2046 860 TextIO.output (TextIO.stdErr, "WARNING: No extension found in filename '" ^ filename ^ "'. Header 'Content-Type' will be omitted in HTTP responses.\n");
adam@2046 861 NONE)
adam@2046 862 | SOME ext =>
adam@2046 863 let
adam@2046 864 val to = SM.find (getMimeTypes (), ext)
adam@2046 865 in
adam@2046 866 case to of
adam@2046 867 NONE => if !noMimeFile then
adam@2046 868 ()
adam@2046 869 else
adam@2046 870 TextIO.output (TextIO.stdErr, "WARNING: No MIME type known for extension '" ^ ext ^ "'. Header 'Content-Type' will be omitted in HTTP responses.\n")
adam@2046 871 | _ => ();
adam@2046 872 to
adam@2046 873 end
adam@2046 874
adam@2046 875 val files = ref (SM.empty : (string * {Uri : string, ContentType : string option, LastModified : Time.time, Bytes : Word8Vector.vector}) SM.map)
adam@2046 876
adam@2046 877 val filePath = ref "."
adam@2046 878
adam@2046 879 fun setFilePath path = filePath := path
adam@2046 880
adam@2046 881 fun addFile {Uri, LoadFromFilename} =
adam@2046 882 let
julian@2135 883 val path = OS.Path.concat (!filePath, LoadFromFilename)
adam@2046 884 in
adam@2046 885 case SM.find (!files, Uri) of
adam@2046 886 SOME (path', _) =>
adam@2183 887 if OS.Path.mkCanonical path' = OS.Path.mkCanonical path then
adam@2046 888 ()
adam@2046 889 else
adam@2172 890 ErrorMsg.error ("Two different files requested for URI " ^ Uri ^ " ( " ^ path' ^ " vs. " ^ path ^ ")")
adam@2046 891 | NONE =>
adam@2046 892 let
adam@2046 893 val inf = BinIO.openIn path
adam@2046 894 in
adam@2046 895 files := SM.insert (!files,
adam@2046 896 Uri,
adam@2046 897 (path,
adam@2046 898 {Uri = Uri,
adam@2046 899 ContentType = mimeTypeOf path,
adam@2046 900 LastModified = OS.FileSys.modTime path,
adam@2046 901 Bytes = BinIO.inputAll inf}));
adam@2046 902 BinIO.closeIn inf
adam@2046 903 end
adam@2046 904 end handle IO.Io _ =>
adam@2046 905 ErrorMsg.error ("Error loading file " ^ LoadFromFilename)
adam@2046 906 | OS.SysErr (s, _) =>
adam@2046 907 ErrorMsg.error ("Error loading file " ^ LoadFromFilename ^ " (" ^ s ^ ")")
adam@2046 908
adam@2046 909 fun listFiles () = map #2 (SM.listItems (!files))
adam@2046 910
adamc@765 911 end