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
adam@2112:               | EFfiApp ("Basis", "getHeader", _) => true
adam@2112:               | EFfiApp ("Basis", "getenv", _) => 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