Mercurial > urweb

annotate src/prepare.sml @ 2112:b4702145f8de

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Treat getHeader and getenv as vectors for reading request data supplied implicitly by browsers
author Adam Chlipala <adam@chlipala.net>
date Thu, 05 Feb 2015 11:09:25 -0500
parents 4d64af730e35
children
rev   line source
adamc@282 1 (* Copyright (c) 2008, Adam Chlipala
adamc@282 2 * All rights reserved.
adamc@282 3 *
adamc@282 4 * Redistribution and use in source and binary forms, with or without
adamc@282 5 * modification, are permitted provided that the following conditions are met:
adamc@282 6 *
adamc@282 7 * - Redistributions of source code must retain the above copyright notice,
adamc@282 8 * this list of conditions and the following disclaimer.
adamc@282 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@282 10 * this list of conditions and the following disclaimer in the documentation
adamc@282 11 * and/or other materials provided with the distribution.
adamc@282 12 * - The names of contributors may not be used to endorse or promote products
adamc@282 13 * derived from this software without specific prior written permission.
adamc@282 14 *
adamc@282 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@282 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@282 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@282 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@282 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@282 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@282 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@282 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@282 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@282 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@282 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@282 26 *)
adamc@282 27
adamc@282 28 structure Prepare :> PREPARE = struct
adamc@282 29
adamc@282 30 open Cjr
adamc@874 31 open Settings
adamc@282 32
adamc@883 33 structure SM = BinaryMapFn(struct
adamc@883 34 type ord_key = string
adamc@883 35 val compare = String.compare
adamc@883 36 end)
adamc@883 37
adamc@883 38 structure St :> sig
adamc@883 39 type t
adamc@883 40 val empty : t
adamc@883 41 val nameOf : t * string -> t * int
adamc@883 42 val list : t -> (string * int) list
adamc@883 43 val count : t -> int
adamc@883 44 end = struct
adamc@883 45
adamc@883 46 type t = {map : int SM.map, list : (string * int) list, count : int}
adamc@883 47
adamc@883 48 val empty = {map = SM.empty, list = [], count = 0}
adamc@883 49
adamc@883 50 fun nameOf (t as {map, list, count}, s) =
adamc@883 51 case SM.find (map, s) of
adamc@883 52 NONE => ({map = SM.insert (map, s, count), list = (s, count) :: list, count = count + 1}, count)
adamc@883 53 | SOME n => (t, n)
adamc@883 54
adamc@883 55 fun list (t : t) = rev (#list t)
adamc@883 56 fun count (t : t) = #count t
adamc@883 57
adamc@883 58 end
adamc@883 59
adamc@883 60 fun prepString (e, st) =
adamc@874 61 let
adamc@883 62 fun prepString' (e, ss, n) =
adamc@883 63 let
adamc@883 64 fun doOne t =
adamc@883 65 SOME (#p_blank (Settings.currentDbms ()) (n + 1, t) :: ss, n + 1)
adamc@883 66 in
adamc@883 67 case #1 e of
adam@2048 68 EPrim (Prim.String (_, s)) =>
adamc@883 69 SOME (s :: ss, n)
adam@1663 70 | EFfiApp ("Basis", "strcat", [(e1, _), (e2, _)]) =>
adamc@883 71 (case prepString' (e1, ss, n) of
adamc@883 72 NONE => NONE
adamc@883 73 | SOME (ss, n) => prepString' (e2, ss, n))
adam@1663 74 | EFfiApp ("Basis", "sqlifyInt", [_]) => doOne Int
adam@1663 75 | EFfiApp ("Basis", "sqlifyFloat", [_]) => doOne Float
adam@1663 76 | EFfiApp ("Basis", "sqlifyString", [_]) => doOne String
adam@1663 77 | EFfiApp ("Basis", "sqlifyBool", [_]) => doOne Bool
adam@1663 78 | EFfiApp ("Basis", "sqlifyTime", [_]) => doOne Time
adam@1663 79 | EFfiApp ("Basis", "sqlifyBlob", [_]) => doOne Blob
adam@1663 80 | EFfiApp ("Basis", "sqlifyChannel", [_]) => doOne Channel
adam@1663 81 | EFfiApp ("Basis", "sqlifyClient", [_]) => doOne Client
adamc@883 82
adamc@883 83 | ECase (e,
adamc@883 84 [((PNone _, _),
adam@2048 85 (EPrim (Prim.String (_, "NULL")), _)),
adamc@883 86 ((PSome (_, (PVar _, _)), _),
adam@1663 87 (EFfiApp (m, x, [((ERel 0, _), _)]), _))],
adam@1663 88 {disc = t, ...}) => prepString' ((EFfiApp (m, x, [(e, t)]), #2 e), ss, n)
adamc@883 89
adamc@883 90 | ECase (e,
adamc@883 91 [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, _), _),
adam@2048 92 (EPrim (Prim.String (_, "TRUE")), _)),
adamc@883 93 ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, _), _),
adam@2048 94 (EPrim (Prim.String (_, "FALSE")), _))],
adamc@883 95 _) => doOne Bool
adamc@883 96
adamc@883 97 | _ => NONE
adamc@883 98 end
adamc@874 99 in
adamc@883 100 case prepString' (e, [], 0) of
adamc@883 101 NONE => NONE
adamc@883 102 | SOME (ss, n) =>
adamc@883 103 let
adamc@883 104 val s = String.concat (rev ss)
adamc@883 105 val (st, id) = St.nameOf (st, s)
adamc@883 106 in
adamc@883 107 SOME (id, s, st)
adamc@883 108 end
adamc@874 109 end
adamc@282 110
adamc@883 111 fun prepExp (e as (_, loc), st) =
adamc@282 112 case #1 e of
adamc@883 113 EPrim _ => (e, st)
adamc@883 114 | ERel _ => (e, st)
adamc@883 115 | ENamed _ => (e, st)
adamc@883 116 | ECon (_, _, NONE) => (e, st)
adamc@282 117 | ECon (dk, pc, SOME e) =>
adamc@282 118 let
adamc@883 119 val (e, st) = prepExp (e, st)
adamc@282 120 in
adamc@883 121 ((ECon (dk, pc, SOME e), loc), st)
adamc@282 122 end
adamc@883 123 | ENone t => (e, st)
adamc@291 124 | ESome (t, e) =>
adamc@291 125 let
adamc@883 126 val (e, st) = prepExp (e, st)
adamc@291 127 in
adamc@883 128 ((ESome (t, e), loc), st)
adamc@291 129 end
adamc@883 130 | EFfi _ => (e, st)
adamc@282 131 | EFfiApp (m, x, es) =>
adamc@282 132 let
adam@1663 133 val (es, st) = ListUtil.foldlMap (fn ((e, t), st) =>
adam@1663 134 let
adam@1663 135 val (e, st) = prepExp (e, st)
adam@1663 136 in
adam@1663 137 ((e, t), st)
adam@1663 138 end) st es
adamc@282 139 in
adamc@883 140 ((EFfiApp (m, x, es), loc), st)
adamc@282 141 end
adamc@316 142 | EApp (e1, es) =>
adamc@282 143 let
adamc@883 144 val (e1, st) = prepExp (e1, st)
adamc@883 145 val (es, st) = ListUtil.foldlMap prepExp st es
adamc@282 146 in
adamc@883 147 ((EApp (e1, es), loc), st)
adamc@282 148 end
adamc@282 149
adamc@387 150 | EUnop (s, e1) =>
adamc@387 151 let
adamc@883 152 val (e1, st) = prepExp (e1, st)
adamc@387 153 in
adamc@883 154 ((EUnop (s, e1), loc), st)
adamc@387 155 end
adamc@387 156 | EBinop (s, e1, e2) =>
adamc@387 157 let
adamc@883 158 val (e1, st) = prepExp (e1, st)
adamc@883 159 val (e2, st) = prepExp (e2, st)
adamc@387 160 in
adamc@883 161 ((EBinop (s, e1, e2), loc), st)
adamc@387 162 end
adamc@387 163
adamc@282 164 | ERecord (rn, xes) =>
adamc@282 165 let
adamc@883 166 val (xes, st) = ListUtil.foldlMap (fn ((x, e), st) =>
adamc@282 167 let
adamc@883 168 val (e, st) = prepExp (e, st)
adamc@282 169 in
adamc@883 170 ((x, e), st)
adamc@883 171 end) st xes
adamc@282 172 in
adamc@883 173 ((ERecord (rn, xes), loc), st)
adamc@282 174 end
adamc@282 175 | EField (e, s) =>
adamc@282 176 let
adamc@883 177 val (e, st) = prepExp (e, st)
adamc@282 178 in
adamc@883 179 ((EField (e, s), loc), st)
adamc@282 180 end
adamc@282 181
adamc@282 182 | ECase (e, pes, ts) =>
adamc@282 183 let
adamc@883 184 val (e, st) = prepExp (e, st)
adamc@883 185 val (pes, st) = ListUtil.foldlMap (fn ((p, e), st) =>
adamc@282 186 let
adamc@883 187 val (e, st) = prepExp (e, st)
adamc@282 188 in
adamc@883 189 ((p, e), st)
adamc@883 190 end) st pes
adamc@282 191 in
adamc@883 192 ((ECase (e, pes, ts), loc), st)
adamc@282 193 end
adamc@282 194
adamc@283 195 | EError (e, t) =>
adamc@283 196 let
adamc@883 197 val (e, st) = prepExp (e, st)
adamc@283 198 in
adamc@883 199 ((EError (e, t), loc), st)
adamc@283 200 end
adamc@283 201
adamc@741 202 | EReturnBlob {blob, mimeType, t} =>
adamc@741 203 let
adam@1932 204 val (blob, st) = case blob of
adam@1932 205 NONE => (blob, st)
adam@1932 206 | SOME blob =>
adam@1932 207 let
adam@1932 208 val (b, st) = prepExp (blob, st)
adam@1932 209 in
adam@1932 210 (SOME b, st)
adam@1932 211 end
adamc@883 212 val (mimeType, st) = prepExp (mimeType, st)
adamc@741 213 in
adamc@883 214 ((EReturnBlob {blob = blob, mimeType = mimeType, t = t}, loc), st)
adamc@741 215 end
adamc@741 216
adamc@1065 217 | ERedirect (e, t) =>
adamc@1065 218 let
adamc@1065 219 val (e, st) = prepExp (e, st)
adamc@1065 220 in
adamc@1065 221 ((ERedirect (e, t), loc), st)
adamc@1065 222 end
adamc@1065 223
adamc@282 224 | EWrite e =>
adamc@282 225 let
adamc@883 226 val (e, st) = prepExp (e, st)
adamc@282 227 in
adamc@883 228 ((EWrite e, loc), st)
adamc@282 229 end
adamc@282 230 | ESeq (e1, e2) =>
adamc@282 231 let
adamc@883 232 val (e1, st) = prepExp (e1, st)
adamc@883 233 val (e2, st) = prepExp (e2, st)
adamc@282 234 in
adamc@883 235 ((ESeq (e1, e2), loc), st)
adamc@282 236 end
adamc@282 237 | ELet (x, t, e1, e2) =>
adamc@282 238 let
adamc@883 239 val (e1, st) = prepExp (e1, st)
adamc@883 240 val (e2, st) = prepExp (e2, st)
adamc@282 241 in
adamc@883 242 ((ELet (x, t, e1, e2), loc), st)
adamc@282 243 end
adamc@282 244
adamc@282 245 | EQuery {exps, tables, rnum, state, query, body, initial, ...} =>
adamc@486 246 let
adamc@883 247 val (body, st) = prepExp (body, st)
adamc@486 248 in
adamc@883 249 case prepString (query, st) of
adamc@486 250 NONE =>
adamc@486 251 ((EQuery {exps = exps, tables = tables, rnum = rnum,
adamc@486 252 state = state, query = query, body = body,
adamc@491 253 initial = initial, prepared = NONE}, loc),
adamc@883 254 st)
adamc@883 255 | SOME (id, s, st) =>
adamc@883 256 ((EQuery {exps = exps, tables = tables, rnum = rnum,
adamc@883 257 state = state, query = query, body = body,
adamc@883 258 initial = initial, prepared = SOME {id = id, query = s, nested = true}}, loc), st)
adamc@486 259 end
adamc@282 260
adam@1293 261 | EDml {dml, mode, ...} =>
adamc@883 262 (case prepString (dml, st) of
adamc@883 263 NONE => (e, st)
adamc@883 264 | SOME (id, s, st) =>
adam@1293 265 ((EDml {dml = dml, prepared = SOME {id = id, dml = s}, mode = mode}, loc), st))
adamc@307 266
adamc@338 267 | ENextval {seq, ...} =>
adamc@878 268 if #supportsNextval (Settings.currentDbms ()) then
adamc@878 269 let
adamc@878 270 val s = case seq of
adam@2048 271 (EPrim (Prim.String (_, s)), loc) =>
adam@2048 272 (EPrim (Prim.String (Prim.Normal, "SELECT NEXTVAL('" ^ s ^ "')")), loc)
adamc@878 273 | _ =>
adamc@878 274 let
adam@1663 275 val t = (TFfi ("Basis", "string"), loc)
adam@2048 276 val s' = (EFfiApp ("Basis", "strcat", [(seq, t), ((EPrim (Prim.String (Prim.Normal, "')")), loc), t)]), loc)
adamc@878 277 in
adam@2048 278 (EFfiApp ("Basis", "strcat", [((EPrim (Prim.String (Prim.Normal, "SELECT NEXTVAL('")), loc), t), (s', t)]), loc)
adamc@878 279 end
adamc@878 280 in
adamc@883 281 case prepString (s, st) of
adamc@883 282 NONE => (e, st)
adamc@883 283 | SOME (id, s, st) =>
adamc@883 284 ((ENextval {seq = seq, prepared = SOME {id = id, query = s}}, loc), st)
adamc@878 285 end
adamc@878 286 else
adamc@883 287 (e, st)
adamc@338 288
adamc@1073 289 | ESetval {seq = e1, count = e2} =>
adamc@1073 290 let
adamc@1073 291 val (e1, st) = prepExp (e1, st)
adamc@1073 292 val (e2, st) = prepExp (e2, st)
adamc@1073 293 in
adamc@1073 294 ((ESetval {seq = e1, count = e2}, loc), st)
adamc@1073 295 end
adamc@1073 296
adamc@1112 297 | EUnurlify (e, t, b) =>
adamc@463 298 let
adamc@883 299 val (e, st) = prepExp (e, st)
adamc@463 300 in
adamc@1112 301 ((EUnurlify (e, t, b), loc), st)
adamc@463 302 end
adamc@463 303
adamc@883 304 fun prepDecl (d as (_, loc), st) =
adamc@282 305 case #1 d of
adamc@883 306 DStruct _ => (d, st)
adamc@883 307 | DDatatype _ => (d, st)
adamc@883 308 | DDatatypeForward _ => (d, st)
adamc@282 309 | DVal (x, n, t, e) =>
adamc@282 310 let
adamc@883 311 val (e, st) = prepExp (e, st)
adamc@282 312 in
adamc@883 313 ((DVal (x, n, t, e), loc), st)
adamc@282 314 end
adamc@282 315 | DFun (x, n, xts, t, e) =>
adamc@282 316 let
adamc@883 317 val (e, st) = prepExp (e, st)
adamc@282 318 in
adamc@883 319 ((DFun (x, n, xts, t, e), loc), st)
adamc@282 320 end
adamc@282 321 | DFunRec fs =>
adamc@282 322 let
adamc@883 323 val (fs, st) = ListUtil.foldlMap (fn ((x, n, xts, t, e), st) =>
adamc@282 324 let
adamc@883 325 val (e, st) = prepExp (e, st)
adamc@282 326 in
adamc@883 327 ((x, n, xts, t, e), st)
adamc@883 328 end) st fs
adamc@282 329 in
adamc@883 330 ((DFunRec fs, loc), st)
adamc@282 331 end
adamc@282 332
adamc@883 333 | DTable _ => (d, st)
adamc@883 334 | DSequence _ => (d, st)
adamc@883 335 | DView _ => (d, st)
adamc@883 336 | DDatabase _ => (d, st)
adamc@883 337 | DPreparedStatements _ => (d, st)
adamc@883 338 | DJavaScript _ => (d, st)
adamc@883 339 | DCookie _ => (d, st)
adamc@883 340 | DStyle _ => (d, st)
adam@1348 341 | DTask (tk, x1, x2, e) =>
adamc@1073 342 let
adamc@1073 343 val (e, st) = prepExp (e, st)
adamc@1073 344 in
adam@1348 345 ((DTask (tk, x1, x2, e), loc), st)
adamc@1073 346 end
adam@1294 347 | DOnError _ => (d, st)
adamc@282 348
adamc@282 349 fun prepare (ds, ps) =
adamc@282 350 let
adamc@883 351 val (ds, st) = ListUtil.foldlMap prepDecl St.empty ds
adamc@282 352 in
adamc@883 353 ((DPreparedStatements (St.list st), ErrorMsg.dummySpan) :: ds, ps)
adamc@282 354 end
adamc@282 355
adamc@282 356 end