diff src/cjr_print.sml @ 735:5ccb67665d05

Only use cookie signatures when cookies might be read
author Adam Chlipala <adamc@hcoop.net>
date Thu, 23 Apr 2009 14:10:10 -0400
parents f2a2be93331c
children 796e42c93c48
line wrap: on
line diff
--- a/src/cjr_print.sml	Thu Apr 16 19:12:12 2009 -0400
+++ b/src/cjr_print.sml	Thu Apr 23 14:10:10 2009 -0400
@@ -2227,14 +2227,17 @@
 
         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 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 @@
                               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]