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