(* Copyright (c) 2009-2010, 2013, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are met: * * - Redistributions of source code must retain the above copyright notice, * this list of conditions and the following disclaimer. * - Redistributions in binary form must reproduce the above copyright notice, * this list of conditions and the following disclaimer in the documentation * and/or other materials provided with the distribution. * - The names of contributors may not be used to endorse or promote products * derived from this software without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE * POSSIBILITY OF SUCH DAMAGE. *) structure Effective :> EFFECTIZE = struct open Core structure U = CoreUtil structure IM = IntBinaryMap structure SS = BinarySetFn(struct type ord_key = string val compare = String.compare end) fun effectful x = Settings.isEffectful x andalso not (Settings.isClientOnly x) fun effectize file = let fun expOnload evs e = case e of EFfi f => effectful f | EFfiApp (m, x, _) => effectful (m, x) | ENamed n => IM.inDomain (evs, n) | EServerCall (n, _, _, _) => IM.inDomain (evs, n) | _ => false fun couldWriteOnload evs = U.Exp.exists {kind = fn _ => false, con = fn _ => false, exp = expOnload evs} fun exp evs e = case e of EFfi f => effectful f | EFfiApp (m, x, _) => effectful (m, x) | ENamed n => IM.inDomain (evs, n) | ERecord xets => List.exists (fn ((CName "Onload", _), e, _) => couldWriteOnload evs e | _ => false) xets | _ => false fun couldWrite evs = U.Exp.exists {kind = fn _ => false, con = fn _ => false, exp = exp evs} fun exp writers readers pushers e = case e of ENamed n => IM.inDomain (pushers, n) | EServerCall (n, _, _, _) => IM.inDomain (writers, n) andalso IM.inDomain (readers, n) | _ => false fun couldWriteWithRpc writers readers pushers = U.Exp.exists {kind = fn _ => false, con = fn _ => false, exp = exp writers readers pushers} fun exp evs e = case e of EFfi ("Basis", "getCookie") => true | EFfiApp ("Basis", "getHeader", _) => true | EFfiApp ("Basis", "getenv", _) => 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} val dejs = U.Exp.map {kind = fn x => x, con = fn c => c, exp = fn ERecord xets => ERecord (List.filter (fn ((CName x, _), _ , _) => x = "Onload" orelse not (String.isPrefix "On" x) | _ => true) xets) | e => e} fun doDecl (d, evs as (writers, readers, pushers)) = case #1 d of DVal (x, n, t, e, s) => let val e' = dejs e in (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, if couldWriteWithRpc writers readers pushers e then IM.insert (pushers, n, (#2 d, s)) else pushers)) end | DValRec vis => let fun oneRound evs = foldl (fn ((_, n, _, e, s), (changed, (writers, readers, pushers))) => let val e' = dejs e 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) val (changed, pushers) = if couldWriteWithRpc writers readers pushers e andalso not (IM.inDomain (pushers, n)) then (true, IM.insert (pushers, n, (#2 d, s))) else (changed, pushers) in (changed, (writers, readers, pushers)) end) (false, evs) vis fun loop evs = let val (b, evs) = oneRound evs in if b then loop evs else evs end in (d, loop (writers, readers, pushers)) end | DExport (Link _, n, t) => (case IM.find (writers, n) of NONE => () | SOME (loc, s) => if Settings.isSafeGet s then () else ErrorMsg.errorAt loc ("A handler (URI prefix \"" ^ s ^ "\") 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"); ((DExport (Link (if IM.inDomain (writers, n) then if IM.inDomain (readers, n) then ReadCookieWrite else ReadWrite else ReadOnly), n, IM.inDomain (pushers, n)), #2 d), evs)) | DExport (Action _, n, _) => ((DExport (Action (if IM.inDomain (writers, n) then if IM.inDomain (readers, n) then ReadCookieWrite else ReadWrite else ReadOnly), n, IM.inDomain (pushers, n)), #2 d), evs) | DExport (Rpc _, n, _) => ((DExport (Rpc (if IM.inDomain (writers, n) then if IM.inDomain (readers, n) then ReadCookieWrite else ReadWrite else ReadOnly), n, IM.inDomain (pushers, n)), #2 d), evs) | DExport (Extern _, n, _) => ((DExport (Extern (if IM.inDomain (writers, n) then if IM.inDomain (readers, n) then ReadCookieWrite else ReadWrite else ReadOnly), n, IM.inDomain (pushers, n)), #2 d), evs) | _ => (d, evs) val (file, _) = ListUtil.foldlMap doDecl (IM.empty, IM.empty, IM.empty) file in file end end