Mercurial > urweb
diff src/monoize.sml @ 734:f2a2be93331c
Cookie signing working for forms
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Thu, 16 Apr 2009 19:12:12 -0400 |
| parents | 1b1047992ecf |
| children | 5ccb67665d05 |
line wrap: on
line diff
--- a/src/monoize.sml Thu Apr 16 15:38:01 2009 -0400 +++ b/src/monoize.sml Thu Apr 16 19:12:12 2009 -0400 @@ -2399,7 +2399,7 @@ | L.EApp ((L.ECApp ( (L.ECApp ((L.EFfi ("Basis", "form"), _), _), _), - _), _), + (L.CRecord (_, fields), _)), _), xml) => let fun findSubmit (e, _) = @@ -2468,7 +2468,38 @@ fm) end + fun inFields s = List.exists (fn ((L.CName s', _), _) => s' = s + | _ => true) fields + + fun getSigName () = + let + fun getSigName' n = + let + val s = "Sig" ^ Int.toString n + in + if inFields s then + getSigName' (n + 1) + else + s + end + in + if inFields "Sig" then + getSigName' 0 + else + "Sig" + end + + val sigName = getSigName () + val sigSet = (L'.EFfiApp ("Basis", "sigString", [(L'.ERecord [], loc)]), loc) + val sigSet = (L'.EStrcat ((L'.EPrim (Prim.String ("<input type=\"hidden\" name=\"" + ^ sigName + ^ "\" value=\"")), loc), + sigSet), loc) + val sigSet = (L'.EStrcat (sigSet, + (L'.EPrim (Prim.String "\">"), loc)), loc) + val (xml, fm) = monoExp (env, st, fm) xml + val xml = (L'.EStrcat (sigSet, xml), loc) in ((L'.EStrcat ((L'.EStrcat ((L'.EPrim (Prim.String "<form method=\"post\""), loc), (L'.EStrcat (action,