Mercurial > urweb

annotate src/effectize.sml @ 2258:b1ba35ce2613

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fix bug where pure caching didn't treat FFI applications as effectful.
author Ziv Scully <ziv@mit.edu>
date Sun, 27 Sep 2015 17:02:14 -0400
parents b4702145f8de
children
rev   line source
adam@1848 1 (* Copyright (c) 2009-2010, 2013, Adam Chlipala
adamc@732 2 * All rights reserved.
adamc@732 3 *
adamc@732 4 * Redistribution and use in source and binary forms, with or without
adamc@732 5 * modification, are permitted provided that the following conditions are met:
adamc@732 6 *
adamc@732 7 * - Redistributions of source code must retain the above copyright notice,
adamc@732 8 * this list of conditions and the following disclaimer.
adamc@732 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@732 10 * this list of conditions and the following disclaimer in the documentation
adamc@732 11 * and/or other materials provided with the distribution.
adamc@732 12 * - The names of contributors may not be used to endorse or promote products
adamc@732 13 * derived from this software without specific prior written permission.
adamc@732 14 *
adamc@732 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@732 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@732 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@732 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@732 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@732 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@732 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@732 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@732 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@732 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@732 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@732 26 *)
adamc@732 27
adamc@732 28 structure Effective :> EFFECTIZE = struct
adamc@732 29
adamc@732 30 open Core
adamc@732 31
adamc@732 32 structure U = CoreUtil
adamc@732 33
adamc@732 34 structure IM = IntBinaryMap
adamc@732 35 structure SS = BinarySetFn(struct
adamc@732 36 type ord_key = string
adamc@732 37 val compare = String.compare
adamc@732 38 end)
adamc@732 39
adamc@765 40 fun effectful x = Settings.isEffectful x andalso not (Settings.isClientOnly x)
adamc@732 41
adamc@732 42 fun effectize file =
adamc@732 43 let
adamc@782 44 fun expOnload evs e =
adamc@782 45 case e of
adamc@782 46 EFfi f => effectful f
adamc@782 47 | EFfiApp (m, x, _) => effectful (m, x)
adamc@782 48 | ENamed n => IM.inDomain (evs, n)
adam@1848 49 | EServerCall (n, _, _, _) => IM.inDomain (evs, n)
adamc@782 50 | _ => false
adamc@782 51
adamc@782 52 fun couldWriteOnload evs = U.Exp.exists {kind = fn _ => false,
adamc@782 53 con = fn _ => false,
adamc@782 54 exp = expOnload evs}
adamc@782 55
adamc@732 56 fun exp evs e =
adamc@732 57 case e of
adamc@765 58 EFfi f => effectful f
adamc@765 59 | EFfiApp (m, x, _) => effectful (m, x)
adamc@732 60 | ENamed n => IM.inDomain (evs, n)
adamc@782 61 | ERecord xets => List.exists (fn ((CName "Onload", _), e, _) => couldWriteOnload evs e
adamc@782 62 | _ => false) xets
adamc@732 63 | _ => false
adamc@732 64
adamc@732 65 fun couldWrite evs = U.Exp.exists {kind = fn _ => false,
adamc@732 66 con = fn _ => false,
adamc@732 67 exp = exp evs}
adamc@732 68
adam@1361 69 fun exp writers readers pushers e =
adamc@1104 70 case e of
adam@1361 71 ENamed n => IM.inDomain (pushers, n)
adam@1848 72 | EServerCall (n, _, _, _) => IM.inDomain (writers, n) andalso IM.inDomain (readers, n)
adamc@1104 73 | _ => false
adamc@1104 74
adam@1361 75 fun couldWriteWithRpc writers readers pushers = U.Exp.exists {kind = fn _ => false,
adam@1361 76 con = fn _ => false,
adam@1361 77 exp = exp writers readers pushers}
adamc@1104 78
adamc@735 79 fun exp evs e =
adamc@735 80 case e of
adamc@735 81 EFfi ("Basis", "getCookie") => true
adam@2112 82 | EFfiApp ("Basis", "getHeader", _) => true
adam@2112 83 | EFfiApp ("Basis", "getenv", _) => true
adamc@735 84 | ENamed n => IM.inDomain (evs, n)
adam@1848 85 | EServerCall (n, _, _, _) => IM.inDomain (evs, n)
adamc@735 86 | _ => false
adamc@735 87
adamc@735 88 fun couldReadCookie evs = U.Exp.exists {kind = fn _ => false,
adamc@735 89 con = fn _ => false,
adamc@735 90 exp = exp evs}
adamc@735 91
adam@1433 92 val dejs = U.Exp.map {kind = fn x => x,
adam@1433 93 con = fn c => c,
adam@1433 94 exp = fn ERecord xets => ERecord (List.filter (fn ((CName x, _), _ , _) => x = "Onload" orelse not (String.isPrefix "On" x)
adam@1433 95 | _ => true) xets)
adam@1433 96 | e => e}
adam@1433 97
adamc@1104 98 fun doDecl (d, evs as (writers, readers, pushers)) =
adamc@732 99 case #1 d of
adamc@732 100 DVal (x, n, t, e, s) =>
adam@1433 101 let
adam@1438 102 val e' = dejs e
adam@1433 103 in
adam@1438 104 (d, (if couldWrite writers e' then
adam@1433 105 IM.insert (writers, n, (#2 d, s))
adam@1433 106 else
adam@1433 107 writers,
adam@1438 108 if couldReadCookie readers e' then
adam@1433 109 IM.insert (readers, n, (#2 d, s))
adam@1433 110 else
adam@1433 111 readers,
adam@1433 112 if couldWriteWithRpc writers readers pushers e then
adam@1433 113 IM.insert (pushers, n, (#2 d, s))
adam@1433 114 else
adam@1433 115 pushers))
adam@1433 116 end
adamc@732 117 | DValRec vis =>
adamc@732 118 let
adamc@732 119 fun oneRound evs =
adamc@1104 120 foldl (fn ((_, n, _, e, s), (changed, (writers, readers, pushers))) =>
adamc@735 121 let
adam@1438 122 val e' = dejs e
adam@1433 123
adamc@735 124 val (changed, writers) =
adam@1438 125 if couldWrite writers e' andalso not (IM.inDomain (writers, n)) then
adamc@735 126 (true, IM.insert (writers, n, (#2 d, s)))
adamc@735 127 else
adamc@735 128 (changed, writers)
adamc@735 129
adamc@735 130 val (changed, readers) =
adam@1438 131 if couldReadCookie readers e' andalso not (IM.inDomain (readers, n)) then
adamc@735 132 (true, IM.insert (readers, n, (#2 d, s)))
adamc@735 133 else
adamc@735 134 (changed, readers)
adamc@1104 135
adamc@1104 136 val (changed, pushers) =
adam@1361 137 if couldWriteWithRpc writers readers pushers e
adamc@1104 138 andalso not (IM.inDomain (pushers, n)) then
adamc@1104 139 (true, IM.insert (pushers, n, (#2 d, s)))
adamc@1104 140 else
adamc@1104 141 (changed, pushers)
adamc@735 142 in
adamc@1104 143 (changed, (writers, readers, pushers))
adamc@735 144 end) (false, evs) vis
adamc@732 145
adamc@732 146 fun loop evs =
adamc@732 147 let
adamc@732 148 val (b, evs) = oneRound evs
adamc@732 149 in
adamc@732 150 if b then
adamc@732 151 loop evs
adamc@732 152 else
adamc@732 153 evs
adamc@732 154 end
adamc@732 155 in
adamc@1104 156 (d, loop (writers, readers, pushers))
adamc@732 157 end
adam@1936 158 | DExport (Link _, n, t) =>
adamc@735 159 (case IM.find (writers, n) of
adamc@732 160 NONE => ()
adamc@1183 161 | SOME (loc, s) =>
adamc@1183 162 if Settings.isSafeGet s then
adamc@1183 163 ()
adamc@1183 164 else
adam@1860 165 ErrorMsg.errorAt loc ("A handler (URI prefix \"" ^ s
adam@1860 166 ^ "\") accessible via GET could cause side effects; try accessing it only via forms, removing it from the signature of the main program module, or whitelisting it with the 'safeGet' .urp directive");
adam@1936 167 ((DExport (Link (if IM.inDomain (writers, n) then
adam@1936 168 if IM.inDomain (readers, n) then
adam@1936 169 ReadCookieWrite
adam@1936 170 else
adam@1936 171 ReadWrite
adam@1936 172 else
adam@1936 173 ReadOnly), n, IM.inDomain (pushers, n)), #2 d), evs))
adamc@1104 174 | DExport (Action _, n, _) =>
adamc@735 175 ((DExport (Action (if IM.inDomain (writers, n) then
adamc@735 176 if IM.inDomain (readers, n) then
adamc@735 177 ReadCookieWrite
adamc@735 178 else
adamc@735 179 ReadWrite
adamc@732 180 else
adamc@1104 181 ReadOnly), n, IM.inDomain (pushers, n)), #2 d),
adamc@732 182 evs)
adamc@1104 183 | DExport (Rpc _, n, _) =>
adamc@735 184 ((DExport (Rpc (if IM.inDomain (writers, n) then
adamc@735 185 if IM.inDomain (readers, n) then
adamc@735 186 ReadCookieWrite
adamc@735 187 else
adamc@735 188 ReadWrite
adamc@732 189 else
adamc@1104 190 ReadOnly), n, IM.inDomain (pushers, n)), #2 d),
adamc@732 191 evs)
adam@1347 192 | DExport (Extern _, n, _) =>
adam@1347 193 ((DExport (Extern (if IM.inDomain (writers, n) then
adam@1347 194 if IM.inDomain (readers, n) then
adam@1347 195 ReadCookieWrite
adam@1347 196 else
adam@1347 197 ReadWrite
adam@1347 198 else
adam@1347 199 ReadOnly), n, IM.inDomain (pushers, n)), #2 d),
adam@1347 200 evs)
adamc@732 201 | _ => (d, evs)
adamc@732 202
adamc@1104 203 val (file, _) = ListUtil.foldlMap doDecl (IM.empty, IM.empty, IM.empty) file
adamc@732 204 in
adamc@732 205 file
adamc@732 206 end
adamc@732 207
adamc@732 208 end