Only use cookie signatures when cookies might be read

5 files changed, 136 insertions, 76 deletions

diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 774b2b75..a47bb587 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -2227,14 +2227,17 @@ fun p_file env (ds, ps) =
 
         val fields = foldl (fn ((ek, _, _, ts, _, _), fields) =>
                                case ek of
-                                   Core.Link => fields
-                                 | Core.Rpc _ => fields
-                                 | Core.Action _ =>
+                                   Link => fields
+                                 | Rpc _ => fields
+                                 | Action eff =>
                                    case List.nth (ts, length ts - 2) of
                                        (TRecord i, _) =>
                                        let
                                            val xts = E.lookupStruct env i
-                                           val xts = (sigName xts, (TRecord 0, ErrorMsg.dummySpan)) :: xts
+                                           val xts = case eff of
+                                                         ReadCookieWrite =>
+                                                         (sigName xts, (TRecord 0, ErrorMsg.dummySpan)) :: xts
+                                                       | _ => xts
                                            val xtsSet = SS.addList (SS.empty, map #1 xts)
                                        in
                                            foldl (fn ((x, _), fields) =>
@@ -2424,10 +2427,26 @@ fun p_file env (ds, ps) =
                 fun couldWrite ek =
                     case ek of
                         Link => false
-                      | Action ef => ef = ReadWrite
-                      | Rpc ef => ef = ReadWrite
+                      | Action ef => ef = ReadCookieWrite
+                      | Rpc ef => ef = ReadCookieWrite
             in
-                box [if couldWrite ek then
+                box [string "if (!strncmp(request, \"",
+                     string (String.toString s),
+                     string "\", ",
+                     string (Int.toString (size s)),
+                     string ") && (request[",
+                     string (Int.toString (size s)),
+                     string "] == 0 || request[",
+                     string (Int.toString (size s)),
+                     string "] == '/')) {",
+                     newline,
+                     string "request += ",
+                     string (Int.toString (size s)),
+                     string ";",
+                     newline,
+                     string "if (*request == '/') ++request;",
+                     newline,
+                     if couldWrite ek then
                          box [string "{",
                               newline,
                               string "uw_Basis_string sig = ",
@@ -2450,23 +2469,6 @@ fun p_file env (ds, ps) =
                               newline]
                      else
                          box [],
-                     
-                     string "if (!strncmp(request, \"",
-                     string (String.toString s),
-                     string "\", ",
-                     string (Int.toString (size s)),
-                     string ") && (request[",
-                     string (Int.toString (size s)),
-                     string "] == 0 || request[",
-                     string (Int.toString (size s)),
-                     string "] == '/')) {",
-                     newline,
-                     string "request += ",
-                     string (Int.toString (size s)),
-                     string ";",
-                     newline,
-                     string "if (*request == '/') ++request;",
-                     newline,
                      box (case ek of
                               Core.Rpc _ => [string "uw_write_header(ctx, \"Content-type: text/plain\\r\\n\");",
                                              newline]
diff --git a/src/effectize.sml b/src/effectize.sml
index f33b4eb8..52fdec6d 100644
--- a/src/effectize.sml
+++ b/src/effectize.sml
@@ -37,7 +37,7 @@ structure SS = BinarySetFn(struct
                            val compare = String.compare
                            end)
 
-val effectful = ["dml", "nextval", "send"]
+val effectful = ["dml", "nextval", "send", "setCookie"]
 val effectful = SS.addList (SS.empty, effectful)
 
 fun effectize file =
@@ -54,21 +54,47 @@ fun effectize file =
                                            con = fn _ => false,
                                            exp = exp evs}
 
-        fun doDecl (d, evs) =
+        fun exp evs e =
+            case e of
+                EFfi ("Basis", "getCookie") => true
+              | ENamed n => IM.inDomain (evs, n)
+              | EServerCall (n, _, _, _) => IM.inDomain (evs, n)
+              | _ => false
+
+        fun couldReadCookie evs = U.Exp.exists {kind = fn _ => false,
+                                                con = fn _ => false,
+                                                exp = exp evs}
+
+        fun doDecl (d, evs as (writers, readers)) =
             case #1 d of
                 DVal (x, n, t, e, s) =>
-                (d, if couldWrite evs e then
-                        IM.insert (evs, n, (#2 d, s))
-                    else
-                        evs)
+                (d, (if couldWrite writers e then
+                         IM.insert (writers, n, (#2 d, s))
+                     else
+                         writers,
+                     if couldReadCookie readers e then
+                         IM.insert (readers, n, (#2 d, s))
+                     else
+                         readers))
               | DValRec vis =>
                 let
                     fun oneRound evs =
-                        foldl (fn ((_, n, _, e, s), (changed, evs)) =>
-                                if couldWrite evs e andalso not (IM.inDomain (evs, n)) then
-                                    (true, IM.insert (evs, n, (#2 d, s)))
-                                else
-                                    (changed, evs)) (false, evs) vis
+                        foldl (fn ((_, n, _, e, s), (changed, (writers, readers))) =>
+                                  let
+                                      val (changed, writers) =
+                                          if couldWrite writers e andalso not (IM.inDomain (writers, n)) then
+                                              (true, IM.insert (writers, n, (#2 d, s)))
+                                          else
+                                              (changed, writers)
+
+                                      val (changed, readers) =
+                                          if couldReadCookie readers e andalso not (IM.inDomain (readers, n)) then
+                                              (true, IM.insert (readers, n, (#2 d, s)))
+                                          else
+                                              (changed, readers)
+                                  in
+                                      (changed, (writers, readers))
+                                  end) (false, evs) vis
 
                     fun loop evs =
                         let
@@ -80,28 +106,34 @@ fun effectize file =
                                 evs
                         end
                 in
-                    (d, loop evs)
+                    (d, loop (writers, readers))
                 end
               | DExport (Link, n) =>
-                (case IM.find (evs, n) of
+                (case IM.find (writers, n) of
                      NONE => ()
                    | SOME (loc, s) => ErrorMsg.errorAt loc ("A link (" ^ s ^ ") could cause side effects; try implementing it with a form instead");
                  (d, evs))
               | DExport (Action _, n) =>
-                ((DExport (Action (if IM.inDomain (evs, n) then
-                                       ReadWrite
+                ((DExport (Action (if IM.inDomain (writers, n) then
+                                       if IM.inDomain (readers, n) then
+                                           ReadCookieWrite
+                                       else
+                                           ReadWrite
                                    else
                                        ReadOnly), n), #2 d),
                  evs)
               | DExport (Rpc _, n) =>
-                ((DExport (Rpc (if IM.inDomain (evs, n) then
-                                    ReadWrite
+                ((DExport (Rpc (if IM.inDomain (writers, n) then
+                                    if IM.inDomain (readers, n) then
+                                        ReadCookieWrite
+                                    else
+                                        ReadWrite
                                 else
                                     ReadOnly), n), #2 d),
                  evs)
               | _ => (d, evs)
 
-        val (file, _) = ListUtil.foldlMap doDecl IM.empty file
+        val (file, _) = ListUtil.foldlMap doDecl (IM.empty, IM.empty) file
     in
         file
     end
diff --git a/src/export.sig b/src/export.sig
index 4c46e751..0bbdd1ac 100644
--- a/src/export.sig
+++ b/src/export.sig
@@ -29,6 +29,7 @@ signature EXPORT = sig
 
 datatype effect =
          ReadOnly
+       | ReadCookieWrite
        | ReadWrite
 
 datatype export_kind =
diff --git a/src/export.sml b/src/export.sml
index 8e3e3331..ad604e16 100644
--- a/src/export.sml
+++ b/src/export.sml
@@ -25,13 +25,14 @@
  * POSSIBILITY OF SUCH DAMAGE.
  *)
 
-structure Export = struct
+structure Export :> EXPORT = struct
 
 open Print.PD
 open Print
 
 datatype effect =
          ReadOnly
+       | ReadCookieWrite
        | ReadWrite
 
 datatype export_kind =
@@ -42,6 +43,7 @@ datatype export_kind =
 fun p_effect ef =
     case ef of
         ReadOnly => string "r"
+      | ReadCookieWrite => string "rcw"
       | ReadWrite => string "rw"
 
 fun p_export_kind ck =
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)