Mercurial > urweb
view src/marshalcheck.sml @ 2252:e843a04499d4
Revert to revision 2222.
author | Ziv Scully <ziv@mit.edu> |
---|---|
date | Mon, 21 Sep 2015 10:16:55 -0400 |
parents | 001638622c4f |
children |
line wrap: on
line source
(* Copyright (c) 2009-2010, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are met: * * - Redistributions of source code must retain the above copyright notice, * this list of conditions and the following disclaimer. * - Redistributions in binary form must reproduce the above copyright notice, * this list of conditions and the following disclaimer in the documentation * and/or other materials provided with the distribution. * - The names of contributors may not be used to endorse or promote products * derived from this software without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE * POSSIBILITY OF SUCH DAMAGE. *) structure MarshalCheck :> MARSHAL_CHECK = struct open Core structure U = CoreUtil structure E = ErrorMsg structure PK = struct open Order type ord_key = string * string fun compare ((m1, x1), (m2, x2)) = join (String.compare (m1, m2), fn () => String.compare (x1, x2)) end structure PS = BinarySetFn(PK) structure PS = struct open PS fun toString' (m, x) = m ^ "." ^ x fun toString set = case PS.listItems set of [] => "{}" | [x] => toString' x | x :: xs => List.foldl (fn (x, s) => s ^ ", " ^ toString' x) (toString' x) xs end structure IM = IntBinaryMap fun check file = let fun kind (_, st) = st fun con cmap (c, st) = case c of CFfi mx => if Settings.mayClientToServer mx then st else PS.add (st, mx) | CNamed n => (case IM.find (cmap, n) of NONE => st | SOME st' => PS.union (st, st')) | _ => st fun sins cmap = U.Con.fold {kind = kind, con = con cmap} PS.empty in ignore (foldl (fn ((d, _), (cmap, emap)) => case d of DCon (_, n, _, c) => (IM.insert (cmap, n, sins cmap c), emap) | DDatatype dts => (foldl (fn ((_, n, _, xncs), cmap) => IM.insert (cmap, n, foldl (fn ((_, _, co), s) => case co of NONE => s | SOME c => PS.union (s, sins cmap c)) PS.empty xncs)) cmap dts, emap) | DVal (_, n, t, _, tag) => (cmap, IM.insert (emap, n, (t, tag))) | DValRec vis => (cmap, foldl (fn ((_, n, t, _, tag), emap) => IM.insert (emap, n, (t, tag))) emap vis) | DExport (_, n, _) => (case IM.find (emap, n) of NONE => raise Fail "MarshalCheck: Unknown export" | SOME (t, tag) => let fun makeS (t, _) = case t of TFun (dom, ran) => (case #1 dom of CFfi ("Basis", "postBody") => makeS ran | CApp ((CFfi ("Basis", "option"), _), (CFfi ("Basis", "queryString"), _)) => makeS ran | _ => PS.union (sins cmap dom, makeS ran)) | _ => PS.empty val s = makeS t in if PS.isEmpty s then () else E.error ("Input to exported function '" ^ tag ^ "' involves one or more types that are disallowed for page handler inputs: " ^ PS.toString s); (cmap, emap) end) | DCookie (_, _, t, tag) => let val s = sins cmap t in if PS.isEmpty s then () else E.error ("Cookie '" ^ tag ^ "' includes one or more types that are disallowed for cookies: " ^ PS.toString s); (cmap, emap) end | _ => (cmap, emap)) (IM.empty, IM.empty) file) end end