summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-04-23 14:10:10 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-04-23 14:10:10 -0400
commit5ef3495dd44b076f46f4fdba4a021ea362116677 (patch)
tree5f9043f30674edd2b558719bbd85211d45b02297
parent777ba279e76f6d30de4d64948930ae0d0d17833c (diff)
Only use cookie signatures when cookies might be read
-rw-r--r--src/cjr_print.sml50
-rw-r--r--src/effectize.sml68
-rw-r--r--src/export.sig1
-rw-r--r--src/export.sml4
-rw-r--r--src/monoize.sml89
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)