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)
adamc@765: fun 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@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@1785:                           ("giveFocus", "giveFocus")]
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@2046:             if path' = path then
adam@2046:                 ()
adam@2046:             else
adam@2046:                 ErrorMsg.error ("Two different files requested for URI " ^ Uri)
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