adamc@1114: (* Copyright (c) 2008-2010, 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 adamc@764: * 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: adamc@764: val urlPrefix = ref "/" adamc@764: val timeout = ref 0 adamc@764: val headers = ref ([] : string list) adamc@766: val scripts = ref ([] : string list) adamc@764: adamc@764: fun getUrlPrefix () = !urlPrefix adamc@764: fun setUrlPrefix p = adamc@764: urlPrefix := (if p = "" then adamc@764: "/" adamc@764: else if String.sub (p, size p - 1) <> #"/" then adamc@764: p ^ "/" adamc@764: else adamc@764: p) 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", adamc@765: "bool"] 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@1171: "send"] adamc@765: adamc@765: val effectful = ref effectfulBase adamc@765: fun setEffectful ls = effectful := S.addList (effectfulBase, ls) adamc@765: fun isEffectful x = S.member (!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", adamc@1171: "onError", adamc@1171: "onFail", adamc@1171: "onConnectFail", adamc@1171: "onDisconnect", adamc@1171: "onServerError", adamc@1171: "kc", adamc@1171: "debug"] adamc@1171: adamc@1171: val benign = ref benignBase adamc@1171: fun setBenignEffectful ls = benign := S.addList (benignBase, ls) adamc@1171: fun isBenignEffectful x = S.member (!benign, x) adamc@1171: adamc@765: val clientBase = basis ["get", adamc@765: "set", adamc@841: "current", adamc@765: "alert", adamc@765: "recv", adamc@765: "sleep", adamc@765: "spawn", adamc@765: "onError", adamc@765: "onFail", adamc@765: "onConnectFail", adamc@765: "onDisconnect", adamc@895: "onServerError", adamc@895: "kc"] adamc@765: val client = ref clientBase adamc@765: fun setClientOnly ls = client := S.addList (clientBase, ls) 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", adamc@765: "send"] adamc@765: val server = ref serverBase adamc@765: fun setServerOnly ls = server := S.addList (serverBase, ls) 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"), 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"), 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"), adamc@829: ("strchr", "schr"), adamc@831: ("substring", "ssub"), adamc@895: ("strcspn", "sspn"), adamc@1061: ("kc", "kc"), 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"), adamc@1061: ("tolower", "toLower"), adamc@1061: ("toupper", "toUpper")] 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) 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 adamc@768: type rewrite = { pkind : path_kind, kind : pattern_kind, from : string, to : string } adamc@768: 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 adamc@768: | SOME suffixStart => #to rewr ^ String.extract (s, suffixStart, NONE) 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) adamc@769: adamc@769: fun setUrlRules ls = url := ls adamc@769: fun setMimeRules ls = mime := ls adamc@769: adamc@770: fun getUrlRules () = !url adamc@770: fun getMimeRules () = !mime 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 adamc@769: val checkMime = check adamc@769: (CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"/" orelse ch = #"-" orelse ch = #".")) adamc@769: mime 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: adamc@855: fun clibFile s = OS.Path.joinDirFile {dir = Config.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: adamc@866: type dbms = { adamc@866: name : 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, adamc@868: dml : ErrorMsg.span -> Print.PD.pp_desc, adamc@868: dmlPrepared : {loc : ErrorMsg.span, id : int, dml : string, adamc@869: inputs : sql_type list} -> 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@1014: falseString : string adamc@866: } adamc@866: adamc@866: val dbmses = ref ([] : dbms list) adamc@866: val curDb = ref ({name = "", 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@1014: falseString = ""} : 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: adamc@1016: val coreInline = ref 20 adamc@1016: fun setCoreInline n = coreInline := n adamc@1016: fun getCoreInline () = !coreInline adamc@1016: adamc@1016: val monoInline = ref 20 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: adamc@765: end