adam@1478
|
1 (* Copyright (c) 2008-2011, 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
|
rmbruijn@1597
|
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
|
ezyang@1739
|
30 val configBin = ref Config.bin
|
ezyang@1739
|
31 val configLib = ref Config.lib
|
ezyang@1739
|
32 val configSrcLib = ref Config.srclib
|
ezyang@1739
|
33 val configInclude = ref Config.includ
|
ezyang@1739
|
34 val configSitelisp = ref Config.sitelisp
|
ezyang@1739
|
35
|
grrwlf@1871
|
36 val configCCompiler = ref Config.ccompiler
|
grrwlf@1871
|
37
|
grrwlf@1871
|
38 fun getCCompiler () = !configCCompiler
|
grrwlf@1871
|
39 fun setCCompiler cc = configCCompiler := cc
|
grrwlf@1871
|
40
|
ezyang@1739
|
41 fun libUr () = OS.Path.joinDirFile {dir = !configSrcLib,
|
ezyang@1739
|
42 file = "ur"}
|
ezyang@1739
|
43 fun libC () = OS.Path.joinDirFile {dir = !configSrcLib,
|
ezyang@1739
|
44 file = "c"}
|
ezyang@1739
|
45 fun libJs () = OS.Path.joinDirFile {dir = !configSrcLib,
|
ezyang@1739
|
46 file = "js"}
|
ezyang@1739
|
47
|
ezyang@1739
|
48 fun libFile s = OS.Path.joinDirFile {dir = libUr (),
|
ezyang@1739
|
49 file = s}
|
ezyang@1739
|
50
|
adam@1637
|
51 val urlPrefixFull = ref "/"
|
adamc@764
|
52 val urlPrefix = ref "/"
|
adam@1370
|
53 val urlPrePrefix = ref ""
|
adamc@764
|
54 val timeout = ref 0
|
adamc@764
|
55 val headers = ref ([] : string list)
|
adamc@766
|
56 val scripts = ref ([] : string list)
|
adamc@764
|
57
|
adam@1637
|
58 fun getUrlPrefixFull () = !urlPrefixFull
|
adamc@764
|
59 fun getUrlPrefix () = !urlPrefix
|
adam@1370
|
60 fun getUrlPrePrefix () = !urlPrePrefix
|
adamc@764
|
61 fun setUrlPrefix p =
|
adam@1370
|
62 let
|
adam@1370
|
63 val prefix = if p = "" then
|
adam@1370
|
64 "/"
|
adam@1370
|
65 else if String.sub (p, size p - 1) <> #"/" then
|
adam@1370
|
66 p ^ "/"
|
adam@1370
|
67 else
|
adam@1370
|
68 p
|
adam@1370
|
69
|
adam@1470
|
70 fun findPrefix n =
|
adam@1470
|
71 let
|
adam@1470
|
72 val (befor, after) = Substring.splitl (fn ch => ch <> #"/") (Substring.extract (prefix, n, NONE))
|
adam@1470
|
73 in
|
adam@1470
|
74 if Substring.isEmpty after then
|
adam@1470
|
75 ("", prefix)
|
adam@1470
|
76 else
|
adam@1470
|
77 (String.substring (prefix, 0, n) ^ Substring.string befor, Substring.string after)
|
rmbruijn@1597
|
78 end
|
adam@1470
|
79
|
adam@1370
|
80 val (prepre, prefix) =
|
adam@1370
|
81 if String.isPrefix "http://" prefix then
|
adam@1470
|
82 findPrefix 7
|
adam@1470
|
83 else if String.isPrefix "https://" prefix then
|
adam@1470
|
84 findPrefix 8
|
adam@1370
|
85 else
|
adam@1370
|
86 ("", prefix)
|
adam@1370
|
87 in
|
adam@1637
|
88 urlPrefixFull := p;
|
adam@1370
|
89 urlPrePrefix := prepre;
|
adam@1370
|
90 urlPrefix := prefix
|
adam@1370
|
91 end
|
adamc@764
|
92
|
adamc@764
|
93 fun getTimeout () = !timeout
|
adamc@764
|
94 fun setTimeout n = timeout := n
|
adamc@764
|
95
|
adamc@764
|
96 fun getHeaders () = !headers
|
adamc@764
|
97 fun setHeaders ls = headers := ls
|
adamc@764
|
98
|
adamc@766
|
99 fun getScripts () = !scripts
|
adamc@766
|
100 fun setScripts ls = scripts := ls
|
adamc@766
|
101
|
adamc@765
|
102 type ffi = string * string
|
adamc@765
|
103
|
adamc@765
|
104 structure K = struct
|
adamc@765
|
105 type ord_key = ffi
|
adamc@765
|
106 fun compare ((m1, x1), (m2, x2)) =
|
adamc@765
|
107 Order.join (String.compare (m1, m2),
|
adamc@765
|
108 fn () => String.compare (x1, x2))
|
adamc@764
|
109 end
|
adamc@765
|
110
|
adamc@765
|
111 structure S = BinarySetFn(K)
|
adamc@765
|
112 structure M = BinaryMapFn(K)
|
adamc@765
|
113
|
adamc@765
|
114 fun basis x = S.addList (S.empty, map (fn x : string => ("Basis", x)) x)
|
adamc@765
|
115
|
adamc@765
|
116 val clientToServerBase = basis ["int",
|
adamc@765
|
117 "float",
|
adamc@765
|
118 "string",
|
adamc@765
|
119 "time",
|
adamc@765
|
120 "file",
|
adamc@765
|
121 "unit",
|
adamc@765
|
122 "option",
|
adamc@765
|
123 "list",
|
adam@1288
|
124 "bool",
|
adam@1288
|
125 "variant"]
|
adamc@765
|
126 val clientToServer = ref clientToServerBase
|
adamc@765
|
127 fun setClientToServer ls = clientToServer := S.addList (clientToServerBase, ls)
|
adamc@765
|
128 fun mayClientToServer x = S.member (!clientToServer, x)
|
adamc@765
|
129
|
adamc@779
|
130 val effectfulBase = basis ["dml",
|
adamc@779
|
131 "nextval",
|
adamc@1073
|
132 "setval",
|
adamc@779
|
133 "set_cookie",
|
adamc@1050
|
134 "clear_cookie",
|
adamc@765
|
135 "new_channel",
|
adamc@1200
|
136 "send",
|
adamc@1200
|
137 "htmlifyInt_w",
|
adamc@1200
|
138 "htmlifyFloat_w",
|
adamc@1200
|
139 "htmlifyString_w",
|
adamc@1200
|
140 "htmlifyBool_w",
|
adamc@1200
|
141 "htmlifyTime_w",
|
adamc@1200
|
142 "attrifyInt_w",
|
adamc@1200
|
143 "attrifyFloat_w",
|
adamc@1200
|
144 "attrifyString_w",
|
adamc@1200
|
145 "attrifyChar_w",
|
adamc@1200
|
146 "urlifyInt_w",
|
adamc@1200
|
147 "urlifyFloat_w",
|
adamc@1200
|
148 "urlifyString_w",
|
adamc@1200
|
149 "urlifyBool_w",
|
adamc@1200
|
150 "urlifyChannel_w"]
|
adamc@765
|
151
|
adamc@765
|
152 val effectful = ref effectfulBase
|
adamc@765
|
153 fun setEffectful ls = effectful := S.addList (effectfulBase, ls)
|
adamc@765
|
154 fun isEffectful x = S.member (!effectful, x)
|
adam@1878
|
155 fun addEffectful x = effectful := S.add (!effectful, x)
|
adamc@765
|
156
|
adamc@1171
|
157 val benignBase = basis ["get_cookie",
|
adamc@1171
|
158 "new_client_source",
|
adamc@1171
|
159 "get_client_source",
|
adamc@1171
|
160 "set_client_source",
|
adamc@1171
|
161 "current",
|
adamc@1171
|
162 "alert",
|
adam@1290
|
163 "confirm",
|
adamc@1171
|
164 "onError",
|
adamc@1171
|
165 "onFail",
|
adamc@1171
|
166 "onConnectFail",
|
adamc@1171
|
167 "onDisconnect",
|
adamc@1171
|
168 "onServerError",
|
adam@1783
|
169 "mouseEvent",
|
adam@1783
|
170 "keyEvent",
|
adamc@1250
|
171 "debug",
|
adam@1422
|
172 "rand",
|
adam@1465
|
173 "now",
|
adam@1465
|
174 "getHeader",
|
adam@1555
|
175 "setHeader",
|
adam@1555
|
176 "spawn",
|
adam@1555
|
177 "onClick",
|
adam@1555
|
178 "onDblclick",
|
adam@1555
|
179 "onKeydown",
|
adam@1555
|
180 "onKeypress",
|
adam@1555
|
181 "onKeyup",
|
adam@1555
|
182 "onMousedown",
|
adam@1791
|
183 "onMousemove",
|
adam@1791
|
184 "onMouseout",
|
adam@1791
|
185 "onMouseover",
|
adam@1556
|
186 "onMouseup",
|
adam@1559
|
187 "preventDefault",
|
adam@1559
|
188 "stopPropagation",
|
adam@1785
|
189 "fresh",
|
adam@1952
|
190 "giveFocus",
|
adam@1952
|
191 "currentUrlHasPost",
|
adam@1952
|
192 "currentUrlHasQueryString",
|
adam@1952
|
193 "currentUrl"]
|
adamc@1171
|
194
|
adamc@1171
|
195 val benign = ref benignBase
|
adamc@1171
|
196 fun setBenignEffectful ls = benign := S.addList (benignBase, ls)
|
adam@2010
|
197 fun addBenignEffectful x = benign := S.add (!benign, x)
|
adamc@1171
|
198 fun isBenignEffectful x = S.member (!benign, x)
|
adamc@1171
|
199
|
adam@1595
|
200 val clientBase = basis ["get_client_source",
|
adamc@841
|
201 "current",
|
adamc@765
|
202 "alert",
|
adam@1290
|
203 "confirm",
|
adamc@765
|
204 "recv",
|
adamc@765
|
205 "sleep",
|
adamc@765
|
206 "spawn",
|
adamc@765
|
207 "onError",
|
adamc@765
|
208 "onFail",
|
adamc@765
|
209 "onConnectFail",
|
adamc@765
|
210 "onDisconnect",
|
adamc@895
|
211 "onServerError",
|
adam@1783
|
212 "mouseEvent",
|
adam@1783
|
213 "keyEvent",
|
adam@1555
|
214 "onClick",
|
adam@1555
|
215 "onDblclick",
|
adam@1555
|
216 "onKeydown",
|
adam@1555
|
217 "onKeypress",
|
adam@1555
|
218 "onKeyup",
|
adam@1555
|
219 "onMousedown",
|
adam@1791
|
220 "onMousemove",
|
adam@1791
|
221 "onMouseout",
|
adam@1791
|
222 "onMouseover",
|
adam@1559
|
223 "onMouseup",
|
adam@1559
|
224 "preventDefault",
|
adam@1785
|
225 "stopPropagation",
|
adam@1785
|
226 "giveFocus"]
|
adamc@765
|
227 val client = ref clientBase
|
adamc@765
|
228 fun setClientOnly ls = client := S.addList (clientBase, ls)
|
adam@2010
|
229 fun addClientOnly x = client := S.add (!client, x)
|
adamc@765
|
230 fun isClientOnly x = S.member (!client, x)
|
adamc@765
|
231
|
adamc@765
|
232 val serverBase = basis ["requestHeader",
|
adamc@765
|
233 "query",
|
adamc@765
|
234 "dml",
|
adamc@765
|
235 "nextval",
|
adamc@1073
|
236 "setval",
|
adamc@765
|
237 "channel",
|
adam@1787
|
238 "send",
|
adam@1787
|
239 "fieldName",
|
adam@1787
|
240 "fieldValue",
|
adam@1787
|
241 "remainingFields",
|
adam@1787
|
242 "firstFormField"]
|
adamc@765
|
243 val server = ref serverBase
|
adamc@765
|
244 fun setServerOnly ls = server := S.addList (serverBase, ls)
|
adam@2010
|
245 fun addServerOnly x = server := S.add (!server, x)
|
adamc@765
|
246 fun isServerOnly x = S.member (!server, x)
|
adamc@765
|
247
|
adamc@765
|
248 val basisM = foldl (fn ((k, v : string), m) => M.insert (m, ("Basis", k), v)) M.empty
|
adamc@765
|
249
|
adamc@765
|
250 val jsFuncsBase = basisM [("alert", "alert"),
|
adam@1599
|
251 ("stringToTime", "stringToTime"),
|
adam@1599
|
252 ("stringToTime_error", "stringToTime_error"),
|
adam@1609
|
253 ("timef", "strftime"),
|
adam@1290
|
254 ("confirm", "confrm"),
|
adamc@765
|
255 ("get_client_source", "sg"),
|
adamc@841
|
256 ("current", "scur"),
|
adamc@765
|
257 ("htmlifyBool", "bs"),
|
adamc@765
|
258 ("htmlifyFloat", "ts"),
|
adamc@765
|
259 ("htmlifyInt", "ts"),
|
adamc@765
|
260 ("htmlifyString", "eh"),
|
adamc@765
|
261 ("new_client_source", "sc"),
|
adamc@765
|
262 ("set_client_source", "sv"),
|
adamc@838
|
263 ("stringToFloat", "pflo"),
|
adamc@838
|
264 ("stringToInt", "pio"),
|
adamc@765
|
265 ("stringToFloat_error", "pfl"),
|
adamc@765
|
266 ("stringToInt_error", "pi"),
|
adamc@765
|
267 ("urlifyInt", "ts"),
|
adamc@765
|
268 ("urlifyFloat", "ts"),
|
adam@1360
|
269 ("urlifyTime", "ts"),
|
adamc@765
|
270 ("urlifyString", "uf"),
|
adamc@912
|
271 ("urlifyBool", "ub"),
|
adamc@765
|
272 ("recv", "rv"),
|
adamc@765
|
273 ("strcat", "cat"),
|
adamc@765
|
274 ("intToString", "ts"),
|
adamc@765
|
275 ("floatToString", "ts"),
|
adamc@821
|
276 ("charToString", "ts"),
|
adamc@765
|
277 ("onError", "onError"),
|
adamc@765
|
278 ("onFail", "onFail"),
|
adamc@765
|
279 ("onConnectFail", "onConnectFail"),
|
adamc@765
|
280 ("onDisconnect", "onDisconnect"),
|
adamc@798
|
281 ("onServerError", "onServerError"),
|
adamc@1108
|
282 ("attrifyString", "atr"),
|
adamc@798
|
283 ("attrifyInt", "ts"),
|
adamc@798
|
284 ("attrifyFloat", "ts"),
|
adamc@820
|
285 ("attrifyBool", "bs"),
|
adamc@821
|
286 ("boolToString", "ts"),
|
adamc@1057
|
287 ("str1", "id"),
|
adamc@821
|
288 ("strsub", "sub"),
|
adamc@828
|
289 ("strsuffix", "suf"),
|
adamc@829
|
290 ("strlen", "slen"),
|
adamc@829
|
291 ("strindex", "sidx"),
|
dukhovni@2045
|
292 ("strsindex", "ssidx"),
|
adamc@829
|
293 ("strchr", "schr"),
|
adamc@831
|
294 ("substring", "ssub"),
|
adamc@895
|
295 ("strcspn", "sspn"),
|
adam@1624
|
296 ("strlenGe", "strlenGe"),
|
adam@1783
|
297 ("mouseEvent", "uw_mouseEvent"),
|
adam@1783
|
298 ("keyEvent", "uw_keyEvent"),
|
adam@1404
|
299 ("minTime", "0"),
|
adamc@1061
|
300
|
adamc@1061
|
301 ("islower", "isLower"),
|
adamc@1061
|
302 ("isupper", "isUpper"),
|
adamc@1061
|
303 ("isalpha", "isAlpha"),
|
adamc@1061
|
304 ("isdigit", "isDigit"),
|
adamc@1061
|
305 ("isalnum", "isAlnum"),
|
adamc@1061
|
306 ("isblank", "isBlank"),
|
adamc@1061
|
307 ("isspace", "isSpace"),
|
adamc@1061
|
308 ("isxdigit", "isXdigit"),
|
adam@1927
|
309 ("isprint", "isPrint"),
|
adamc@1061
|
310 ("tolower", "toLower"),
|
adamc@1323
|
311 ("toupper", "toUpper"),
|
adam@1927
|
312 ("ord", "ord"),
|
adamc@1323
|
313
|
adamc@1323
|
314 ("checkUrl", "checkUrl"),
|
adam@1366
|
315 ("bless", "bless"),
|
adam@2008
|
316 ("blessData", "blessData"),
|
adam@1366
|
317
|
adam@1366
|
318 ("eq_time", "eq"),
|
adam@1366
|
319 ("lt_time", "lt"),
|
adam@1430
|
320 ("le_time", "le"),
|
adam@1430
|
321
|
adam@1625
|
322 ("debug", "uw_debug"),
|
adam@1625
|
323 ("naughtyDebug", "uw_debug"),
|
adam@1487
|
324
|
adam@1571
|
325 ("floatFromInt", "float"),
|
adam@1571
|
326 ("ceil", "ceil"),
|
adam@1571
|
327 ("trunc", "trunc"),
|
adam@1571
|
328 ("round", "round"),
|
adam@1571
|
329
|
adam@1487
|
330 ("now", "now"),
|
adam@1487
|
331 ("timeToString", "showTime"),
|
adam@1629
|
332 ("htmlifyTime", "showTimeHtml"),
|
adam@1514
|
333 ("toSeconds", "toSeconds"),
|
adam@1518
|
334 ("addSeconds", "addSeconds"),
|
adam@1555
|
335 ("diffInSeconds", "diffInSeconds"),
|
adam@1685
|
336 ("toMilliseconds", "toMilliseconds"),
|
adam@1685
|
337 ("diffInMilliseconds", "diffInMilliseconds"),
|
adam@1555
|
338
|
phurst@1986
|
339 ("fromDatetime", "fromDatetime"),
|
phurst@1986
|
340 ("datetimeYear", "datetimeYear"),
|
phurst@1986
|
341 ("datetimeMonth", "datetimeMonth"),
|
phurst@1986
|
342 ("datetimeDay", "datetimeDay"),
|
phurst@1986
|
343 ("datetimeHour", "datetimeHour"),
|
phurst@1986
|
344 ("datetimeMinute", "datetimeMinute"),
|
phurst@1986
|
345 ("datetimeSecond", "datetimeSecond"),
|
phurst@1986
|
346 ("datetimeDayOfWeek", "datetimeDayOfWeek"),
|
phurst@1986
|
347
|
phurst@1986
|
348
|
adam@1555
|
349 ("onClick", "uw_onClick"),
|
adam@1555
|
350 ("onDblclick", "uw_onDblclick"),
|
adam@1555
|
351 ("onKeydown", "uw_onKeydown"),
|
adam@1555
|
352 ("onKeypress", "uw_onKeypress"),
|
adam@1555
|
353 ("onKeyup", "uw_onKeyup"),
|
adam@1555
|
354 ("onMousedown", "uw_onMousedown"),
|
adam@1791
|
355 ("onMousemove", "uw_onMousemove"),
|
adam@1791
|
356 ("onMouseout", "uw_onMouseout"),
|
adam@1791
|
357 ("onMouseover", "uw_onMouseover"),
|
adam@1556
|
358 ("onMouseup", "uw_onMouseup"),
|
adam@1559
|
359 ("preventDefault", "uw_preventDefault"),
|
adam@1559
|
360 ("stopPropagation", "uw_stopPropagation"),
|
adam@1556
|
361
|
adam@1755
|
362 ("fresh", "fresh"),
|
adam@1755
|
363
|
adam@1755
|
364 ("atom", "atom"),
|
adam@1755
|
365 ("css_url", "css_url"),
|
adam@1785
|
366 ("property", "property"),
|
adam@1785
|
367 ("giveFocus", "giveFocus")]
|
adamc@765
|
368 val jsFuncs = ref jsFuncsBase
|
adamc@765
|
369 fun setJsFuncs ls = jsFuncs := foldl (fn ((k, v), m) => M.insert (m, k, v)) jsFuncsBase ls
|
adamc@765
|
370 fun jsFunc x = M.find (!jsFuncs, x)
|
adam@2010
|
371 fun addJsFunc (k, v) = jsFuncs := M.insert (!jsFuncs, k, v)
|
adam@1433
|
372 fun allJsFuncs () = M.listItemsi (!jsFuncs)
|
adamc@765
|
373
|
adamc@768
|
374 datatype pattern_kind = Exact | Prefix
|
adamc@768
|
375 datatype action = Allow | Deny
|
adamc@768
|
376 type rule = { action : action, kind : pattern_kind, pattern : string }
|
adamc@768
|
377
|
adamc@768
|
378 datatype path_kind = Any | Url | Table | Sequence | View | Relation | Cookie | Style
|
adam@1752
|
379 type rewrite = { pkind : path_kind, kind : pattern_kind, from : string, to : string, hyphenate : bool }
|
adamc@768
|
380
|
adam@2096
|
381 fun pak2s pak =
|
adam@2096
|
382 case pak of
|
adam@2096
|
383 Exact => "Exact"
|
adam@2096
|
384 | Prefix => "Prefix"
|
adam@2096
|
385 fun pk2s pk =
|
adam@2096
|
386 case pk of
|
adam@2096
|
387 Any => "Any"
|
adam@2096
|
388 | Url => "Url"
|
adam@2096
|
389 | Table => "Table"
|
adam@2096
|
390 | Sequence => "Sequence"
|
adam@2096
|
391 | View => "View"
|
adam@2096
|
392 | Relation => "Relation"
|
adam@2096
|
393 | Cookie => "Cookie"
|
adam@2096
|
394 | Style => "Style"
|
adam@2096
|
395 fun r2s (r : rewrite) = pak2s (#kind r) ^ " " ^ pk2s (#pkind r) ^ ", from<" ^ #from r ^ ">, to<" ^ #to r ^ ">"
|
adam@2096
|
396
|
adamc@768
|
397 val rewrites = ref ([] : rewrite list)
|
adamc@768
|
398
|
adamc@768
|
399 fun subsume (pk1, pk2) =
|
adamc@768
|
400 pk1 = pk2
|
adamc@768
|
401 orelse pk2 = Any
|
adamc@768
|
402 orelse pk2 = Relation andalso (pk1 = Table orelse pk1 = Sequence orelse pk1 = View)
|
adamc@768
|
403
|
adamc@768
|
404 fun setRewriteRules ls = rewrites := ls
|
adamc@768
|
405 fun rewrite pk s =
|
adamc@768
|
406 let
|
adamc@768
|
407 fun rew (ls : rewrite list) =
|
adamc@768
|
408 case ls of
|
adamc@768
|
409 [] => s
|
adamc@768
|
410 | rewr :: ls =>
|
adamc@768
|
411 let
|
adamc@768
|
412 fun match () =
|
adamc@768
|
413 case #kind rewr of
|
adamc@768
|
414 Exact => if #from rewr = s then
|
adamc@768
|
415 SOME (size s)
|
adamc@768
|
416 else
|
adamc@768
|
417 NONE
|
adamc@768
|
418 | Prefix => if String.isPrefix (#from rewr) s then
|
adamc@768
|
419 SOME (size (#from rewr))
|
adamc@768
|
420 else
|
adamc@768
|
421 NONE
|
adamc@768
|
422 in
|
adamc@768
|
423 if subsume (pk, #pkind rewr) then
|
adamc@768
|
424 case match () of
|
adamc@768
|
425 NONE => rew ls
|
adam@1752
|
426 | SOME suffixStart =>
|
adam@1752
|
427 let
|
adam@1752
|
428 val s = #to rewr ^ String.extract (s, suffixStart, NONE)
|
adam@1752
|
429 in
|
adam@1752
|
430 if #hyphenate rewr then
|
adam@1752
|
431 String.translate (fn #"_" => "-" | ch => str ch) s
|
adam@1752
|
432 else
|
adam@1752
|
433 s
|
adam@1752
|
434 end
|
adamc@768
|
435 else
|
adamc@768
|
436 rew ls
|
adamc@768
|
437 end
|
adamc@768
|
438 in
|
adamc@768
|
439 rew (!rewrites)
|
adamc@768
|
440 end
|
adamc@768
|
441
|
adamc@769
|
442 val url = ref ([] : rule list)
|
adamc@769
|
443 val mime = ref ([] : rule list)
|
adam@1465
|
444 val request = ref ([] : rule list)
|
adam@1465
|
445 val response = ref ([] : rule list)
|
adam@1799
|
446 val env = ref ([] : rule list)
|
adamc@769
|
447
|
adamc@769
|
448 fun setUrlRules ls = url := ls
|
adamc@769
|
449 fun setMimeRules ls = mime := ls
|
adam@1465
|
450 fun setRequestHeaderRules ls = request := ls
|
adam@1465
|
451 fun setResponseHeaderRules ls = response := ls
|
adam@1799
|
452 fun setEnvVarRules ls = env := ls
|
adamc@769
|
453
|
adamc@770
|
454 fun getUrlRules () = !url
|
adamc@770
|
455 fun getMimeRules () = !mime
|
adam@1465
|
456 fun getRequestHeaderRules () = !request
|
adam@1465
|
457 fun getResponseHeaderRules () = !response
|
adam@1799
|
458 fun getEnvVarRules () = !env
|
adamc@770
|
459
|
adamc@769
|
460 fun check f rules s =
|
adamc@769
|
461 let
|
adamc@769
|
462 fun chk (ls : rule list) =
|
adamc@769
|
463 case ls of
|
adamc@769
|
464 [] => false
|
adamc@769
|
465 | rule :: ls =>
|
adamc@769
|
466 let
|
adamc@769
|
467 val matches =
|
adamc@769
|
468 case #kind rule of
|
adamc@769
|
469 Exact => #pattern rule = s
|
adamc@769
|
470 | Prefix => String.isPrefix (#pattern rule) s
|
adamc@769
|
471 in
|
adamc@769
|
472 if matches then
|
adamc@769
|
473 case #action rule of
|
adamc@769
|
474 Allow => true
|
adamc@769
|
475 | Deny => false
|
adamc@769
|
476 else
|
adamc@769
|
477 chk ls
|
adamc@769
|
478 end
|
adamc@769
|
479 in
|
adamc@769
|
480 f s andalso chk (!rules)
|
adamc@769
|
481 end
|
adamc@769
|
482
|
adamc@769
|
483 val checkUrl = check (fn _ => true) url
|
adam@1465
|
484
|
grrwlf@2024
|
485 val validMime = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"/" orelse ch = #"-" orelse ch = #"." orelse ch = #"+")
|
adam@1799
|
486 val validEnv = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"_" orelse ch = #".")
|
adam@1465
|
487
|
adam@1465
|
488 val checkMime = check validMime mime
|
adam@1465
|
489 val checkRequestHeader = check validMime request
|
adam@1465
|
490 val checkResponseHeader = check validMime response
|
adam@1799
|
491 val checkEnvVar = check validEnv env
|
adamc@769
|
492
|
adamc@855
|
493
|
adamc@855
|
494 type protocol = {
|
adamc@855
|
495 name : string,
|
adamc@1096
|
496 compile : string,
|
adamc@1095
|
497 linkStatic : string,
|
adamc@1095
|
498 linkDynamic : string,
|
adamc@1164
|
499 persistent : bool,
|
adamc@1164
|
500 code : unit -> Print.PD.pp_desc
|
adamc@855
|
501 }
|
adamc@855
|
502 val protocols = ref ([] : protocol list)
|
adamc@855
|
503 fun addProtocol p = protocols := p :: !protocols
|
adamc@855
|
504 fun getProtocol s = List.find (fn p => #name p = s) (!protocols)
|
adamc@855
|
505
|
ezyang@1739
|
506 fun clibFile s = OS.Path.joinDirFile {dir = libC (),
|
adamc@855
|
507 file = s}
|
adamc@855
|
508
|
adamc@865
|
509 val curProto = ref {name = "",
|
adamc@1096
|
510 compile = "",
|
adamc@1095
|
511 linkStatic = "",
|
adamc@1095
|
512 linkDynamic = "",
|
adamc@1164
|
513 persistent = false,
|
adamc@1164
|
514 code = fn () => Print.box []}
|
adamc@856
|
515 fun setProtocol name =
|
adamc@856
|
516 case getProtocol name of
|
adamc@856
|
517 NONE => raise Fail ("Unknown protocol " ^ name)
|
adamc@856
|
518 | SOME p => curProto := p
|
adamc@855
|
519 fun currentProtocol () = !curProto
|
adamc@855
|
520
|
adamc@857
|
521 val debug = ref false
|
adamc@857
|
522 fun setDebug b = debug := b
|
adamc@857
|
523 fun getDebug () = !debug
|
adamc@857
|
524
|
adamc@867
|
525 datatype sql_type =
|
adamc@867
|
526 Int
|
adamc@867
|
527 | Float
|
adamc@867
|
528 | String
|
adamc@1011
|
529 | Char
|
adamc@867
|
530 | Bool
|
adamc@867
|
531 | Time
|
adamc@867
|
532 | Blob
|
adamc@867
|
533 | Channel
|
adamc@867
|
534 | Client
|
adamc@867
|
535 | Nullable of sql_type
|
adamc@867
|
536
|
adamc@873
|
537 fun p_sql_ctype t =
|
adamc@867
|
538 let
|
adamc@867
|
539 open Print.PD
|
adamc@867
|
540 open Print
|
adamc@867
|
541 in
|
adamc@867
|
542 case t of
|
adamc@870
|
543 Int => "uw_Basis_int"
|
adamc@870
|
544 | Float => "uw_Basis_float"
|
adamc@870
|
545 | String => "uw_Basis_string"
|
adamc@1011
|
546 | Char => "uw_Basis_char"
|
adamc@870
|
547 | Bool => "uw_Basis_bool"
|
adamc@870
|
548 | Time => "uw_Basis_time"
|
adamc@870
|
549 | Blob => "uw_Basis_blob"
|
adamc@870
|
550 | Channel => "uw_Basis_channel"
|
adamc@870
|
551 | Client => "uw_Basis_client"
|
adamc@870
|
552 | Nullable String => "uw_Basis_string"
|
adamc@873
|
553 | Nullable t => p_sql_ctype t ^ "*"
|
adamc@867
|
554 end
|
adamc@867
|
555
|
adamc@867
|
556 fun isBlob Blob = true
|
adamc@867
|
557 | isBlob (Nullable t) = isBlob t
|
adamc@867
|
558 | isBlob _ = false
|
adamc@867
|
559
|
adamc@870
|
560 fun isNotNull (Nullable _) = false
|
adamc@870
|
561 | isNotNull _ = true
|
adamc@870
|
562
|
adam@1293
|
563 datatype failure_mode = Error | None
|
adam@1293
|
564
|
adamc@866
|
565 type dbms = {
|
adamc@866
|
566 name : string,
|
adam@1682
|
567 randomFunction : string,
|
adamc@866
|
568 header : string,
|
adamc@866
|
569 link : string,
|
adamc@873
|
570 p_sql_type : sql_type -> string,
|
adamc@870
|
571 init : {dbstring : string,
|
adamc@870
|
572 prepared : (string * int) list,
|
adamc@870
|
573 tables : (string * (string * sql_type) list) list,
|
adamc@872
|
574 views : (string * (string * sql_type) list) list,
|
adamc@870
|
575 sequences : string list} -> Print.PD.pp_desc,
|
adamc@873
|
576 query : {loc : ErrorMsg.span, cols : sql_type list,
|
adamc@880
|
577 doCols : ({loc : ErrorMsg.span, wontLeakStrings : bool, col : int, typ : sql_type} -> Print.PD.pp_desc)
|
adamc@867
|
578 -> Print.PD.pp_desc}
|
adamc@867
|
579 -> Print.PD.pp_desc,
|
adamc@867
|
580 queryPrepared : {loc : ErrorMsg.span, id : int, query : string,
|
adamc@873
|
581 inputs : sql_type list, cols : sql_type list,
|
adamc@880
|
582 doCols : ({loc : ErrorMsg.span, wontLeakStrings : bool, col : int,
|
adamc@880
|
583 typ : sql_type} -> Print.PD.pp_desc)
|
adamc@879
|
584 -> Print.PD.pp_desc,
|
adamc@879
|
585 nested : bool}
|
adamc@868
|
586 -> Print.PD.pp_desc,
|
adam@1293
|
587 dml : ErrorMsg.span * failure_mode -> Print.PD.pp_desc,
|
adamc@868
|
588 dmlPrepared : {loc : ErrorMsg.span, id : int, dml : string,
|
adam@1293
|
589 inputs : sql_type list, mode : failure_mode} -> Print.PD.pp_desc,
|
adamc@878
|
590 nextval : {loc : ErrorMsg.span, seqName : string option, seqE : Print.PD.pp_desc} -> Print.PD.pp_desc,
|
adamc@874
|
591 nextvalPrepared : {loc : ErrorMsg.span, id : int, query : string} -> Print.PD.pp_desc,
|
adamc@1073
|
592 setval : {loc : ErrorMsg.span, seqE : Print.PD.pp_desc, count : Print.PD.pp_desc} -> Print.PD.pp_desc,
|
adamc@874
|
593 sqlifyString : string -> string,
|
adamc@874
|
594 p_cast : string * sql_type -> string,
|
adamc@874
|
595 p_blank : int * sql_type -> string,
|
adamc@877
|
596 supportsDeleteAs : bool,
|
adamc@886
|
597 supportsUpdateAs : bool,
|
adamc@877
|
598 createSequence : string -> string,
|
adamc@878
|
599 textKeysNeedLengths : bool,
|
adamc@879
|
600 supportsNextval : bool,
|
adamc@882
|
601 supportsNestedPrepared : bool,
|
adamc@890
|
602 sqlPrefix : string,
|
adamc@1014
|
603 supportsOctetLength : bool,
|
adamc@1014
|
604 trueString : string,
|
adamc@1196
|
605 falseString : string,
|
adamc@1196
|
606 onlyUnion : bool,
|
adam@1777
|
607 nestedRelops : bool,
|
adam@1778
|
608 windowFunctions: bool
|
adamc@866
|
609 }
|
adamc@866
|
610
|
adamc@866
|
611 val dbmses = ref ([] : dbms list)
|
adamc@866
|
612 val curDb = ref ({name = "",
|
adam@1682
|
613 randomFunction = "",
|
adamc@866
|
614 header = "",
|
adamc@866
|
615 link = "",
|
adamc@873
|
616 p_sql_type = fn _ => "",
|
adamc@867
|
617 init = fn _ => Print.box [],
|
adamc@867
|
618 query = fn _ => Print.box [],
|
adamc@868
|
619 queryPrepared = fn _ => Print.box [],
|
adamc@868
|
620 dml = fn _ => Print.box [],
|
adamc@869
|
621 dmlPrepared = fn _ => Print.box [],
|
adamc@869
|
622 nextval = fn _ => Print.box [],
|
adamc@874
|
623 nextvalPrepared = fn _ => Print.box [],
|
adamc@1073
|
624 setval = fn _ => Print.box [],
|
adamc@874
|
625 sqlifyString = fn s => s,
|
adamc@874
|
626 p_cast = fn _ => "",
|
adamc@874
|
627 p_blank = fn _ => "",
|
adamc@877
|
628 supportsDeleteAs = false,
|
adamc@886
|
629 supportsUpdateAs = false,
|
adamc@877
|
630 createSequence = fn _ => "",
|
adamc@878
|
631 textKeysNeedLengths = false,
|
adamc@879
|
632 supportsNextval = false,
|
adamc@882
|
633 supportsNestedPrepared = false,
|
adamc@890
|
634 sqlPrefix = "",
|
adamc@1014
|
635 supportsOctetLength = false,
|
adamc@1014
|
636 trueString = "",
|
adamc@1196
|
637 falseString = "",
|
adamc@1196
|
638 onlyUnion = false,
|
adam@1777
|
639 nestedRelops = false,
|
adam@1777
|
640 windowFunctions = false} : dbms)
|
adamc@866
|
641
|
adamc@866
|
642 fun addDbms v = dbmses := v :: !dbmses
|
adamc@866
|
643 fun setDbms s =
|
adamc@866
|
644 case List.find (fn db => #name db = s) (!dbmses) of
|
adamc@866
|
645 NONE => raise Fail ("Unknown DBMS " ^ s)
|
adamc@866
|
646 | SOME db => curDb := db
|
adamc@866
|
647 fun currentDbms () = !curDb
|
adamc@866
|
648
|
adamc@891
|
649 val dbstring = ref (NONE : string option)
|
adamc@891
|
650 fun setDbstring so = dbstring := so
|
adamc@891
|
651 fun getDbstring () = !dbstring
|
adamc@891
|
652
|
adamc@891
|
653 val exe = ref (NONE : string option)
|
adamc@891
|
654 fun setExe so = exe := so
|
adamc@891
|
655 fun getExe () = !exe
|
adamc@891
|
656
|
adamc@891
|
657 val sql = ref (NONE : string option)
|
adamc@891
|
658 fun setSql so = sql := so
|
adamc@891
|
659 fun getSql () = !sql
|
adamc@891
|
660
|
adam@1820
|
661 val coreInline = ref 5
|
adamc@1016
|
662 fun setCoreInline n = coreInline := n
|
adamc@1016
|
663 fun getCoreInline () = !coreInline
|
adamc@1016
|
664
|
adam@1820
|
665 val monoInline = ref 5
|
adamc@1016
|
666 fun setMonoInline n = monoInline := n
|
adamc@1016
|
667 fun getMonoInline () = !monoInline
|
adamc@1016
|
668
|
adamc@1095
|
669 val staticLinking = ref false
|
adamc@1095
|
670 fun setStaticLinking b = staticLinking := b
|
adamc@1095
|
671 fun getStaticLinking () = !staticLinking
|
adamc@1095
|
672
|
adamc@1114
|
673 val deadlines = ref false
|
adamc@1114
|
674 fun setDeadlines b = deadlines := b
|
adamc@1114
|
675 fun getDeadlines () = !deadlines
|
adamc@1114
|
676
|
adamc@1164
|
677 val sigFile = ref (NONE : string option)
|
adamc@1164
|
678 fun setSigFile v = sigFile := v
|
adamc@1164
|
679 fun getSigFile () = !sigFile
|
adamc@1164
|
680
|
adamc@1183
|
681 structure SS = BinarySetFn(struct
|
adamc@1183
|
682 type ord_key = string
|
adamc@1183
|
683 val compare = String.compare
|
adamc@1183
|
684 end)
|
adamc@1183
|
685
|
adamc@1183
|
686 val safeGet = ref SS.empty
|
adamc@1183
|
687 fun setSafeGets ls = safeGet := SS.addList (SS.empty, ls)
|
adamc@1183
|
688 fun isSafeGet x = SS.member (!safeGet, x)
|
adamc@1183
|
689
|
adam@1294
|
690 val onError = ref (NONE : (string * string list * string) option)
|
adam@1294
|
691 fun setOnError x = onError := x
|
adam@1294
|
692 fun getOnError () = !onError
|
adam@1294
|
693
|
adam@1307
|
694 val limits = ["messages", "clients", "headers", "page", "heap", "script",
|
adam@1307
|
695 "inputs", "subinputs", "cleanup", "deltas", "transactionals",
|
adam@1308
|
696 "globals", "database", "time"]
|
adam@1307
|
697
|
adam@1307
|
698 val limitsList = ref ([] : (string * int) list)
|
adam@1307
|
699 fun addLimit (v as (name, _)) =
|
adam@1307
|
700 if List.exists (fn name' => name' = name) limits then
|
adam@1308
|
701 (limitsList := v :: !limitsList;
|
adam@1308
|
702 if name = "time" then
|
adam@1308
|
703 setDeadlines true
|
adam@1308
|
704 else
|
adam@1308
|
705 ())
|
adam@1307
|
706 else
|
adam@1307
|
707 raise Fail ("Unknown limit category '" ^ name ^ "'")
|
adam@1307
|
708 fun limits () = !limitsList
|
adam@1307
|
709
|
adam@1332
|
710 val minHeap = ref 0
|
adam@1332
|
711 fun setMinHeap n = if n >= 0 then minHeap := n else raise Fail "Trying to set negative minHeap"
|
adam@1332
|
712 fun getMinHeap () = !minHeap
|
adam@1332
|
713
|
adam@1393
|
714 structure SS = BinarySetFn(struct
|
adam@1393
|
715 type ord_key = string
|
adam@1393
|
716 val compare = String.compare
|
adam@1393
|
717 end)
|
adam@1393
|
718
|
adam@1393
|
719 val alwaysInline = ref SS.empty
|
adam@1393
|
720 fun addAlwaysInline s = alwaysInline := SS.add (!alwaysInline, s)
|
adam@1393
|
721 fun checkAlwaysInline s = SS.member (!alwaysInline, s)
|
adam@1393
|
722
|
adam@1966
|
723 val neverInline = ref SS.empty
|
adam@1966
|
724 fun addNeverInline s = neverInline := SS.add (!neverInline, s)
|
adam@1966
|
725 fun checkNeverInline s = SS.member (!neverInline, s)
|
adam@1966
|
726
|
adam@1478
|
727 val noXsrfProtection = ref SS.empty
|
adam@1478
|
728 fun addNoXsrfProtection s = noXsrfProtection := SS.add (!noXsrfProtection, s)
|
adam@1478
|
729 fun checkNoXsrfProtection s = SS.member (!noXsrfProtection, s)
|
adam@1478
|
730
|
adam@1629
|
731 val timeFormat = ref "%c"
|
adam@1629
|
732 fun setTimeFormat v = timeFormat := v
|
adam@1629
|
733 fun getTimeFormat () = !timeFormat
|
adam@1629
|
734
|
adam@1953
|
735 fun lowercase s =
|
adam@1953
|
736 case s of
|
adam@1953
|
737 "" => ""
|
adam@1953
|
738 | _ => str (Char.toLower (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
|
adam@1953
|
739
|
adam@1953
|
740 fun capitalize s =
|
adam@1953
|
741 case s of
|
adam@1953
|
742 "" => ""
|
adam@1953
|
743 | _ => str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
|
adam@1953
|
744
|
adam@1953
|
745 val mangle = ref true
|
adam@1953
|
746 fun setMangleSql x = mangle := x
|
adam@1953
|
747 fun mangleSqlTable s = if !mangle then "uw_" ^ capitalize s
|
adam@1953
|
748 else if #name (currentDbms ()) = "mysql" then capitalize s
|
adam@1959
|
749 else lowercase s
|
adam@1953
|
750 fun mangleSql s = if !mangle then "uw_" ^ s
|
adam@1953
|
751 else if #name (currentDbms ()) = "mysql" then lowercase s
|
adam@1959
|
752 else lowercase s
|
adam@1953
|
753 fun mangleSqlCatalog s = if !mangle then "uw_" ^ s else lowercase s
|
adam@1953
|
754
|
adam@1956
|
755 val html5 = ref false
|
adam@1956
|
756 fun setIsHtml5 b = html5 := b
|
adam@1956
|
757 fun getIsHtml5 () = !html5
|
adam@1956
|
758
|
adam@2010
|
759 val less = ref false
|
adam@2010
|
760 fun setLessSafeFfi b = less := b
|
adam@2010
|
761 fun getLessSafeFfi () = !less
|
adam@2010
|
762
|
adam@2046
|
763 structure SM = BinaryMapFn(struct
|
adam@2046
|
764 type ord_key = string
|
adam@2046
|
765 val compare = String.compare
|
adam@2046
|
766 end)
|
adam@2046
|
767
|
adam@2046
|
768 val noMimeFile = ref false
|
adam@2046
|
769
|
adam@2046
|
770 fun noMime () =
|
adam@2046
|
771 (TextIO.output (TextIO.stdErr, "WARNING: Error opening /etc/mime.types. Static files will be served with no suggested MIME types.\n");
|
adam@2046
|
772 noMimeFile := true;
|
adam@2046
|
773 SM.empty)
|
adam@2046
|
774
|
adam@2046
|
775 fun readMimeTypes () =
|
adam@2046
|
776 let
|
adam@2046
|
777 val inf = TextIO.openIn "/etc/mime.types"
|
adam@2046
|
778
|
adam@2046
|
779 fun loop m =
|
adam@2046
|
780 case TextIO.inputLine inf of
|
adam@2046
|
781 NONE => m
|
adam@2046
|
782 | SOME line =>
|
adam@2046
|
783 if size line > 0 andalso String.sub (line, 0) = #"#" then
|
adam@2046
|
784 loop m
|
adam@2046
|
785 else
|
adam@2046
|
786 case String.tokens Char.isSpace line of
|
adam@2046
|
787 typ :: exts =>
|
adam@2046
|
788 loop (foldl (fn (ext, m) => SM.insert (m, ext, typ)) m exts)
|
adam@2046
|
789 | _ => loop m
|
adam@2046
|
790 in
|
adam@2046
|
791 loop SM.empty
|
adam@2046
|
792 before TextIO.closeIn inf
|
adam@2046
|
793 end handle IO.Io _ => noMime ()
|
adam@2046
|
794 | OS.SysErr _ => noMime ()
|
adam@2046
|
795
|
adam@2046
|
796 val mimeTypes = ref (NONE : string SM.map option)
|
adam@2046
|
797
|
adam@2046
|
798 fun getMimeTypes () =
|
adam@2046
|
799 case !mimeTypes of
|
adam@2046
|
800 SOME m => m
|
adam@2046
|
801 | NONE =>
|
adam@2046
|
802 let
|
adam@2046
|
803 val m = readMimeTypes ()
|
adam@2046
|
804 in
|
adam@2046
|
805 mimeTypes := SOME m;
|
adam@2046
|
806 m
|
adam@2046
|
807 end
|
adam@2046
|
808
|
adam@2046
|
809 fun mimeTypeOf filename =
|
adam@2046
|
810 case OS.Path.ext filename of
|
adam@2046
|
811 NONE => (if !noMimeFile then
|
adam@2046
|
812 ()
|
adam@2046
|
813 else
|
adam@2046
|
814 TextIO.output (TextIO.stdErr, "WARNING: No extension found in filename '" ^ filename ^ "'. Header 'Content-Type' will be omitted in HTTP responses.\n");
|
adam@2046
|
815 NONE)
|
adam@2046
|
816 | SOME ext =>
|
adam@2046
|
817 let
|
adam@2046
|
818 val to = SM.find (getMimeTypes (), ext)
|
adam@2046
|
819 in
|
adam@2046
|
820 case to of
|
adam@2046
|
821 NONE => if !noMimeFile then
|
adam@2046
|
822 ()
|
adam@2046
|
823 else
|
adam@2046
|
824 TextIO.output (TextIO.stdErr, "WARNING: No MIME type known for extension '" ^ ext ^ "'. Header 'Content-Type' will be omitted in HTTP responses.\n")
|
adam@2046
|
825 | _ => ();
|
adam@2046
|
826 to
|
adam@2046
|
827 end
|
adam@2046
|
828
|
adam@2046
|
829 val files = ref (SM.empty : (string * {Uri : string, ContentType : string option, LastModified : Time.time, Bytes : Word8Vector.vector}) SM.map)
|
adam@2046
|
830
|
adam@2046
|
831 val filePath = ref "."
|
adam@2046
|
832
|
adam@2046
|
833 fun setFilePath path = filePath := path
|
adam@2046
|
834
|
adam@2046
|
835 fun addFile {Uri, LoadFromFilename} =
|
adam@2046
|
836 let
|
adam@2046
|
837 val path = OS.Path.joinDirFile {dir = !filePath, file = LoadFromFilename}
|
adam@2046
|
838 in
|
adam@2046
|
839 case SM.find (!files, Uri) of
|
adam@2046
|
840 SOME (path', _) =>
|
adam@2046
|
841 if path' = path then
|
adam@2046
|
842 ()
|
adam@2046
|
843 else
|
adam@2046
|
844 ErrorMsg.error ("Two different files requested for URI " ^ Uri)
|
adam@2046
|
845 | NONE =>
|
adam@2046
|
846 let
|
adam@2046
|
847 val inf = BinIO.openIn path
|
adam@2046
|
848 in
|
adam@2046
|
849 files := SM.insert (!files,
|
adam@2046
|
850 Uri,
|
adam@2046
|
851 (path,
|
adam@2046
|
852 {Uri = Uri,
|
adam@2046
|
853 ContentType = mimeTypeOf path,
|
adam@2046
|
854 LastModified = OS.FileSys.modTime path,
|
adam@2046
|
855 Bytes = BinIO.inputAll inf}));
|
adam@2046
|
856 BinIO.closeIn inf
|
adam@2046
|
857 end
|
adam@2046
|
858 end handle IO.Io _ =>
|
adam@2046
|
859 ErrorMsg.error ("Error loading file " ^ LoadFromFilename)
|
adam@2046
|
860 | OS.SysErr (s, _) =>
|
adam@2046
|
861 ErrorMsg.error ("Error loading file " ^ LoadFromFilename ^ " (" ^ s ^ ")")
|
adam@2046
|
862
|
adam@2046
|
863 fun listFiles () = map #2 (SM.listItems (!files))
|
adam@2046
|
864
|
adamc@765
|
865 end
|