Mercurial > urweb

comparison src/effectize.sml @ 735:5ccb67665d05

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
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 5819fb63c93a
children a28982de5645
comparison
equal deleted inserted replaced
734:f2a2be93331c 735:5ccb67665d05
35 structure SS = BinarySetFn(struct 35 structure SS = BinarySetFn(struct
36 type ord_key = string 36 type ord_key = string
37 val compare = String.compare 37 val compare = String.compare
38 end) 38 end)
39 39
40 val effectful = ["dml", "nextval", "send"] 40 val effectful = ["dml", "nextval", "send", "setCookie"]
41 val effectful = SS.addList (SS.empty, effectful) 41 val effectful = SS.addList (SS.empty, effectful)
42 42
43 fun effectize file = 43 fun effectize file =
44 let 44 let
45 fun exp evs e = 45 fun exp evs e =
52 52
53 fun couldWrite evs = U.Exp.exists {kind = fn _ => false, 53 fun couldWrite evs = U.Exp.exists {kind = fn _ => false,
54 con = fn _ => false, 54 con = fn _ => false,
55 exp = exp evs} 55 exp = exp evs}
56 56
57 fun doDecl (d, evs) = 57 fun exp evs e =
58 case e of
59 EFfi ("Basis", "getCookie") => true
60 | ENamed n => IM.inDomain (evs, n)
61 | EServerCall (n, _, _, _) => IM.inDomain (evs, n)
62 | _ => false
63
64 fun couldReadCookie evs = U.Exp.exists {kind = fn _ => false,
65 con = fn _ => false,
66 exp = exp evs}
67
68 fun doDecl (d, evs as (writers, readers)) =
58 case #1 d of 69 case #1 d of
59 DVal (x, n, t, e, s) => 70 DVal (x, n, t, e, s) =>
60 (d, if couldWrite evs e then 71 (d, (if couldWrite writers e then
61 IM.insert (evs, n, (#2 d, s)) 72 IM.insert (writers, n, (#2 d, s))
62 else 73 else
63 evs) 74 writers,
75 if couldReadCookie readers e then
76 IM.insert (readers, n, (#2 d, s))
77 else
78 readers))
64 | DValRec vis => 79 | DValRec vis =>
65 let 80 let
66 fun oneRound evs = 81 fun oneRound evs =
67 foldl (fn ((_, n, _, e, s), (changed, evs)) => 82 foldl (fn ((_, n, _, e, s), (changed, (writers, readers))) =>
68 if couldWrite evs e andalso not (IM.inDomain (evs, n)) then 83 let
69 (true, IM.insert (evs, n, (#2 d, s))) 84 val (changed, writers) =
70 else 85 if couldWrite writers e andalso not (IM.inDomain (writers, n)) then
71 (changed, evs)) (false, evs) vis 86 (true, IM.insert (writers, n, (#2 d, s)))
87 else
88 (changed, writers)
89
90 val (changed, readers) =
91 if couldReadCookie readers e andalso not (IM.inDomain (readers, n)) then
92 (true, IM.insert (readers, n, (#2 d, s)))
93 else
94 (changed, readers)
95 in
96 (changed, (writers, readers))
97 end) (false, evs) vis
72 98
73 fun loop evs = 99 fun loop evs =
74 let 100 let
75 val (b, evs) = oneRound evs 101 val (b, evs) = oneRound evs
76 in 102 in
78 loop evs 104 loop evs
79 else 105 else
80 evs 106 evs
81 end 107 end
82 in 108 in
83 (d, loop evs) 109 (d, loop (writers, readers))
84 end 110 end
85 | DExport (Link, n) => 111 | DExport (Link, n) =>
86 (case IM.find (evs, n) of 112 (case IM.find (writers, n) of
87 NONE => () 113 NONE => ()
88 | SOME (loc, s) => ErrorMsg.errorAt loc ("A link (" ^ s ^ ") could cause side effects; try implementing it with a form instead"); 114 | SOME (loc, s) => ErrorMsg.errorAt loc ("A link (" ^ s ^ ") could cause side effects; try implementing it with a form instead");
89 (d, evs)) 115 (d, evs))
90 | DExport (Action _, n) => 116 | DExport (Action _, n) =>
91 ((DExport (Action (if IM.inDomain (evs, n) then 117 ((DExport (Action (if IM.inDomain (writers, n) then
92 ReadWrite 118 if IM.inDomain (readers, n) then
119 ReadCookieWrite
120 else
121 ReadWrite
93 else 122 else
94 ReadOnly), n), #2 d), 123 ReadOnly), n), #2 d),
95 evs) 124 evs)
96 | DExport (Rpc _, n) => 125 | DExport (Rpc _, n) =>
97 ((DExport (Rpc (if IM.inDomain (evs, n) then 126 ((DExport (Rpc (if IM.inDomain (writers, n) then
98 ReadWrite 127 if IM.inDomain (readers, n) then
128 ReadCookieWrite
129 else
130 ReadWrite
99 else 131 else
100 ReadOnly), n), #2 d), 132 ReadOnly), n), #2 d),
101 evs) 133 evs)
102 | _ => (d, evs) 134 | _ => (d, evs)
103 135
104 val (file, _) = ListUtil.foldlMap doDecl IM.empty file 136 val (file, _) = ListUtil.foldlMap doDecl (IM.empty, IM.empty) file
105 in 137 in
106 file 138 file
107 end 139 end
108 140
109 end 141 end