diff options
author | Adam Chlipala <adamc@hcoop.net> | 2009-04-23 14:10:10 -0400 |
---|---|---|
committer | Adam Chlipala <adamc@hcoop.net> | 2009-04-23 14:10:10 -0400 |
commit | 5ef3495dd44b076f46f4fdba4a021ea362116677 (patch) | |
tree | 5f9043f30674edd2b558719bbd85211d45b02297 | |
parent | 777ba279e76f6d30de4d64948930ae0d0d17833c (diff) |
Only use cookie signatures when cookies might be read
-rw-r--r-- | src/cjr_print.sml | 50 | ||||
-rw-r--r-- | src/effectize.sml | 68 | ||||
-rw-r--r-- | src/export.sig | 1 | ||||
-rw-r--r-- | src/export.sml | 4 | ||||
-rw-r--r-- | src/monoize.sml | 89 |
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) |