adamc@764: (* Copyright (c) 2008-2009, 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@779: "set_cookie", adamc@765: "new_client_source", adamc@765: "get_client_source", adamc@765: "set_client_source", adamc@765: "alert", adamc@765: "new_channel", adamc@765: "send", adamc@765: "onError", adamc@765: "onFail", adamc@765: "onConnectFail", adamc@765: "onDisconnect", adamc@765: "onServerError"] 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@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@765: "onServerError"] 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@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@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@798: ("attrifyString", "escape"), adamc@798: ("attrifyInt", "ts"), adamc@798: ("attrifyFloat", "ts"), adamc@820: ("attrifyBool", "bs"), adamc@821: ("boolToString", "ts"), 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@831: ("strcspn", "sspn")] 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@765: end