Mercurial > urweb

annotate src/settings.sml @ 2276:c05f9a5e0f0f

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