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",
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)
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",
adam@1290:                         "confirm",
adamc@1171:                         "onError",
adamc@1171:                         "onFail",
adamc@1171:                         "onConnectFail",
adamc@1171:                         "onDisconnect",
adamc@1171:                         "onServerError",
adamc@1171:                         "kc",
adamc@1250:                         "debug",
adamc@1250:                         "rand"]
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",
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",
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"),
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"),
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: 
adam@1293: datatype failure_mode = Error | None
adam@1293: 
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,
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,
adamc@1196:      nestedRelops : bool
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@1196:                   falseString = "",
adamc@1196:                   onlyUnion = false,
adamc@1196:                   nestedRelops = 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: 
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: 
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: 
adamc@765: end