From 1c5416512d92309bb3f6a98f439edaf5a21d2318 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Thu, 23 Apr 2009 14:10:10 -0400
Subject: Only use cookie signatures when cookies might be read

---
 src/monoize.sml | 89 ++++++++++++++++++++++++++++++++++++---------------------
 1 file changed, 56 insertions(+), 33 deletions(-)

(limited to 'src/monoize.sml')

diff --git a/src/monoize.sml b/src/monoize.sml
index a979e5ed..5a164831 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -34,6 +34,7 @@ structure L = Core
 structure L' = Mono
 
 structure IM = IntBinaryMap
+structure IS = IntBinarySet
 
 val urlPrefix = ref "/"
 
@@ -538,6 +539,8 @@ fun strcatComma loc es =
 
 fun strcatR loc e xs = strcatComma loc (map (fn (x, _) => (L'.EField (e, x), loc)) xs)
 
+val readCookie = ref IS.empty
+
 fun monoExp (env, st, fm) (all as (e, loc)) =
     let
         val strcat = strcat loc
@@ -2453,53 +2456,64 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                            | _ => findSubmit xml)
                       | _ => NotFound
 
-                val (action, fm) = case findSubmit xml of
-                    NotFound => ((L'.EPrim (Prim.String ""), loc), fm)
+                val (func, action, fm) = case findSubmit xml of
+                    NotFound => (0, (L'.EPrim (Prim.String ""), loc), fm)
                   | Error => raise Fail "Not ready for multi-submit lforms yet"
                   | Found (action, actionT) =>
                     let
+                        val func = case #1 action of
+                                       L.EClosure (n, _) => n
+                                     | _ => raise Fail "Monoize: Action is not a closure"
                         val actionT = monoType env actionT
                         val (action, fm) = monoExp (env, st, fm) action
                         val (action, fm) = urlifyExp env fm (action, actionT)
                     in
-                        ((L'.EStrcat ((L'.EPrim (Prim.String " action=\""), loc),
+                        (func,
+                         (L'.EStrcat ((L'.EPrim (Prim.String " action=\""), loc),
                                       (L'.EStrcat (action,
                                                    (L'.EPrim (Prim.String "\""), loc)), loc)), loc),
                          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 (xml, fm) = monoExp (env, st, fm) xml
 
-                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 =
+                    if IS.member (!readCookie, func) then
+                        let
+                            fun inFields s = List.exists (fn ((L.CName s', _), _) => s' = s
+                                                           | _ => true) fields
 
-                val (xml, fm) = monoExp (env, st, fm) xml
-                val xml = (L'.EStrcat (sigSet, xml), loc)
+                            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)
+                        in
+                            (L'.EStrcat (sigSet, xml), loc)
+                        end
+                    else
+                        xml
             in
                 ((L'.EStrcat ((L'.EStrcat ((L'.EPrim (Prim.String "<form method=\"post\""), loc),
                                            (L'.EStrcat (action,
@@ -2793,6 +2807,15 @@ fun monoize env file =
             else
                 ()
 
+        (* Calculate which exported functions need cookie signature protection *)
+        val rcook = foldl (fn ((d, _), rcook) =>
+                              case d of
+                                  L.DExport (L.Action L.ReadCookieWrite, n) => IS.add (rcook, n)
+                                | L.DExport (L.Rpc L.ReadCookieWrite, n) => IS.add (rcook, n)
+                                | _ => rcook)
+                          IS.empty file
+        val () = readCookie := rcook
+
         val loc = E.dummySpan
         val client = (L'.TFfi ("Basis", "client"), loc)
         val unit = (L'.TRecord [], loc)
-- 
cgit v1.2.3