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