Mercurial > urweb

annotate src/effectize.sml @ 2164:728aaeea12fd

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Add a simple 'make test' target
author Adam Chlipala <adam@chlipala.net>
date Wed, 29 Jul 2015 10:08:03 -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