diff options
| -rw-r--r-- | src/marshalcheck.sml | 135 | ||||
| -rw-r--r-- | tests/serializingXml.ur | 14 |
2 files changed, 94 insertions, 55 deletions
diff --git a/src/marshalcheck.sml b/src/marshalcheck.sml index 8d7edd15..122d3415 100644 --- a/src/marshalcheck.sml +++ b/src/marshalcheck.sml @@ -71,62 +71,87 @@ fun check file = | _ => st fun sins cmap = U.Con.fold {kind = kind, con = con cmap} PS.empty + + fun decl (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) + + fun checkSins (cmap, _) t = + let + val s = sins cmap t + in + if PS.isEmpty s then + () + else + E.error ("Not allowed to [de]serialize a value involving one or more disallowed types: " ^ PS.toString s) + end + + fun exp (e, s) = + case e of + ECApp ((EFfi ("Basis", "serialize"), _), t) => + (checkSins s t; s) + | ECApp ((EFfi ("Basis", "deserialize"), _), t) => + (checkSins s t; s) + | _ => s + + fun passthrough (_, s) = s 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) + ignore (U.File.fold {kind = passthrough, + con = passthrough, + exp = exp, + decl = decl} + (IM.empty, IM.empty) file) end end diff --git a/tests/serializingXml.ur b/tests/serializingXml.ur new file mode 100644 index 00000000..34eb3436 --- /dev/null +++ b/tests/serializingXml.ur @@ -0,0 +1,14 @@ +fun alerts n = + if n <= 0 then + return () + else + (alert ("Alert #" ^ show n); + alerts (n - 1)) + +cookie uhoh : serialized xbody + +fun main () : transaction page = + setCookie uhoh {Value = serialize <xml><active code={alerts 3; return <xml>Yay!</xml>}/></xml>, + Expires = None, + Secure = False}; + return <xml></xml> |