Mercurial > urweb

annotate src/settings.sml @ 1739:c414850f206f

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Add support for -boot flag, which allows in-tree execution of Ur/Web The boot flag rewrites most hardcoded paths to point to the build directory, and also forces static compilation. This is convenient for developing Ur/Web, or if you cannot 'sudo make install' Ur/Web. The following changes were made: * Header files were moved to include/urweb instead of include; this lets FFI users point their C_INCLUDE_PATH at this directory at write <urweb/urweb.h>. For internal Ur/Web executables, we simply pass -I$PATH/include/urweb as normal. * Differentiate between LIB and SRCLIB; SRCLIB is Ur and JavaScript source files, while LIB is compiled products from libtool. For in-tree compilation these live in different places. * No longer reference Config for paths; instead use Settings; these settings can be changed dynamically by Compiler.enableBoot () (TODO: add a disableBoot function.) * config.h is now generated directly in include/urweb/config.h, for consistency's sake (especially since it gets installed along with the rest of the headers!) * All of the autotools build products got updated. * The linkStatic field in protocols now only contains the name of the build product, and not the absolute path. Future users have to be careful not to reference the Settings files to early, lest they get an old version (this was the source of two bugs during development of this patch.)
author Edward Z. Yang <ezyang@mit.edu>
date Wed, 02 May 2012 17:17:57 -0400
parents 225b87d4a7df
children 675ce534e3ec
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
ezyang@1739 36 fun libUr () = OS.Path.joinDirFile {dir = !configSrcLib,
ezyang@1739 37 file = "ur"}
ezyang@1739 38 fun libC () = OS.Path.joinDirFile {dir = !configSrcLib,
ezyang@1739 39 file = "c"}
ezyang@1739 40 fun libJs () = OS.Path.joinDirFile {dir = !configSrcLib,
ezyang@1739 41 file = "js"}
ezyang@1739 42
ezyang@1739 43 fun libFile s = OS.Path.joinDirFile {dir = libUr (),
ezyang@1739 44 file = s}
ezyang@1739 45
adam@1637 46 val urlPrefixFull = ref "/"
adamc@764 47 val urlPrefix = ref "/"
adam@1370 48 val urlPrePrefix = ref ""
adamc@764 49 val timeout = ref 0
adamc@764 50 val headers = ref ([] : string list)
adamc@766 51 val scripts = ref ([] : string list)
adamc@764 52
adam@1637 53 fun getUrlPrefixFull () = !urlPrefixFull
adamc@764 54 fun getUrlPrefix () = !urlPrefix
adam@1370 55 fun getUrlPrePrefix () = !urlPrePrefix
adamc@764 56 fun setUrlPrefix p =
adam@1370 57 let
adam@1370 58 val prefix = if p = "" then
adam@1370 59 "/"
adam@1370 60 else if String.sub (p, size p - 1) <> #"/" then
adam@1370 61 p ^ "/"
adam@1370 62 else
adam@1370 63 p
adam@1370 64
adam@1470 65 fun findPrefix n =
adam@1470 66 let
adam@1470 67 val (befor, after) = Substring.splitl (fn ch => ch <> #"/") (Substring.extract (prefix, n, NONE))
adam@1470 68 in
adam@1470 69 if Substring.isEmpty after then
adam@1470 70 ("", prefix)
adam@1470 71 else
adam@1470 72 (String.substring (prefix, 0, n) ^ Substring.string befor, Substring.string after)
rmbruijn@1597 73 end
adam@1470 74
adam@1370 75 val (prepre, prefix) =
adam@1370 76 if String.isPrefix "http://" prefix then
adam@1470 77 findPrefix 7
adam@1470 78 else if String.isPrefix "https://" prefix then
adam@1470 79 findPrefix 8
adam@1370 80 else
adam@1370 81 ("", prefix)
adam@1370 82 in
adam@1637 83 urlPrefixFull := p;
adam@1370 84 urlPrePrefix := prepre;
adam@1370 85 urlPrefix := prefix
adam@1370 86 end
adamc@764 87
adamc@764 88 fun getTimeout () = !timeout
adamc@764 89 fun setTimeout n = timeout := n
adamc@764 90
adamc@764 91 fun getHeaders () = !headers
adamc@764 92 fun setHeaders ls = headers := ls
adamc@764 93
adamc@766 94 fun getScripts () = !scripts
adamc@766 95 fun setScripts ls = scripts := ls
adamc@766 96
adamc@765 97 type ffi = string * string
adamc@765 98
adamc@765 99 structure K = struct
adamc@765 100 type ord_key = ffi
adamc@765 101 fun compare ((m1, x1), (m2, x2)) =
adamc@765 102 Order.join (String.compare (m1, m2),
adamc@765 103 fn () => String.compare (x1, x2))
adamc@764 104 end
adamc@765 105
adamc@765 106 structure S = BinarySetFn(K)
adamc@765 107 structure M = BinaryMapFn(K)
adamc@765 108
adamc@765 109 fun basis x = S.addList (S.empty, map (fn x : string => ("Basis", x)) x)
adamc@765 110
adamc@765 111 val clientToServerBase = basis ["int",
adamc@765 112 "float",
adamc@765 113 "string",
adamc@765 114 "time",
adamc@765 115 "file",
adamc@765 116 "unit",
adamc@765 117 "option",
adamc@765 118 "list",
adam@1288 119 "bool",
adam@1288 120 "variant"]
adamc@765 121 val clientToServer = ref clientToServerBase
adamc@765 122 fun setClientToServer ls = clientToServer := S.addList (clientToServerBase, ls)
adamc@765 123 fun mayClientToServer x = S.member (!clientToServer, x)
adamc@765 124
adamc@779 125 val effectfulBase = basis ["dml",
adamc@779 126 "nextval",
adamc@1073 127 "setval",
adamc@779 128 "set_cookie",
adamc@1050 129 "clear_cookie",
adamc@765 130 "new_channel",
adamc@1200 131 "send",
adamc@1200 132 "htmlifyInt_w",
adamc@1200 133 "htmlifyFloat_w",
adamc@1200 134 "htmlifyString_w",
adamc@1200 135 "htmlifyBool_w",
adamc@1200 136 "htmlifyTime_w",
adamc@1200 137 "attrifyInt_w",
adamc@1200 138 "attrifyFloat_w",
adamc@1200 139 "attrifyString_w",
adamc@1200 140 "attrifyChar_w",
adamc@1200 141 "urlifyInt_w",
adamc@1200 142 "urlifyFloat_w",
adamc@1200 143 "urlifyString_w",
adamc@1200 144 "urlifyBool_w",
adamc@1200 145 "urlifyChannel_w"]
adamc@765 146
adamc@765 147 val effectful = ref effectfulBase
adamc@765 148 fun setEffectful ls = effectful := S.addList (effectfulBase, ls)
adamc@765 149 fun isEffectful x = S.member (!effectful, x)
adamc@765 150
adamc@1171 151 val benignBase = basis ["get_cookie",
adamc@1171 152 "new_client_source",
adamc@1171 153 "get_client_source",
adamc@1171 154 "set_client_source",
adamc@1171 155 "current",
adamc@1171 156 "alert",
adam@1290 157 "confirm",
adamc@1171 158 "onError",
adamc@1171 159 "onFail",
adamc@1171 160 "onConnectFail",
adamc@1171 161 "onDisconnect",
adamc@1171 162 "onServerError",
adamc@1171 163 "kc",
adamc@1250 164 "debug",
adam@1422 165 "rand",
adam@1465 166 "now",
adam@1465 167 "getHeader",
adam@1555 168 "setHeader",
adam@1555 169 "spawn",
adam@1555 170 "onClick",
adam@1555 171 "onDblclick",
adam@1555 172 "onKeydown",
adam@1555 173 "onKeypress",
adam@1555 174 "onKeyup",
adam@1555 175 "onMousedown",
adam@1556 176 "onMouseup",
adam@1559 177 "preventDefault",
adam@1559 178 "stopPropagation",
adam@1556 179 "fresh"]
adamc@1171 180
adamc@1171 181 val benign = ref benignBase
adamc@1171 182 fun setBenignEffectful ls = benign := S.addList (benignBase, ls)
adamc@1171 183 fun isBenignEffectful x = S.member (!benign, x)
adamc@1171 184
adam@1595 185 val clientBase = basis ["get_client_source",
adamc@841 186 "current",
adamc@765 187 "alert",
adam@1290 188 "confirm",
adamc@765 189 "recv",
adamc@765 190 "sleep",
adamc@765 191 "spawn",
adamc@765 192 "onError",
adamc@765 193 "onFail",
adamc@765 194 "onConnectFail",
adamc@765 195 "onDisconnect",
adamc@895 196 "onServerError",
adam@1555 197 "kc",
adam@1555 198 "onClick",
adam@1555 199 "onDblclick",
adam@1555 200 "onKeydown",
adam@1555 201 "onKeypress",
adam@1555 202 "onKeyup",
adam@1555 203 "onMousedown",
adam@1559 204 "onMouseup",
adam@1559 205 "preventDefault",
adam@1559 206 "stopPropagation"]
adamc@765 207 val client = ref clientBase
adamc@765 208 fun setClientOnly ls = client := S.addList (clientBase, ls)
adamc@765 209 fun isClientOnly x = S.member (!client, x)
adamc@765 210
adamc@765 211 val serverBase = basis ["requestHeader",
adamc@765 212 "query",
adamc@765 213 "dml",
adamc@765 214 "nextval",
adamc@1073 215 "setval",
adamc@765 216 "channel",
adamc@765 217 "send"]
adamc@765 218 val server = ref serverBase
adamc@765 219 fun setServerOnly ls = server := S.addList (serverBase, ls)
adamc@765 220 fun isServerOnly x = S.member (!server, x)
adamc@765 221
adamc@765 222 val basisM = foldl (fn ((k, v : string), m) => M.insert (m, ("Basis", k), v)) M.empty
adamc@765 223
adamc@765 224 val jsFuncsBase = basisM [("alert", "alert"),
adam@1599 225 ("stringToTime", "stringToTime"),
adam@1599 226 ("stringToTime_error", "stringToTime_error"),
adam@1609 227 ("timef", "strftime"),
adam@1290 228 ("confirm", "confrm"),
adamc@765 229 ("get_client_source", "sg"),
adamc@841 230 ("current", "scur"),
adamc@765 231 ("htmlifyBool", "bs"),
adamc@765 232 ("htmlifyFloat", "ts"),
adamc@765 233 ("htmlifyInt", "ts"),
adamc@765 234 ("htmlifyString", "eh"),
adamc@765 235 ("new_client_source", "sc"),
adamc@765 236 ("set_client_source", "sv"),
adamc@838 237 ("stringToFloat", "pflo"),
adamc@838 238 ("stringToInt", "pio"),
adamc@765 239 ("stringToFloat_error", "pfl"),
adamc@765 240 ("stringToInt_error", "pi"),
adamc@765 241 ("urlifyInt", "ts"),
adamc@765 242 ("urlifyFloat", "ts"),
adam@1360 243 ("urlifyTime", "ts"),
adamc@765 244 ("urlifyString", "uf"),
adamc@912 245 ("urlifyBool", "ub"),
adamc@765 246 ("recv", "rv"),
adamc@765 247 ("strcat", "cat"),
adamc@765 248 ("intToString", "ts"),
adamc@765 249 ("floatToString", "ts"),
adamc@821 250 ("charToString", "ts"),
adamc@765 251 ("onError", "onError"),
adamc@765 252 ("onFail", "onFail"),
adamc@765 253 ("onConnectFail", "onConnectFail"),
adamc@765 254 ("onDisconnect", "onDisconnect"),
adamc@798 255 ("onServerError", "onServerError"),
adamc@1108 256 ("attrifyString", "atr"),
adamc@798 257 ("attrifyInt", "ts"),
adamc@798 258 ("attrifyFloat", "ts"),
adamc@820 259 ("attrifyBool", "bs"),
adamc@821 260 ("boolToString", "ts"),
adamc@1057 261 ("str1", "id"),
adamc@821 262 ("strsub", "sub"),
adamc@828 263 ("strsuffix", "suf"),
adamc@829 264 ("strlen", "slen"),
adamc@829 265 ("strindex", "sidx"),
adamc@829 266 ("strchr", "schr"),
adamc@831 267 ("substring", "ssub"),
adamc@895 268 ("strcspn", "sspn"),
adam@1624 269 ("strlenGe", "strlenGe"),
adamc@1061 270 ("kc", "kc"),
adam@1404 271 ("minTime", "0"),
adamc@1061 272
adamc@1061 273 ("islower", "isLower"),
adamc@1061 274 ("isupper", "isUpper"),
adamc@1061 275 ("isalpha", "isAlpha"),
adamc@1061 276 ("isdigit", "isDigit"),
adamc@1061 277 ("isalnum", "isAlnum"),
adamc@1061 278 ("isblank", "isBlank"),
adamc@1061 279 ("isspace", "isSpace"),
adamc@1061 280 ("isxdigit", "isXdigit"),
adamc@1061 281 ("tolower", "toLower"),
adamc@1323 282 ("toupper", "toUpper"),
adamc@1323 283
adamc@1323 284 ("checkUrl", "checkUrl"),
adam@1366 285 ("bless", "bless"),
adam@1366 286
adam@1366 287 ("eq_time", "eq"),
adam@1366 288 ("lt_time", "lt"),
adam@1430 289 ("le_time", "le"),
adam@1430 290
adam@1625 291 ("debug", "uw_debug"),
adam@1625 292 ("naughtyDebug", "uw_debug"),
adam@1487 293
adam@1571 294 ("floatFromInt", "float"),
adam@1571 295 ("ceil", "ceil"),
adam@1571 296 ("trunc", "trunc"),
adam@1571 297 ("round", "round"),
adam@1571 298
adam@1487 299 ("now", "now"),
adam@1487 300 ("timeToString", "showTime"),
adam@1629 301 ("htmlifyTime", "showTimeHtml"),
adam@1514 302 ("toSeconds", "toSeconds"),
adam@1518 303 ("addSeconds", "addSeconds"),
adam@1555 304 ("diffInSeconds", "diffInSeconds"),
adam@1685 305 ("toMilliseconds", "toMilliseconds"),
adam@1685 306 ("diffInMilliseconds", "diffInMilliseconds"),
adam@1555 307
adam@1555 308 ("onClick", "uw_onClick"),
adam@1555 309 ("onDblclick", "uw_onDblclick"),
adam@1555 310 ("onKeydown", "uw_onKeydown"),
adam@1555 311 ("onKeypress", "uw_onKeypress"),
adam@1555 312 ("onKeyup", "uw_onKeyup"),
adam@1555 313 ("onMousedown", "uw_onMousedown"),
adam@1556 314 ("onMouseup", "uw_onMouseup"),
adam@1559 315 ("preventDefault", "uw_preventDefault"),
adam@1559 316 ("stopPropagation", "uw_stopPropagation"),
adam@1556 317
adam@1556 318 ("fresh", "fresh")]
adamc@765 319 val jsFuncs = ref jsFuncsBase
adamc@765 320 fun setJsFuncs ls = jsFuncs := foldl (fn ((k, v), m) => M.insert (m, k, v)) jsFuncsBase ls
adamc@765 321 fun jsFunc x = M.find (!jsFuncs, x)
adam@1433 322 fun allJsFuncs () = M.listItemsi (!jsFuncs)
adamc@765 323
adamc@768 324 datatype pattern_kind = Exact | Prefix
adamc@768 325 datatype action = Allow | Deny
adamc@768 326 type rule = { action : action, kind : pattern_kind, pattern : string }
adamc@768 327
adamc@768 328 datatype path_kind = Any | Url | Table | Sequence | View | Relation | Cookie | Style
adamc@768 329 type rewrite = { pkind : path_kind, kind : pattern_kind, from : string, to : string }
adamc@768 330
adamc@768 331 val rewrites = ref ([] : rewrite list)
adamc@768 332
adamc@768 333 fun subsume (pk1, pk2) =
adamc@768 334 pk1 = pk2
adamc@768 335 orelse pk2 = Any
adamc@768 336 orelse pk2 = Relation andalso (pk1 = Table orelse pk1 = Sequence orelse pk1 = View)
adamc@768 337
adamc@768 338 fun setRewriteRules ls = rewrites := ls
adamc@768 339 fun rewrite pk s =
adamc@768 340 let
adamc@768 341 fun rew (ls : rewrite list) =
adamc@768 342 case ls of
adamc@768 343 [] => s
adamc@768 344 | rewr :: ls =>
adamc@768 345 let
adamc@768 346 fun match () =
adamc@768 347 case #kind rewr of
adamc@768 348 Exact => if #from rewr = s then
adamc@768 349 SOME (size s)
adamc@768 350 else
adamc@768 351 NONE
adamc@768 352 | Prefix => if String.isPrefix (#from rewr) s then
adamc@768 353 SOME (size (#from rewr))
adamc@768 354 else
adamc@768 355 NONE
adamc@768 356 in
adamc@768 357 if subsume (pk, #pkind rewr) then
adamc@768 358 case match () of
adamc@768 359 NONE => rew ls
adamc@768 360 | SOME suffixStart => #to rewr ^ String.extract (s, suffixStart, NONE)
adamc@768 361 else
adamc@768 362 rew ls
adamc@768 363 end
adamc@768 364 in
adamc@768 365 rew (!rewrites)
adamc@768 366 end
adamc@768 367
adamc@769 368 val url = ref ([] : rule list)
adamc@769 369 val mime = ref ([] : rule list)
adam@1465 370 val request = ref ([] : rule list)
adam@1465 371 val response = ref ([] : rule list)
adamc@769 372
adamc@769 373 fun setUrlRules ls = url := ls
adamc@769 374 fun setMimeRules ls = mime := ls
adam@1465 375 fun setRequestHeaderRules ls = request := ls
adam@1465 376 fun setResponseHeaderRules ls = response := ls
adamc@769 377
adamc@770 378 fun getUrlRules () = !url
adamc@770 379 fun getMimeRules () = !mime
adam@1465 380 fun getRequestHeaderRules () = !request
adam@1465 381 fun getResponseHeaderRules () = !response
adamc@770 382
adamc@769 383 fun check f rules s =
adamc@769 384 let
adamc@769 385 fun chk (ls : rule list) =
adamc@769 386 case ls of
adamc@769 387 [] => false
adamc@769 388 | rule :: ls =>
adamc@769 389 let
adamc@769 390 val matches =
adamc@769 391 case #kind rule of
adamc@769 392 Exact => #pattern rule = s
adamc@769 393 | Prefix => String.isPrefix (#pattern rule) s
adamc@769 394 in
adamc@769 395 if matches then
adamc@769 396 case #action rule of
adamc@769 397 Allow => true
adamc@769 398 | Deny => false
adamc@769 399 else
adamc@769 400 chk ls
adamc@769 401 end
adamc@769 402 in
adamc@769 403 f s andalso chk (!rules)
adamc@769 404 end
adamc@769 405
adamc@769 406 val checkUrl = check (fn _ => true) url
adam@1465 407
adam@1465 408 val validMime = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"/" orelse ch = #"-" orelse ch = #".")
adam@1465 409
adam@1465 410 val checkMime = check validMime mime
adam@1465 411 val checkRequestHeader = check validMime request
adam@1465 412 val checkResponseHeader = check validMime response
adamc@769 413
adamc@855 414
adamc@855 415 type protocol = {
adamc@855 416 name : string,
adamc@1096 417 compile : string,
adamc@1095 418 linkStatic : string,
adamc@1095 419 linkDynamic : string,
adamc@1164 420 persistent : bool,
adamc@1164 421 code : unit -> Print.PD.pp_desc
adamc@855 422 }
adamc@855 423 val protocols = ref ([] : protocol list)
adamc@855 424 fun addProtocol p = protocols := p :: !protocols
adamc@855 425 fun getProtocol s = List.find (fn p => #name p = s) (!protocols)
adamc@855 426
ezyang@1739 427 fun clibFile s = OS.Path.joinDirFile {dir = libC (),
adamc@855 428 file = s}
adamc@855 429
adamc@865 430 val curProto = ref {name = "",
adamc@1096 431 compile = "",
adamc@1095 432 linkStatic = "",
adamc@1095 433 linkDynamic = "",
adamc@1164 434 persistent = false,
adamc@1164 435 code = fn () => Print.box []}
adamc@856 436 fun setProtocol name =
adamc@856 437 case getProtocol name of
adamc@856 438 NONE => raise Fail ("Unknown protocol " ^ name)
adamc@856 439 | SOME p => curProto := p
adamc@855 440 fun currentProtocol () = !curProto
adamc@855 441
adamc@857 442 val debug = ref false
adamc@857 443 fun setDebug b = debug := b
adamc@857 444 fun getDebug () = !debug
adamc@857 445
adamc@867 446 datatype sql_type =
adamc@867 447 Int
adamc@867 448 | Float
adamc@867 449 | String
adamc@1011 450 | Char
adamc@867 451 | Bool
adamc@867 452 | Time
adamc@867 453 | Blob
adamc@867 454 | Channel
adamc@867 455 | Client
adamc@867 456 | Nullable of sql_type
adamc@867 457
adamc@873 458 fun p_sql_ctype t =
adamc@867 459 let
adamc@867 460 open Print.PD
adamc@867 461 open Print
adamc@867 462 in
adamc@867 463 case t of
adamc@870 464 Int => "uw_Basis_int"
adamc@870 465 | Float => "uw_Basis_float"
adamc@870 466 | String => "uw_Basis_string"
adamc@1011 467 | Char => "uw_Basis_char"
adamc@870 468 | Bool => "uw_Basis_bool"
adamc@870 469 | Time => "uw_Basis_time"
adamc@870 470 | Blob => "uw_Basis_blob"
adamc@870 471 | Channel => "uw_Basis_channel"
adamc@870 472 | Client => "uw_Basis_client"
adamc@870 473 | Nullable String => "uw_Basis_string"
adamc@873 474 | Nullable t => p_sql_ctype t ^ "*"
adamc@867 475 end
adamc@867 476
adamc@867 477 fun isBlob Blob = true
adamc@867 478 | isBlob (Nullable t) = isBlob t
adamc@867 479 | isBlob _ = false
adamc@867 480
adamc@870 481 fun isNotNull (Nullable _) = false
adamc@870 482 | isNotNull _ = true
adamc@870 483
adam@1293 484 datatype failure_mode = Error | None
adam@1293 485
adamc@866 486 type dbms = {
adamc@866 487 name : string,
adam@1682 488 randomFunction : string,
adamc@866 489 header : string,
adamc@866 490 link : string,
adamc@873 491 p_sql_type : sql_type -> string,
adamc@870 492 init : {dbstring : string,
adamc@870 493 prepared : (string * int) list,
adamc@870 494 tables : (string * (string * sql_type) list) list,
adamc@872 495 views : (string * (string * sql_type) list) list,
adamc@870 496 sequences : string list} -> Print.PD.pp_desc,
adamc@873 497 query : {loc : ErrorMsg.span, cols : sql_type list,
adamc@880 498 doCols : ({loc : ErrorMsg.span, wontLeakStrings : bool, col : int, typ : sql_type} -> Print.PD.pp_desc)
adamc@867 499 -> Print.PD.pp_desc}
adamc@867 500 -> Print.PD.pp_desc,
adamc@867 501 queryPrepared : {loc : ErrorMsg.span, id : int, query : string,
adamc@873 502 inputs : sql_type list, cols : sql_type list,
adamc@880 503 doCols : ({loc : ErrorMsg.span, wontLeakStrings : bool, col : int,
adamc@880 504 typ : sql_type} -> Print.PD.pp_desc)
adamc@879 505 -> Print.PD.pp_desc,
adamc@879 506 nested : bool}
adamc@868 507 -> Print.PD.pp_desc,
adam@1293 508 dml : ErrorMsg.span * failure_mode -> Print.PD.pp_desc,
adamc@868 509 dmlPrepared : {loc : ErrorMsg.span, id : int, dml : string,
adam@1293 510 inputs : sql_type list, mode : failure_mode} -> Print.PD.pp_desc,
adamc@878 511 nextval : {loc : ErrorMsg.span, seqName : string option, seqE : Print.PD.pp_desc} -> Print.PD.pp_desc,
adamc@874 512 nextvalPrepared : {loc : ErrorMsg.span, id : int, query : string} -> Print.PD.pp_desc,
adamc@1073 513 setval : {loc : ErrorMsg.span, seqE : Print.PD.pp_desc, count : Print.PD.pp_desc} -> Print.PD.pp_desc,
adamc@874 514 sqlifyString : string -> string,
adamc@874 515 p_cast : string * sql_type -> string,
adamc@874 516 p_blank : int * sql_type -> string,
adamc@877 517 supportsDeleteAs : bool,
adamc@886 518 supportsUpdateAs : bool,
adamc@877 519 createSequence : string -> string,
adamc@878 520 textKeysNeedLengths : bool,
adamc@879 521 supportsNextval : bool,
adamc@882 522 supportsNestedPrepared : bool,
adamc@890 523 sqlPrefix : string,
adamc@1014 524 supportsOctetLength : bool,
adamc@1014 525 trueString : string,
adamc@1196 526 falseString : string,
adamc@1196 527 onlyUnion : bool,
adamc@1196 528 nestedRelops : bool
adamc@866 529 }
adamc@866 530
adamc@866 531 val dbmses = ref ([] : dbms list)
adamc@866 532 val curDb = ref ({name = "",
adam@1682 533 randomFunction = "",
adamc@866 534 header = "",
adamc@866 535 link = "",
adamc@873 536 p_sql_type = fn _ => "",
adamc@867 537 init = fn _ => Print.box [],
adamc@867 538 query = fn _ => Print.box [],
adamc@868 539 queryPrepared = fn _ => Print.box [],
adamc@868 540 dml = fn _ => Print.box [],
adamc@869 541 dmlPrepared = fn _ => Print.box [],
adamc@869 542 nextval = fn _ => Print.box [],
adamc@874 543 nextvalPrepared = fn _ => Print.box [],
adamc@1073 544 setval = fn _ => Print.box [],
adamc@874 545 sqlifyString = fn s => s,
adamc@874 546 p_cast = fn _ => "",
adamc@874 547 p_blank = fn _ => "",
adamc@877 548 supportsDeleteAs = false,
adamc@886 549 supportsUpdateAs = false,
adamc@877 550 createSequence = fn _ => "",
adamc@878 551 textKeysNeedLengths = false,
adamc@879 552 supportsNextval = false,
adamc@882 553 supportsNestedPrepared = false,
adamc@890 554 sqlPrefix = "",
adamc@1014 555 supportsOctetLength = false,
adamc@1014 556 trueString = "",
adamc@1196 557 falseString = "",
adamc@1196 558 onlyUnion = false,
adamc@1196 559 nestedRelops = false} : dbms)
adamc@866 560
adamc@866 561 fun addDbms v = dbmses := v :: !dbmses
adamc@866 562 fun setDbms s =
adamc@866 563 case List.find (fn db => #name db = s) (!dbmses) of
adamc@866 564 NONE => raise Fail ("Unknown DBMS " ^ s)
adamc@866 565 | SOME db => curDb := db
adamc@866 566 fun currentDbms () = !curDb
adamc@866 567
adamc@891 568 val dbstring = ref (NONE : string option)
adamc@891 569 fun setDbstring so = dbstring := so
adamc@891 570 fun getDbstring () = !dbstring
adamc@891 571
adamc@891 572 val exe = ref (NONE : string option)
adamc@891 573 fun setExe so = exe := so
adamc@891 574 fun getExe () = !exe
adamc@891 575
adamc@891 576 val sql = ref (NONE : string option)
adamc@891 577 fun setSql so = sql := so
adamc@891 578 fun getSql () = !sql
adamc@891 579
adamc@1016 580 val coreInline = ref 20
adamc@1016 581 fun setCoreInline n = coreInline := n
adamc@1016 582 fun getCoreInline () = !coreInline
adamc@1016 583
adam@1351 584 val monoInline = ref 100
adamc@1016 585 fun setMonoInline n = monoInline := n
adamc@1016 586 fun getMonoInline () = !monoInline
adamc@1016 587
adamc@1095 588 val staticLinking = ref false
adamc@1095 589 fun setStaticLinking b = staticLinking := b
adamc@1095 590 fun getStaticLinking () = !staticLinking
adamc@1095 591
adamc@1114 592 val deadlines = ref false
adamc@1114 593 fun setDeadlines b = deadlines := b
adamc@1114 594 fun getDeadlines () = !deadlines
adamc@1114 595
adamc@1164 596 val sigFile = ref (NONE : string option)
adamc@1164 597 fun setSigFile v = sigFile := v
adamc@1164 598 fun getSigFile () = !sigFile
adamc@1164 599
adamc@1183 600 structure SS = BinarySetFn(struct
adamc@1183 601 type ord_key = string
adamc@1183 602 val compare = String.compare
adamc@1183 603 end)
adamc@1183 604
adamc@1183 605 val safeGet = ref SS.empty
adamc@1183 606 fun setSafeGets ls = safeGet := SS.addList (SS.empty, ls)
adamc@1183 607 fun isSafeGet x = SS.member (!safeGet, x)
adamc@1183 608
adam@1294 609 val onError = ref (NONE : (string * string list * string) option)
adam@1294 610 fun setOnError x = onError := x
adam@1294 611 fun getOnError () = !onError
adam@1294 612
adam@1307 613 val limits = ["messages", "clients", "headers", "page", "heap", "script",
adam@1307 614 "inputs", "subinputs", "cleanup", "deltas", "transactionals",
adam@1308 615 "globals", "database", "time"]
adam@1307 616
adam@1307 617 val limitsList = ref ([] : (string * int) list)
adam@1307 618 fun addLimit (v as (name, _)) =
adam@1307 619 if List.exists (fn name' => name' = name) limits then
adam@1308 620 (limitsList := v :: !limitsList;
adam@1308 621 if name = "time" then
adam@1308 622 setDeadlines true
adam@1308 623 else
adam@1308 624 ())
adam@1307 625 else
adam@1307 626 raise Fail ("Unknown limit category '" ^ name ^ "'")
adam@1307 627 fun limits () = !limitsList
adam@1307 628
adam@1332 629 val minHeap = ref 0
adam@1332 630 fun setMinHeap n = if n >= 0 then minHeap := n else raise Fail "Trying to set negative minHeap"
adam@1332 631 fun getMinHeap () = !minHeap
adam@1332 632
adam@1393 633 structure SS = BinarySetFn(struct
adam@1393 634 type ord_key = string
adam@1393 635 val compare = String.compare
adam@1393 636 end)
adam@1393 637
adam@1393 638 val alwaysInline = ref SS.empty
adam@1393 639 fun addAlwaysInline s = alwaysInline := SS.add (!alwaysInline, s)
adam@1393 640 fun checkAlwaysInline s = SS.member (!alwaysInline, s)
adam@1393 641
adam@1478 642 val noXsrfProtection = ref SS.empty
adam@1478 643 fun addNoXsrfProtection s = noXsrfProtection := SS.add (!noXsrfProtection, s)
adam@1478 644 fun checkNoXsrfProtection s = SS.member (!noXsrfProtection, s)
adam@1478 645
adam@1629 646 val timeFormat = ref "%c"
adam@1629 647 fun setTimeFormat v = timeFormat := v
adam@1629 648 fun getTimeFormat () = !timeFormat
adam@1629 649
adamc@765 650 end