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
|