Mercurial > urweb

annotate src/settings.sml @ 925:552c989c1601

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Change string URLification to avoid using the empty string, which confuses Apache no2slash()
author Adam Chlipala <adamc@hcoop.net>
date Sat, 12 Sep 2009 09:31:50 -0400
parents 771449d8b411
children 16f7cb0891b6
rev   line source
adamc@764 1 (* Copyright (c) 2008-2009, Adam Chlipala
adamc@764 2 * All rights reserved.
adamc@764 3 *
adamc@764 4 * Redistribution and use in source and binary forms, with or without
adamc@764 5 * modification, are permitted provided that the following conditions are met:
adamc@764 6 *
adamc@764 7 * - Redistributions of source code must retain the above copyright notice,
adamc@764 8 * this list of conditions and the following disclaimer.
adamc@764 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@764 10 * this list of conditions and the following disclaimer in the documentation
adamc@764 11 * and/or other materials provided with the distribution.
adamc@764 12 * - The names of contributors may not be used to endorse or promote products
adamc@764 13 * derived from this software without specific prior written permission.
adamc@764 14 *
adamc@764 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@764 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@764 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@764 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@764 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@764 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@764 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@764 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@764 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@764 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@764 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@764 26 *)
adamc@764 27
adamc@764 28 structure Settings :> SETTINGS = struct
adamc@764 29
adamc@764 30 val urlPrefix = ref "/"
adamc@764 31 val timeout = ref 0
adamc@764 32 val headers = ref ([] : string list)
adamc@766 33 val scripts = ref ([] : string list)
adamc@764 34
adamc@764 35 fun getUrlPrefix () = !urlPrefix
adamc@764 36 fun setUrlPrefix p =
adamc@764 37 urlPrefix := (if p = "" then
adamc@764 38 "/"
adamc@764 39 else if String.sub (p, size p - 1) <> #"/" then
adamc@764 40 p ^ "/"
adamc@764 41 else
adamc@764 42 p)
adamc@764 43
adamc@764 44 fun getTimeout () = !timeout
adamc@764 45 fun setTimeout n = timeout := n
adamc@764 46
adamc@764 47 fun getHeaders () = !headers
adamc@764 48 fun setHeaders ls = headers := ls
adamc@764 49
adamc@766 50 fun getScripts () = !scripts
adamc@766 51 fun setScripts ls = scripts := ls
adamc@766 52
adamc@765 53 type ffi = string * string
adamc@765 54
adamc@765 55 structure K = struct
adamc@765 56 type ord_key = ffi
adamc@765 57 fun compare ((m1, x1), (m2, x2)) =
adamc@765 58 Order.join (String.compare (m1, m2),
adamc@765 59 fn () => String.compare (x1, x2))
adamc@764 60 end
adamc@765 61
adamc@765 62 structure S = BinarySetFn(K)
adamc@765 63 structure M = BinaryMapFn(K)
adamc@765 64
adamc@765 65 fun basis x = S.addList (S.empty, map (fn x : string => ("Basis", x)) x)
adamc@765 66
adamc@765 67 val clientToServerBase = basis ["int",
adamc@765 68 "float",
adamc@765 69 "string",
adamc@765 70 "time",
adamc@765 71 "file",
adamc@765 72 "unit",
adamc@765 73 "option",
adamc@765 74 "list",
adamc@765 75 "bool"]
adamc@765 76 val clientToServer = ref clientToServerBase
adamc@765 77 fun setClientToServer ls = clientToServer := S.addList (clientToServerBase, ls)
adamc@765 78 fun mayClientToServer x = S.member (!clientToServer, x)
adamc@765 79
adamc@779 80 val effectfulBase = basis ["dml",
adamc@779 81 "nextval",
adamc@779 82 "set_cookie",
adamc@765 83 "new_client_source",
adamc@765 84 "get_client_source",
adamc@765 85 "set_client_source",
adamc@845 86 "current",
adamc@765 87 "alert",
adamc@765 88 "new_channel",
adamc@765 89 "send",
adamc@765 90 "onError",
adamc@765 91 "onFail",
adamc@765 92 "onConnectFail",
adamc@765 93 "onDisconnect",
adamc@895 94 "onServerError",
adamc@895 95 "kc"]
adamc@765 96
adamc@765 97 val effectful = ref effectfulBase
adamc@765 98 fun setEffectful ls = effectful := S.addList (effectfulBase, ls)
adamc@765 99 fun isEffectful x = S.member (!effectful, x)
adamc@765 100
adamc@765 101 val clientBase = basis ["get",
adamc@765 102 "set",
adamc@841 103 "current",
adamc@765 104 "alert",
adamc@765 105 "recv",
adamc@765 106 "sleep",
adamc@765 107 "spawn",
adamc@765 108 "onError",
adamc@765 109 "onFail",
adamc@765 110 "onConnectFail",
adamc@765 111 "onDisconnect",
adamc@895 112 "onServerError",
adamc@895 113 "kc"]
adamc@765 114 val client = ref clientBase
adamc@765 115 fun setClientOnly ls = client := S.addList (clientBase, ls)
adamc@765 116 fun isClientOnly x = S.member (!client, x)
adamc@765 117
adamc@765 118 val serverBase = basis ["requestHeader",
adamc@765 119 "query",
adamc@765 120 "dml",
adamc@765 121 "nextval",
adamc@765 122 "channel",
adamc@765 123 "send"]
adamc@765 124 val server = ref serverBase
adamc@765 125 fun setServerOnly ls = server := S.addList (serverBase, ls)
adamc@765 126 fun isServerOnly x = S.member (!server, x)
adamc@765 127
adamc@765 128 val basisM = foldl (fn ((k, v : string), m) => M.insert (m, ("Basis", k), v)) M.empty
adamc@765 129
adamc@765 130 val jsFuncsBase = basisM [("alert", "alert"),
adamc@765 131 ("get_client_source", "sg"),
adamc@841 132 ("current", "scur"),
adamc@765 133 ("htmlifyBool", "bs"),
adamc@765 134 ("htmlifyFloat", "ts"),
adamc@765 135 ("htmlifyInt", "ts"),
adamc@765 136 ("htmlifyString", "eh"),
adamc@765 137 ("new_client_source", "sc"),
adamc@765 138 ("set_client_source", "sv"),
adamc@838 139 ("stringToFloat", "pflo"),
adamc@838 140 ("stringToInt", "pio"),
adamc@765 141 ("stringToFloat_error", "pfl"),
adamc@765 142 ("stringToInt_error", "pi"),
adamc@765 143 ("urlifyInt", "ts"),
adamc@765 144 ("urlifyFloat", "ts"),
adamc@765 145 ("urlifyString", "uf"),
adamc@912 146 ("urlifyBool", "ub"),
adamc@765 147 ("recv", "rv"),
adamc@765 148 ("strcat", "cat"),
adamc@765 149 ("intToString", "ts"),
adamc@765 150 ("floatToString", "ts"),
adamc@821 151 ("charToString", "ts"),
adamc@765 152 ("onError", "onError"),
adamc@765 153 ("onFail", "onFail"),
adamc@765 154 ("onConnectFail", "onConnectFail"),
adamc@765 155 ("onDisconnect", "onDisconnect"),
adamc@798 156 ("onServerError", "onServerError"),
adamc@798 157 ("attrifyString", "escape"),
adamc@798 158 ("attrifyInt", "ts"),
adamc@798 159 ("attrifyFloat", "ts"),
adamc@820 160 ("attrifyBool", "bs"),
adamc@821 161 ("boolToString", "ts"),
adamc@821 162 ("strsub", "sub"),
adamc@828 163 ("strsuffix", "suf"),
adamc@829 164 ("strlen", "slen"),
adamc@829 165 ("strindex", "sidx"),
adamc@829 166 ("strchr", "schr"),
adamc@831 167 ("substring", "ssub"),
adamc@895 168 ("strcspn", "sspn"),
adamc@895 169 ("kc", "kc")]
adamc@765 170 val jsFuncs = ref jsFuncsBase
adamc@765 171 fun setJsFuncs ls = jsFuncs := foldl (fn ((k, v), m) => M.insert (m, k, v)) jsFuncsBase ls
adamc@765 172 fun jsFunc x = M.find (!jsFuncs, x)
adamc@765 173
adamc@768 174 datatype pattern_kind = Exact | Prefix
adamc@768 175 datatype action = Allow | Deny
adamc@768 176 type rule = { action : action, kind : pattern_kind, pattern : string }
adamc@768 177
adamc@768 178 datatype path_kind = Any | Url | Table | Sequence | View | Relation | Cookie | Style
adamc@768 179 type rewrite = { pkind : path_kind, kind : pattern_kind, from : string, to : string }
adamc@768 180
adamc@768 181 val rewrites = ref ([] : rewrite list)
adamc@768 182
adamc@768 183 fun subsume (pk1, pk2) =
adamc@768 184 pk1 = pk2
adamc@768 185 orelse pk2 = Any
adamc@768 186 orelse pk2 = Relation andalso (pk1 = Table orelse pk1 = Sequence orelse pk1 = View)
adamc@768 187
adamc@768 188 fun setRewriteRules ls = rewrites := ls
adamc@768 189 fun rewrite pk s =
adamc@768 190 let
adamc@768 191 fun rew (ls : rewrite list) =
adamc@768 192 case ls of
adamc@768 193 [] => s
adamc@768 194 | rewr :: ls =>
adamc@768 195 let
adamc@768 196 fun match () =
adamc@768 197 case #kind rewr of
adamc@768 198 Exact => if #from rewr = s then
adamc@768 199 SOME (size s)
adamc@768 200 else
adamc@768 201 NONE
adamc@768 202 | Prefix => if String.isPrefix (#from rewr) s then
adamc@768 203 SOME (size (#from rewr))
adamc@768 204 else
adamc@768 205 NONE
adamc@768 206 in
adamc@768 207 if subsume (pk, #pkind rewr) then
adamc@768 208 case match () of
adamc@768 209 NONE => rew ls
adamc@768 210 | SOME suffixStart => #to rewr ^ String.extract (s, suffixStart, NONE)
adamc@768 211 else
adamc@768 212 rew ls
adamc@768 213 end
adamc@768 214 in
adamc@768 215 rew (!rewrites)
adamc@768 216 end
adamc@768 217
adamc@769 218 val url = ref ([] : rule list)
adamc@769 219 val mime = ref ([] : rule list)
adamc@769 220
adamc@769 221 fun setUrlRules ls = url := ls
adamc@769 222 fun setMimeRules ls = mime := ls
adamc@769 223
adamc@770 224 fun getUrlRules () = !url
adamc@770 225 fun getMimeRules () = !mime
adamc@770 226
adamc@769 227 fun check f rules s =
adamc@769 228 let
adamc@769 229 fun chk (ls : rule list) =
adamc@769 230 case ls of
adamc@769 231 [] => false
adamc@769 232 | rule :: ls =>
adamc@769 233 let
adamc@769 234 val matches =
adamc@769 235 case #kind rule of
adamc@769 236 Exact => #pattern rule = s
adamc@769 237 | Prefix => String.isPrefix (#pattern rule) s
adamc@769 238 in
adamc@769 239 if matches then
adamc@769 240 case #action rule of
adamc@769 241 Allow => true
adamc@769 242 | Deny => false
adamc@769 243 else
adamc@769 244 chk ls
adamc@769 245 end
adamc@769 246 in
adamc@769 247 f s andalso chk (!rules)
adamc@769 248 end
adamc@769 249
adamc@769 250 val checkUrl = check (fn _ => true) url
adamc@769 251 val checkMime = check
adamc@769 252 (CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"/" orelse ch = #"-" orelse ch = #"."))
adamc@769 253 mime
adamc@769 254
adamc@855 255
adamc@855 256 type protocol = {
adamc@855 257 name : string,
adamc@855 258 link : string,
adamc@858 259 persistent : bool
adamc@855 260 }
adamc@855 261 val protocols = ref ([] : protocol list)
adamc@855 262 fun addProtocol p = protocols := p :: !protocols
adamc@855 263 fun getProtocol s = List.find (fn p => #name p = s) (!protocols)
adamc@855 264
adamc@855 265 fun clibFile s = OS.Path.joinDirFile {dir = Config.libC,
adamc@855 266 file = s}
adamc@855 267
adamc@865 268 val curProto = ref {name = "",
adamc@865 269 link = "",
adamc@865 270 persistent = false}
adamc@856 271 fun setProtocol name =
adamc@856 272 case getProtocol name of
adamc@856 273 NONE => raise Fail ("Unknown protocol " ^ name)
adamc@856 274 | SOME p => curProto := p
adamc@855 275 fun currentProtocol () = !curProto
adamc@855 276
adamc@857 277 val debug = ref false
adamc@857 278 fun setDebug b = debug := b
adamc@857 279 fun getDebug () = !debug
adamc@857 280
adamc@867 281 datatype sql_type =
adamc@867 282 Int
adamc@867 283 | Float
adamc@867 284 | String
adamc@867 285 | Bool
adamc@867 286 | Time
adamc@867 287 | Blob
adamc@867 288 | Channel
adamc@867 289 | Client
adamc@867 290 | Nullable of sql_type
adamc@867 291
adamc@873 292 fun p_sql_ctype t =
adamc@867 293 let
adamc@867 294 open Print.PD
adamc@867 295 open Print
adamc@867 296 in
adamc@867 297 case t of
adamc@870 298 Int => "uw_Basis_int"
adamc@870 299 | Float => "uw_Basis_float"
adamc@870 300 | String => "uw_Basis_string"
adamc@870 301 | Bool => "uw_Basis_bool"
adamc@870 302 | Time => "uw_Basis_time"
adamc@870 303 | Blob => "uw_Basis_blob"
adamc@870 304 | Channel => "uw_Basis_channel"
adamc@870 305 | Client => "uw_Basis_client"
adamc@870 306 | Nullable String => "uw_Basis_string"
adamc@873 307 | Nullable t => p_sql_ctype t ^ "*"
adamc@867 308 end
adamc@867 309
adamc@867 310 fun isBlob Blob = true
adamc@867 311 | isBlob (Nullable t) = isBlob t
adamc@867 312 | isBlob _ = false
adamc@867 313
adamc@870 314 fun isNotNull (Nullable _) = false
adamc@870 315 | isNotNull _ = true
adamc@870 316
adamc@866 317 type dbms = {
adamc@866 318 name : string,
adamc@866 319 header : string,
adamc@866 320 link : string,
adamc@873 321 p_sql_type : sql_type -> string,
adamc@870 322 init : {dbstring : string,
adamc@870 323 prepared : (string * int) list,
adamc@870 324 tables : (string * (string * sql_type) list) list,
adamc@872 325 views : (string * (string * sql_type) list) list,
adamc@870 326 sequences : string list} -> Print.PD.pp_desc,
adamc@873 327 query : {loc : ErrorMsg.span, cols : sql_type list,
adamc@880 328 doCols : ({loc : ErrorMsg.span, wontLeakStrings : bool, col : int, typ : sql_type} -> Print.PD.pp_desc)
adamc@867 329 -> Print.PD.pp_desc}
adamc@867 330 -> Print.PD.pp_desc,
adamc@867 331 queryPrepared : {loc : ErrorMsg.span, id : int, query : string,
adamc@873 332 inputs : sql_type list, cols : sql_type list,
adamc@880 333 doCols : ({loc : ErrorMsg.span, wontLeakStrings : bool, col : int,
adamc@880 334 typ : sql_type} -> Print.PD.pp_desc)
adamc@879 335 -> Print.PD.pp_desc,
adamc@879 336 nested : bool}
adamc@868 337 -> Print.PD.pp_desc,
adamc@868 338 dml : ErrorMsg.span -> Print.PD.pp_desc,
adamc@868 339 dmlPrepared : {loc : ErrorMsg.span, id : int, dml : string,
adamc@869 340 inputs : sql_type list} -> Print.PD.pp_desc,
adamc@878 341 nextval : {loc : ErrorMsg.span, seqName : string option, seqE : Print.PD.pp_desc} -> Print.PD.pp_desc,
adamc@874 342 nextvalPrepared : {loc : ErrorMsg.span, id : int, query : string} -> Print.PD.pp_desc,
adamc@874 343 sqlifyString : string -> string,
adamc@874 344 p_cast : string * sql_type -> string,
adamc@874 345 p_blank : int * sql_type -> string,
adamc@877 346 supportsDeleteAs : bool,
adamc@886 347 supportsUpdateAs : bool,
adamc@877 348 createSequence : string -> string,
adamc@878 349 textKeysNeedLengths : bool,
adamc@879 350 supportsNextval : bool,
adamc@882 351 supportsNestedPrepared : bool,
adamc@890 352 sqlPrefix : string,
adamc@890 353 supportsOctetLength : bool
adamc@866 354 }
adamc@866 355
adamc@866 356 val dbmses = ref ([] : dbms list)
adamc@866 357 val curDb = ref ({name = "",
adamc@866 358 header = "",
adamc@866 359 link = "",
adamc@873 360 p_sql_type = fn _ => "",
adamc@867 361 init = fn _ => Print.box [],
adamc@867 362 query = fn _ => Print.box [],
adamc@868 363 queryPrepared = fn _ => Print.box [],
adamc@868 364 dml = fn _ => Print.box [],
adamc@869 365 dmlPrepared = fn _ => Print.box [],
adamc@869 366 nextval = fn _ => Print.box [],
adamc@874 367 nextvalPrepared = fn _ => Print.box [],
adamc@874 368 sqlifyString = fn s => s,
adamc@874 369 p_cast = fn _ => "",
adamc@874 370 p_blank = fn _ => "",
adamc@877 371 supportsDeleteAs = false,
adamc@886 372 supportsUpdateAs = false,
adamc@877 373 createSequence = fn _ => "",
adamc@878 374 textKeysNeedLengths = false,
adamc@879 375 supportsNextval = false,
adamc@882 376 supportsNestedPrepared = false,
adamc@890 377 sqlPrefix = "",
adamc@890 378 supportsOctetLength = false} : dbms)
adamc@866 379
adamc@866 380 fun addDbms v = dbmses := v :: !dbmses
adamc@866 381 fun setDbms s =
adamc@866 382 case List.find (fn db => #name db = s) (!dbmses) of
adamc@866 383 NONE => raise Fail ("Unknown DBMS " ^ s)
adamc@866 384 | SOME db => curDb := db
adamc@866 385 fun currentDbms () = !curDb
adamc@866 386
adamc@891 387 val dbstring = ref (NONE : string option)
adamc@891 388 fun setDbstring so = dbstring := so
adamc@891 389 fun getDbstring () = !dbstring
adamc@891 390
adamc@891 391 val exe = ref (NONE : string option)
adamc@891 392 fun setExe so = exe := so
adamc@891 393 fun getExe () = !exe
adamc@891 394
adamc@891 395 val sql = ref (NONE : string option)
adamc@891 396 fun setSql so = sql := so
adamc@891 397 fun getSql () = !sql
adamc@891 398
adamc@765 399 end