Mercurial > urweb

annotate src/settings.sml @ 2116:ebfaab689570

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