adam@1478: (* Copyright (c) 2008-2011, Adam Chlipala adamc@764: * All rights reserved. adamc@764: * adamc@764: * Redistribution and use in source and binary forms, with or without adamc@764: * modification, are permitted provided that the following conditions are met: adamc@764: * adamc@764: * - Redistributions of source code must retain the above copyright notice, adamc@764: * this list of conditions and the following disclaimer. adamc@764: * - Redistributions in binary form must reproduce the above copyright notice, adamc@764: * this list of conditions and the following disclaimer in the documentation adamc@764: * and/or other materials provided with the distribution. adamc@764: * - The names of contributors may not be used to endorse or promote products adamc@764: * derived from this software without specific prior written permission. adamc@764: * adamc@764: * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" adamc@764: * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE adamc@764: * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE adamc@764: * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE rmbruijn@1597: * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR adamc@764: * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF adamc@764: * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS adamc@764: * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN adamc@764: * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) adamc@764: * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE adamc@764: * POSSIBILITY OF SUCH DAMAGE. adamc@764: *) adamc@764: adamc@764: structure Settings :> SETTINGS = struct adamc@764: ezyang@1739: val configBin = ref Config.bin ezyang@1739: val configLib = ref Config.lib ezyang@1739: val configSrcLib = ref Config.srclib ezyang@1739: val configInclude = ref Config.includ ezyang@1739: val configSitelisp = ref Config.sitelisp ezyang@1739: grrwlf@1871: val configCCompiler = ref Config.ccompiler grrwlf@1871: grrwlf@1871: fun getCCompiler () = !configCCompiler grrwlf@1871: fun setCCompiler cc = configCCompiler := cc grrwlf@1871: ezyang@1739: fun libUr () = OS.Path.joinDirFile {dir = !configSrcLib, ezyang@1739: file = "ur"} ezyang@1739: fun libC () = OS.Path.joinDirFile {dir = !configSrcLib, ezyang@1739: file = "c"} ezyang@1739: fun libJs () = OS.Path.joinDirFile {dir = !configSrcLib, ezyang@1739: file = "js"} ezyang@1739: ezyang@1739: fun libFile s = OS.Path.joinDirFile {dir = libUr (), ezyang@1739: file = s} ezyang@1739: adam@1637: val urlPrefixFull = ref "/" adamc@764: val urlPrefix = ref "/" adam@1370: val urlPrePrefix = ref "" adamc@764: val timeout = ref 0 adamc@764: val headers = ref ([] : string list) adamc@766: val scripts = ref ([] : string list) adamc@764: adam@1637: fun getUrlPrefixFull () = !urlPrefixFull adamc@764: fun getUrlPrefix () = !urlPrefix adam@1370: fun getUrlPrePrefix () = !urlPrePrefix adamc@764: fun setUrlPrefix p = adam@1370: let adam@1370: val prefix = if p = "" then adam@1370: "/" adam@1370: else if String.sub (p, size p - 1) <> #"/" then adam@1370: p ^ "/" adam@1370: else adam@1370: p adam@1370: adam@1470: fun findPrefix n = adam@1470: let adam@1470: val (befor, after) = Substring.splitl (fn ch => ch <> #"/") (Substring.extract (prefix, n, NONE)) adam@1470: in adam@1470: if Substring.isEmpty after then adam@1470: ("", prefix) adam@1470: else adam@1470: (String.substring (prefix, 0, n) ^ Substring.string befor, Substring.string after) rmbruijn@1597: end adam@1470: adam@1370: val (prepre, prefix) = adam@1370: if String.isPrefix "http://" prefix then adam@1470: findPrefix 7 adam@1470: else if String.isPrefix "https://" prefix then adam@1470: findPrefix 8 adam@1370: else adam@1370: ("", prefix) adam@1370: in adam@1637: urlPrefixFull := p; adam@1370: urlPrePrefix := prepre; adam@1370: urlPrefix := prefix adam@1370: end adamc@764: adamc@764: fun getTimeout () = !timeout adamc@764: fun setTimeout n = timeout := n adamc@764: adamc@764: fun getHeaders () = !headers adamc@764: fun setHeaders ls = headers := ls adamc@764: adamc@766: fun getScripts () = !scripts adamc@766: fun setScripts ls = scripts := ls adamc@766: adamc@765: type ffi = string * string adamc@765: adamc@765: structure K = struct adamc@765: type ord_key = ffi adamc@765: fun compare ((m1, x1), (m2, x2)) = adamc@765: Order.join (String.compare (m1, m2), adamc@765: fn () => String.compare (x1, x2)) adamc@764: end adamc@765: adamc@765: structure S = BinarySetFn(K) adamc@765: structure M = BinaryMapFn(K) adamc@765: adamc@765: fun basis x = S.addList (S.empty, map (fn x : string => ("Basis", x)) x) adamc@765: adamc@765: val clientToServerBase = basis ["int", adamc@765: "float", adamc@765: "string", adamc@765: "time", adamc@765: "file", adamc@765: "unit", adamc@765: "option", adamc@765: "list", adam@1288: "bool", adam@1288: "variant"] adamc@765: val clientToServer = ref clientToServerBase adamc@765: fun setClientToServer ls = clientToServer := S.addList (clientToServerBase, ls) adamc@765: fun mayClientToServer x = S.member (!clientToServer, x) adamc@765: adamc@779: val effectfulBase = basis ["dml", adamc@779: "nextval", adamc@1073: "setval", adamc@779: "set_cookie", adamc@1050: "clear_cookie", adamc@765: "new_channel", adamc@1200: "send", adamc@1200: "htmlifyInt_w", adamc@1200: "htmlifyFloat_w", adamc@1200: "htmlifyString_w", adamc@1200: "htmlifyBool_w", adamc@1200: "htmlifyTime_w", adamc@1200: "attrifyInt_w", adamc@1200: "attrifyFloat_w", adamc@1200: "attrifyString_w", adamc@1200: "attrifyChar_w", adamc@1200: "urlifyInt_w", adamc@1200: "urlifyFloat_w", adamc@1200: "urlifyString_w", adamc@1200: "urlifyBool_w", adamc@1200: "urlifyChannel_w"] adamc@765: adamc@765: val effectful = ref effectfulBase adamc@765: fun setEffectful ls = effectful := S.addList (effectfulBase, ls) ziv@2265: fun isEffectful ("Sqlcache", _) = true ziv@2265: | isEffectful x = S.member (!effectful, x) adam@1878: fun addEffectful x = effectful := S.add (!effectful, x) adamc@765: adamc@1171: val benignBase = basis ["get_cookie", adamc@1171: "new_client_source", adamc@1171: "get_client_source", adamc@1171: "set_client_source", adamc@1171: "current", adamc@1171: "alert", adam@1290: "confirm", adamc@1171: "onError", adamc@1171: "onFail", adamc@1171: "onConnectFail", adamc@1171: "onDisconnect", adamc@1171: "onServerError", adam@1783: "mouseEvent", adam@1783: "keyEvent", adamc@1250: "debug", adam@1422: "rand", adam@1465: "now", adam@1465: "getHeader", adam@1555: "setHeader", adam@1555: "spawn", adam@1555: "onClick", adam@1555: "onDblclick", ziv@2130: "onContextmenu", adam@1555: "onKeydown", adam@1555: "onKeypress", adam@1555: "onKeyup", adam@1555: "onMousedown", ziv@2130: "onMouseenter", ziv@2130: "onMouseleave", adam@1791: "onMousemove", adam@1791: "onMouseout", adam@1791: "onMouseover", adam@1556: "onMouseup", adam@1559: "preventDefault", adam@1559: "stopPropagation", adam@1785: "fresh", adam@1952: "giveFocus", adam@1952: "currentUrlHasPost", adam@1952: "currentUrlHasQueryString", adam@1952: "currentUrl"] adamc@1171: adamc@1171: val benign = ref benignBase adamc@1171: fun setBenignEffectful ls = benign := S.addList (benignBase, ls) adam@2010: fun addBenignEffectful x = benign := S.add (!benign, x) adamc@1171: fun isBenignEffectful x = S.member (!benign, x) adamc@1171: adam@1595: val clientBase = basis ["get_client_source", adamc@841: "current", adamc@765: "alert", adam@1290: "confirm", adamc@765: "recv", adamc@765: "sleep", adamc@765: "spawn", adamc@765: "onError", adamc@765: "onFail", adamc@765: "onConnectFail", adamc@765: "onDisconnect", adamc@895: "onServerError", adam@1783: "mouseEvent", adam@1783: "keyEvent", adam@1555: "onClick", ziv@2130: "onContextmenu", adam@1555: "onDblclick", adam@1555: "onKeydown", adam@1555: "onKeypress", adam@1555: "onKeyup", adam@1555: "onMousedown", ziv@2130: "onMouseenter", ziv@2130: "onMouseleave", adam@1791: "onMousemove", adam@1791: "onMouseout", adam@1791: "onMouseover", adam@1559: "onMouseup", adam@1559: "preventDefault", adam@1785: "stopPropagation", adam@1785: "giveFocus"] adamc@765: val client = ref clientBase adamc@765: fun setClientOnly ls = client := S.addList (clientBase, ls) adam@2010: fun addClientOnly x = client := S.add (!client, x) adamc@765: fun isClientOnly x = S.member (!client, x) adamc@765: adamc@765: val serverBase = basis ["requestHeader", adamc@765: "query", adamc@765: "dml", adamc@765: "nextval", adamc@1073: "setval", adamc@765: "channel", adam@1787: "send", adam@1787: "fieldName", adam@1787: "fieldValue", adam@1787: "remainingFields", adam@1787: "firstFormField"] adamc@765: val server = ref serverBase adamc@765: fun setServerOnly ls = server := S.addList (serverBase, ls) adam@2010: fun addServerOnly x = server := S.add (!server, x) adamc@765: fun isServerOnly x = S.member (!server, x) adamc@765: adamc@765: val basisM = foldl (fn ((k, v : string), m) => M.insert (m, ("Basis", k), v)) M.empty adamc@765: adamc@765: val jsFuncsBase = basisM [("alert", "alert"), adam@1599: ("stringToTime", "stringToTime"), adam@1599: ("stringToTime_error", "stringToTime_error"), adam@1609: ("timef", "strftime"), adam@1290: ("confirm", "confrm"), adamc@765: ("get_client_source", "sg"), adamc@841: ("current", "scur"), adamc@765: ("htmlifyBool", "bs"), adamc@765: ("htmlifyFloat", "ts"), adamc@765: ("htmlifyInt", "ts"), adamc@765: ("htmlifyString", "eh"), adamc@765: ("new_client_source", "sc"), adamc@765: ("set_client_source", "sv"), adamc@838: ("stringToFloat", "pflo"), adamc@838: ("stringToInt", "pio"), adamc@765: ("stringToFloat_error", "pfl"), adamc@765: ("stringToInt_error", "pi"), adamc@765: ("urlifyInt", "ts"), adamc@765: ("urlifyFloat", "ts"), adam@1360: ("urlifyTime", "ts"), adamc@765: ("urlifyString", "uf"), adamc@912: ("urlifyBool", "ub"), adamc@765: ("recv", "rv"), adamc@765: ("strcat", "cat"), adamc@765: ("intToString", "ts"), adamc@765: ("floatToString", "ts"), adamc@821: ("charToString", "ts"), adamc@765: ("onError", "onError"), adamc@765: ("onFail", "onFail"), adamc@765: ("onConnectFail", "onConnectFail"), adamc@765: ("onDisconnect", "onDisconnect"), adamc@798: ("onServerError", "onServerError"), adamc@1108: ("attrifyString", "atr"), adamc@798: ("attrifyInt", "ts"), adamc@798: ("attrifyFloat", "ts"), adamc@820: ("attrifyBool", "bs"), adamc@821: ("boolToString", "ts"), adamc@1057: ("str1", "id"), adamc@821: ("strsub", "sub"), adamc@828: ("strsuffix", "suf"), adamc@829: ("strlen", "slen"), adamc@829: ("strindex", "sidx"), dukhovni@2045: ("strsindex", "ssidx"), adamc@829: ("strchr", "schr"), adamc@831: ("substring", "ssub"), adamc@895: ("strcspn", "sspn"), adam@1624: ("strlenGe", "strlenGe"), adam@1783: ("mouseEvent", "uw_mouseEvent"), adam@1783: ("keyEvent", "uw_keyEvent"), adam@1404: ("minTime", "0"), adam@2097: ("stringToBool_error", "s2be"), adam@2097: ("stringToBool", "s2b"), adamc@1061: adamc@1061: ("islower", "isLower"), adamc@1061: ("isupper", "isUpper"), adamc@1061: ("isalpha", "isAlpha"), adamc@1061: ("isdigit", "isDigit"), adamc@1061: ("isalnum", "isAlnum"), adamc@1061: ("isblank", "isBlank"), adamc@1061: ("isspace", "isSpace"), adamc@1061: ("isxdigit", "isXdigit"), adam@1927: ("isprint", "isPrint"), adamc@1061: ("tolower", "toLower"), adamc@1323: ("toupper", "toUpper"), adam@1927: ("ord", "ord"), adamc@1323: adamc@1323: ("checkUrl", "checkUrl"), adam@1366: ("bless", "bless"), adam@2008: ("blessData", "blessData"), adam@1366: adam@1366: ("eq_time", "eq"), adam@1366: ("lt_time", "lt"), adam@1430: ("le_time", "le"), adam@1430: adam@1625: ("debug", "uw_debug"), adam@1625: ("naughtyDebug", "uw_debug"), adam@1487: adam@1571: ("floatFromInt", "float"), adam@1571: ("ceil", "ceil"), adam@1571: ("trunc", "trunc"), adam@1571: ("round", "round"), adam@1571: adam@1487: ("now", "now"), adam@1487: ("timeToString", "showTime"), adam@1629: ("htmlifyTime", "showTimeHtml"), adam@1514: ("toSeconds", "toSeconds"), adam@1518: ("addSeconds", "addSeconds"), adam@1555: ("diffInSeconds", "diffInSeconds"), adam@1685: ("toMilliseconds", "toMilliseconds"), adam@2187: ("fromMilliseconds", "fromMilliseconds"), adam@1685: ("diffInMilliseconds", "diffInMilliseconds"), adam@1555: phurst@1986: ("fromDatetime", "fromDatetime"), phurst@1986: ("datetimeYear", "datetimeYear"), phurst@1986: ("datetimeMonth", "datetimeMonth"), phurst@1986: ("datetimeDay", "datetimeDay"), phurst@1986: ("datetimeHour", "datetimeHour"), phurst@1986: ("datetimeMinute", "datetimeMinute"), phurst@1986: ("datetimeSecond", "datetimeSecond"), phurst@1986: ("datetimeDayOfWeek", "datetimeDayOfWeek"), phurst@1986: phurst@1986: adam@1555: ("onClick", "uw_onClick"), ziv@2130: ("onContextmenu", "uw_onContextmenu"), adam@1555: ("onDblclick", "uw_onDblclick"), adam@1555: ("onKeydown", "uw_onKeydown"), adam@1555: ("onKeypress", "uw_onKeypress"), adam@1555: ("onKeyup", "uw_onKeyup"), adam@1555: ("onMousedown", "uw_onMousedown"), ziv@2130: ("onMouseenter", "uw_onMouseenter"), ziv@2130: ("onMouseleave", "uw_onMouseleave"), adam@1791: ("onMousemove", "uw_onMousemove"), adam@1791: ("onMouseout", "uw_onMouseout"), adam@1791: ("onMouseover", "uw_onMouseover"), adam@1556: ("onMouseup", "uw_onMouseup"), adam@1559: ("preventDefault", "uw_preventDefault"), adam@1559: ("stopPropagation", "uw_stopPropagation"), adam@1556: adam@1755: ("fresh", "fresh"), adam@1755: adam@1755: ("atom", "atom"), adam@1755: ("css_url", "css_url"), adam@1785: ("property", "property"), adam@2189: ("giveFocus", "giveFocus"), adam@2189: adam@2189: ("htmlifySpecialChar", "htmlifySpecialChar"), adam@2189: ("chr", "chr")] adamc@765: val jsFuncs = ref jsFuncsBase adamc@765: fun setJsFuncs ls = jsFuncs := foldl (fn ((k, v), m) => M.insert (m, k, v)) jsFuncsBase ls adamc@765: fun jsFunc x = M.find (!jsFuncs, x) adam@2010: fun addJsFunc (k, v) = jsFuncs := M.insert (!jsFuncs, k, v) adam@1433: fun allJsFuncs () = M.listItemsi (!jsFuncs) adamc@765: adamc@768: datatype pattern_kind = Exact | Prefix adamc@768: datatype action = Allow | Deny adamc@768: type rule = { action : action, kind : pattern_kind, pattern : string } adamc@768: adamc@768: datatype path_kind = Any | Url | Table | Sequence | View | Relation | Cookie | Style adam@1752: type rewrite = { pkind : path_kind, kind : pattern_kind, from : string, to : string, hyphenate : bool } adamc@768: adam@2096: fun pak2s pak = adam@2096: case pak of adam@2096: Exact => "Exact" adam@2096: | Prefix => "Prefix" adam@2096: fun pk2s pk = adam@2096: case pk of adam@2096: Any => "Any" adam@2096: | Url => "Url" adam@2096: | Table => "Table" adam@2096: | Sequence => "Sequence" adam@2096: | View => "View" adam@2096: | Relation => "Relation" adam@2096: | Cookie => "Cookie" adam@2096: | Style => "Style" adam@2096: fun r2s (r : rewrite) = pak2s (#kind r) ^ " " ^ pk2s (#pkind r) ^ ", from<" ^ #from r ^ ">, to<" ^ #to r ^ ">" adam@2096: adamc@768: val rewrites = ref ([] : rewrite list) adamc@768: adamc@768: fun subsume (pk1, pk2) = adamc@768: pk1 = pk2 adamc@768: orelse pk2 = Any adamc@768: orelse pk2 = Relation andalso (pk1 = Table orelse pk1 = Sequence orelse pk1 = View) adamc@768: adamc@768: fun setRewriteRules ls = rewrites := ls adamc@768: fun rewrite pk s = adamc@768: let adamc@768: fun rew (ls : rewrite list) = adamc@768: case ls of adamc@768: [] => s adamc@768: | rewr :: ls => adamc@768: let adamc@768: fun match () = adamc@768: case #kind rewr of adamc@768: Exact => if #from rewr = s then adamc@768: SOME (size s) adamc@768: else adamc@768: NONE adamc@768: | Prefix => if String.isPrefix (#from rewr) s then adamc@768: SOME (size (#from rewr)) adamc@768: else adamc@768: NONE adamc@768: in adamc@768: if subsume (pk, #pkind rewr) then adamc@768: case match () of adamc@768: NONE => rew ls adam@1752: | SOME suffixStart => adam@1752: let adam@1752: val s = #to rewr ^ String.extract (s, suffixStart, NONE) adam@1752: in adam@1752: if #hyphenate rewr then adam@1752: String.translate (fn #"_" => "-" | ch => str ch) s adam@1752: else adam@1752: s adam@1752: end adamc@768: else adamc@768: rew ls adamc@768: end adamc@768: in adamc@768: rew (!rewrites) adamc@768: end adamc@768: adamc@769: val url = ref ([] : rule list) adamc@769: val mime = ref ([] : rule list) adam@1465: val request = ref ([] : rule list) adam@1465: val response = ref ([] : rule list) adam@1799: val env = ref ([] : rule list) adamc@769: adamc@769: fun setUrlRules ls = url := ls adamc@769: fun setMimeRules ls = mime := ls adam@1465: fun setRequestHeaderRules ls = request := ls adam@1465: fun setResponseHeaderRules ls = response := ls adam@1799: fun setEnvVarRules ls = env := ls adamc@769: adamc@770: fun getUrlRules () = !url adamc@770: fun getMimeRules () = !mime adam@1465: fun getRequestHeaderRules () = !request adam@1465: fun getResponseHeaderRules () = !response adam@1799: fun getEnvVarRules () = !env adamc@770: adamc@769: fun check f rules s = adamc@769: let adamc@769: fun chk (ls : rule list) = adamc@769: case ls of adamc@769: [] => false adamc@769: | rule :: ls => adamc@769: let adamc@769: val matches = adamc@769: case #kind rule of adamc@769: Exact => #pattern rule = s adamc@769: | Prefix => String.isPrefix (#pattern rule) s adamc@769: in adamc@769: if matches then adamc@769: case #action rule of adamc@769: Allow => true adamc@769: | Deny => false adamc@769: else adamc@769: chk ls adamc@769: end adamc@769: in adamc@769: f s andalso chk (!rules) adamc@769: end adamc@769: adamc@769: val checkUrl = check (fn _ => true) url adam@1465: grrwlf@2024: val validMime = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"/" orelse ch = #"-" orelse ch = #"." orelse ch = #"+") adam@1799: val validEnv = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"_" orelse ch = #".") adam@1465: adam@1465: val checkMime = check validMime mime adam@1465: val checkRequestHeader = check validMime request adam@1465: val checkResponseHeader = check validMime response adam@1799: val checkEnvVar = check validEnv env adamc@769: adamc@855: adamc@855: type protocol = { adamc@855: name : string, adamc@1096: compile : string, adamc@1095: linkStatic : string, adamc@1095: linkDynamic : string, adamc@1164: persistent : bool, adamc@1164: code : unit -> Print.PD.pp_desc adamc@855: } adamc@855: val protocols = ref ([] : protocol list) adamc@855: fun addProtocol p = protocols := p :: !protocols adamc@855: fun getProtocol s = List.find (fn p => #name p = s) (!protocols) adamc@855: ezyang@1739: fun clibFile s = OS.Path.joinDirFile {dir = libC (), adamc@855: file = s} adamc@855: adamc@865: val curProto = ref {name = "", adamc@1096: compile = "", adamc@1095: linkStatic = "", adamc@1095: linkDynamic = "", adamc@1164: persistent = false, adamc@1164: code = fn () => Print.box []} adamc@856: fun setProtocol name = adamc@856: case getProtocol name of adamc@856: NONE => raise Fail ("Unknown protocol " ^ name) adamc@856: | SOME p => curProto := p adamc@855: fun currentProtocol () = !curProto adamc@855: adamc@857: val debug = ref false adamc@857: fun setDebug b = debug := b adamc@857: fun getDebug () = !debug adamc@857: adamc@867: datatype sql_type = adamc@867: Int adamc@867: | Float adamc@867: | String adamc@1011: | Char adamc@867: | Bool adamc@867: | Time adamc@867: | Blob adamc@867: | Channel adamc@867: | Client adamc@867: | Nullable of sql_type adamc@867: adamc@873: fun p_sql_ctype t = adamc@867: let adamc@867: open Print.PD adamc@867: open Print adamc@867: in adamc@867: case t of adamc@870: Int => "uw_Basis_int" adamc@870: | Float => "uw_Basis_float" adamc@870: | String => "uw_Basis_string" adamc@1011: | Char => "uw_Basis_char" adamc@870: | Bool => "uw_Basis_bool" adamc@870: | Time => "uw_Basis_time" adamc@870: | Blob => "uw_Basis_blob" adamc@870: | Channel => "uw_Basis_channel" adamc@870: | Client => "uw_Basis_client" adamc@870: | Nullable String => "uw_Basis_string" adamc@873: | Nullable t => p_sql_ctype t ^ "*" adamc@867: end adamc@867: adamc@867: fun isBlob Blob = true adamc@867: | isBlob (Nullable t) = isBlob t adamc@867: | isBlob _ = false adamc@867: adamc@870: fun isNotNull (Nullable _) = false adamc@870: | isNotNull _ = true adamc@870: adam@1293: datatype failure_mode = Error | None adam@1293: adamc@866: type dbms = { adamc@866: name : string, adam@1682: randomFunction : string, adamc@866: header : string, adamc@866: link : string, adamc@873: p_sql_type : sql_type -> string, adamc@870: init : {dbstring : string, adamc@870: prepared : (string * int) list, adamc@870: tables : (string * (string * sql_type) list) list, adamc@872: views : (string * (string * sql_type) list) list, adamc@870: sequences : string list} -> Print.PD.pp_desc, adamc@873: query : {loc : ErrorMsg.span, cols : sql_type list, adamc@880: doCols : ({loc : ErrorMsg.span, wontLeakStrings : bool, col : int, typ : sql_type} -> Print.PD.pp_desc) adamc@867: -> Print.PD.pp_desc} adamc@867: -> Print.PD.pp_desc, adamc@867: queryPrepared : {loc : ErrorMsg.span, id : int, query : string, adamc@873: inputs : sql_type list, cols : sql_type list, adamc@880: doCols : ({loc : ErrorMsg.span, wontLeakStrings : bool, col : int, adamc@880: typ : sql_type} -> Print.PD.pp_desc) adamc@879: -> Print.PD.pp_desc, adamc@879: nested : bool} adamc@868: -> Print.PD.pp_desc, adam@1293: dml : ErrorMsg.span * failure_mode -> Print.PD.pp_desc, adamc@868: dmlPrepared : {loc : ErrorMsg.span, id : int, dml : string, adam@1293: inputs : sql_type list, mode : failure_mode} -> Print.PD.pp_desc, adamc@878: nextval : {loc : ErrorMsg.span, seqName : string option, seqE : Print.PD.pp_desc} -> Print.PD.pp_desc, adamc@874: nextvalPrepared : {loc : ErrorMsg.span, id : int, query : string} -> Print.PD.pp_desc, adamc@1073: setval : {loc : ErrorMsg.span, seqE : Print.PD.pp_desc, count : Print.PD.pp_desc} -> Print.PD.pp_desc, adamc@874: sqlifyString : string -> string, adamc@874: p_cast : string * sql_type -> string, adamc@874: p_blank : int * sql_type -> string, adamc@877: supportsDeleteAs : bool, adamc@886: supportsUpdateAs : bool, adamc@877: createSequence : string -> string, adamc@878: textKeysNeedLengths : bool, adamc@879: supportsNextval : bool, adamc@882: supportsNestedPrepared : bool, adamc@890: sqlPrefix : string, adamc@1014: supportsOctetLength : bool, adamc@1014: trueString : string, adamc@1196: falseString : string, adamc@1196: onlyUnion : bool, adam@1777: nestedRelops : bool, adam@1778: windowFunctions: bool adamc@866: } adamc@866: adamc@866: val dbmses = ref ([] : dbms list) adamc@866: val curDb = ref ({name = "", adam@1682: randomFunction = "", adamc@866: header = "", adamc@866: link = "", adamc@873: p_sql_type = fn _ => "", adamc@867: init = fn _ => Print.box [], adamc@867: query = fn _ => Print.box [], adamc@868: queryPrepared = fn _ => Print.box [], adamc@868: dml = fn _ => Print.box [], adamc@869: dmlPrepared = fn _ => Print.box [], adamc@869: nextval = fn _ => Print.box [], adamc@874: nextvalPrepared = fn _ => Print.box [], adamc@1073: setval = fn _ => Print.box [], adamc@874: sqlifyString = fn s => s, adamc@874: p_cast = fn _ => "", adamc@874: p_blank = fn _ => "", adamc@877: supportsDeleteAs = false, adamc@886: supportsUpdateAs = false, adamc@877: createSequence = fn _ => "", adamc@878: textKeysNeedLengths = false, adamc@879: supportsNextval = false, adamc@882: supportsNestedPrepared = false, adamc@890: sqlPrefix = "", adamc@1014: supportsOctetLength = false, adamc@1014: trueString = "", adamc@1196: falseString = "", adamc@1196: onlyUnion = false, adam@1777: nestedRelops = false, adam@1777: windowFunctions = false} : dbms) adamc@866: adamc@866: fun addDbms v = dbmses := v :: !dbmses adamc@866: fun setDbms s = adamc@866: case List.find (fn db => #name db = s) (!dbmses) of adamc@866: NONE => raise Fail ("Unknown DBMS " ^ s) adamc@866: | SOME db => curDb := db adamc@866: fun currentDbms () = !curDb adamc@866: adamc@891: val dbstring = ref (NONE : string option) adamc@891: fun setDbstring so = dbstring := so adamc@891: fun getDbstring () = !dbstring adamc@891: adamc@891: val exe = ref (NONE : string option) adamc@891: fun setExe so = exe := so adamc@891: fun getExe () = !exe adamc@891: adamc@891: val sql = ref (NONE : string option) adamc@891: fun setSql so = sql := so adamc@891: fun getSql () = !sql adamc@891: adam@1820: val coreInline = ref 5 adamc@1016: fun setCoreInline n = coreInline := n adamc@1016: fun getCoreInline () = !coreInline adamc@1016: adam@1820: val monoInline = ref 5 adamc@1016: fun setMonoInline n = monoInline := n adamc@1016: fun getMonoInline () = !monoInline adamc@1016: adamc@1095: val staticLinking = ref false adamc@1095: fun setStaticLinking b = staticLinking := b adamc@1095: fun getStaticLinking () = !staticLinking adamc@1095: adamc@1114: val deadlines = ref false adamc@1114: fun setDeadlines b = deadlines := b adamc@1114: fun getDeadlines () = !deadlines adamc@1114: adamc@1164: val sigFile = ref (NONE : string option) adamc@1164: fun setSigFile v = sigFile := v adamc@1164: fun getSigFile () = !sigFile adamc@1164: adamc@1183: structure SS = BinarySetFn(struct adamc@1183: type ord_key = string adamc@1183: val compare = String.compare adamc@1183: end) adamc@1183: adamc@1183: val safeGet = ref SS.empty adamc@1183: fun setSafeGets ls = safeGet := SS.addList (SS.empty, ls) adamc@1183: fun isSafeGet x = SS.member (!safeGet, x) adamc@1183: adam@1294: val onError = ref (NONE : (string * string list * string) option) adam@1294: fun setOnError x = onError := x adam@1294: fun getOnError () = !onError adam@1294: adam@1307: val limits = ["messages", "clients", "headers", "page", "heap", "script", adam@1307: "inputs", "subinputs", "cleanup", "deltas", "transactionals", adam@1308: "globals", "database", "time"] adam@1307: adam@1307: val limitsList = ref ([] : (string * int) list) adam@1307: fun addLimit (v as (name, _)) = adam@1307: if List.exists (fn name' => name' = name) limits then adam@1308: (limitsList := v :: !limitsList; adam@1308: if name = "time" then adam@1308: setDeadlines true adam@1308: else adam@1308: ()) adam@1307: else adam@1307: raise Fail ("Unknown limit category '" ^ name ^ "'") adam@1307: fun limits () = !limitsList adam@1307: adam@1332: val minHeap = ref 0 adam@1332: fun setMinHeap n = if n >= 0 then minHeap := n else raise Fail "Trying to set negative minHeap" adam@1332: fun getMinHeap () = !minHeap adam@1332: adam@1393: structure SS = BinarySetFn(struct adam@1393: type ord_key = string adam@1393: val compare = String.compare adam@1393: end) adam@1393: adam@1393: val alwaysInline = ref SS.empty adam@1393: fun addAlwaysInline s = alwaysInline := SS.add (!alwaysInline, s) adam@1393: fun checkAlwaysInline s = SS.member (!alwaysInline, s) adam@1393: adam@1966: val neverInline = ref SS.empty adam@1966: fun addNeverInline s = neverInline := SS.add (!neverInline, s) adam@1966: fun checkNeverInline s = SS.member (!neverInline, s) adam@1966: adam@1478: val noXsrfProtection = ref SS.empty adam@1478: fun addNoXsrfProtection s = noXsrfProtection := SS.add (!noXsrfProtection, s) adam@1478: fun checkNoXsrfProtection s = SS.member (!noXsrfProtection, s) adam@1478: adam@1629: val timeFormat = ref "%c" adam@1629: fun setTimeFormat v = timeFormat := v adam@1629: fun getTimeFormat () = !timeFormat adam@1629: adam@1953: fun lowercase s = adam@1953: case s of adam@1953: "" => "" adam@1953: | _ => str (Char.toLower (String.sub (s, 0))) ^ String.extract (s, 1, NONE) adam@1953: adam@1953: fun capitalize s = adam@1953: case s of adam@1953: "" => "" adam@1953: | _ => str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) adam@1953: adam@2108: val allLower = CharVector.map Char.toLower adam@2108: adam@1953: val mangle = ref true adam@1953: fun setMangleSql x = mangle := x adam@2108: adam@2108: fun mangleSqlTable s = adam@2108: if #name (currentDbms ()) = "mysql" then adam@2108: if !mangle then adam@2108: "uw_" ^ allLower s adam@2108: else adam@2108: allLower s adam@2108: else adam@2108: if !mangle then adam@2108: "uw_" ^ capitalize s adam@2108: else adam@2108: lowercase s adam@2108: adam@2108: fun mangleSql s = adam@2108: if #name (currentDbms ()) = "mysql" then adam@2108: if !mangle then ziv@2130: "uw_" ^ allLower s adam@2108: else adam@2108: allLower s adam@2108: else adam@2108: if !mangle then adam@2108: "uw_" ^ s adam@2108: else adam@2108: lowercase s adam@2108: adam@2108: fun mangleSqlCatalog s = adam@2108: if #name (currentDbms ()) = "mysql" then adam@2108: if !mangle then adam@2108: "uw_" ^ allLower s adam@2108: else adam@2108: allLower s adam@2108: else adam@2108: if !mangle then adam@2108: "uw_" ^ s adam@2108: else adam@2108: lowercase s adam@1953: adam@1956: val html5 = ref false adam@1956: fun setIsHtml5 b = html5 := b adam@1956: fun getIsHtml5 () = !html5 adam@1956: adam@2010: val less = ref false adam@2010: fun setLessSafeFfi b = less := b adam@2010: fun getLessSafeFfi () = !less adam@2010: ziv@2213: val sqlcache = ref false ziv@2213: fun setSqlcache b = sqlcache := b ziv@2213: fun getSqlcache () = !sqlcache ziv@2213: adam@2046: structure SM = BinaryMapFn(struct adam@2046: type ord_key = string adam@2046: val compare = String.compare adam@2046: end) adam@2046: adam@2046: val noMimeFile = ref false adam@2046: adam@2046: fun noMime () = adam@2046: (TextIO.output (TextIO.stdErr, "WARNING: Error opening /etc/mime.types. Static files will be served with no suggested MIME types.\n"); adam@2046: noMimeFile := true; adam@2046: SM.empty) adam@2046: adam@2046: fun readMimeTypes () = adam@2046: let adam@2046: val inf = TextIO.openIn "/etc/mime.types" adam@2046: adam@2046: fun loop m = adam@2046: case TextIO.inputLine inf of adam@2046: NONE => m adam@2046: | SOME line => adam@2046: if size line > 0 andalso String.sub (line, 0) = #"#" then adam@2046: loop m adam@2046: else adam@2046: case String.tokens Char.isSpace line of adam@2046: typ :: exts => adam@2046: loop (foldl (fn (ext, m) => SM.insert (m, ext, typ)) m exts) adam@2046: | _ => loop m adam@2046: in adam@2046: loop SM.empty adam@2046: before TextIO.closeIn inf adam@2046: end handle IO.Io _ => noMime () adam@2046: | OS.SysErr _ => noMime () adam@2046: adam@2046: val mimeTypes = ref (NONE : string SM.map option) adam@2046: adam@2046: fun getMimeTypes () = adam@2046: case !mimeTypes of adam@2046: SOME m => m adam@2046: | NONE => adam@2046: let adam@2046: val m = readMimeTypes () adam@2046: in adam@2046: mimeTypes := SOME m; adam@2046: m adam@2046: end adam@2046: adam@2046: fun mimeTypeOf filename = adam@2046: case OS.Path.ext filename of adam@2046: NONE => (if !noMimeFile then adam@2046: () adam@2046: else adam@2046: TextIO.output (TextIO.stdErr, "WARNING: No extension found in filename '" ^ filename ^ "'. Header 'Content-Type' will be omitted in HTTP responses.\n"); adam@2046: NONE) adam@2046: | SOME ext => adam@2046: let adam@2046: val to = SM.find (getMimeTypes (), ext) adam@2046: in adam@2046: case to of adam@2046: NONE => if !noMimeFile then adam@2046: () adam@2046: else adam@2046: TextIO.output (TextIO.stdErr, "WARNING: No MIME type known for extension '" ^ ext ^ "'. Header 'Content-Type' will be omitted in HTTP responses.\n") adam@2046: | _ => (); adam@2046: to adam@2046: end adam@2046: adam@2046: val files = ref (SM.empty : (string * {Uri : string, ContentType : string option, LastModified : Time.time, Bytes : Word8Vector.vector}) SM.map) adam@2046: adam@2046: val filePath = ref "." adam@2046: adam@2046: fun setFilePath path = filePath := path adam@2046: adam@2046: fun addFile {Uri, LoadFromFilename} = adam@2046: let julian@2135: val path = OS.Path.concat (!filePath, LoadFromFilename) adam@2046: in adam@2046: case SM.find (!files, Uri) of adam@2046: SOME (path', _) => adam@2183: if OS.Path.mkCanonical path' = OS.Path.mkCanonical path then adam@2046: () adam@2046: else adam@2172: ErrorMsg.error ("Two different files requested for URI " ^ Uri ^ " ( " ^ path' ^ " vs. " ^ path ^ ")") adam@2046: | NONE => adam@2046: let adam@2046: val inf = BinIO.openIn path adam@2046: in adam@2046: files := SM.insert (!files, adam@2046: Uri, adam@2046: (path, adam@2046: {Uri = Uri, adam@2046: ContentType = mimeTypeOf path, adam@2046: LastModified = OS.FileSys.modTime path, adam@2046: Bytes = BinIO.inputAll inf})); adam@2046: BinIO.closeIn inf adam@2046: end adam@2046: end handle IO.Io _ => adam@2046: ErrorMsg.error ("Error loading file " ^ LoadFromFilename) adam@2046: | OS.SysErr (s, _) => adam@2046: ErrorMsg.error ("Error loading file " ^ LoadFromFilename ^ " (" ^ s ^ ")") adam@2046: adam@2046: fun listFiles () = map #2 (SM.listItems (!files)) adam@2046: adamc@765: end