adamc@643: (* Copyright (c) 2009, Adam Chlipala
adamc@643:  * All rights reserved.
adamc@643:  *
adamc@643:  * Redistribution and use in source and binary forms, with or without
adamc@643:  * modification, are permitted provided that the following conditions are met:
adamc@643:  *
adamc@643:  * - Redistributions of source code must retain the above copyright notice,
adamc@643:  *   this list of conditions and the following disclaimer.
adamc@643:  * - Redistributions in binary form must reproduce the above copyright notice,
adamc@643:  *   this list of conditions and the following disclaimer in the documentation
adamc@643:  *   and/or other materials provided with the distribution.
adamc@643:  * - The names of contributors may not be used to endorse or promote products
adamc@643:  *   derived from this software without specific prior written permission.
adamc@643:  *
adamc@643:  * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@643:  * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@643:  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@643:  * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@643:  * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
adamc@643:  * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@643:  * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@643:  * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@643:  * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@643:  * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@643:  * POSSIBILITY OF SUCH DAMAGE.
adamc@643:  *)
adamc@643: 
adamc@643: structure ScriptCheck :> SCRIPT_CHECK = struct
adamc@643: 
adamc@643: open Cjr
adamc@643: 
adamc@643: structure SS = BinarySetFn(struct
adamc@643:                            type ord_key = string
adamc@643:                            val compare = String.compare
adamc@643:                            end)
adamc@643: structure IS = IntBinarySet
adamc@643: 
adamc@643: val csBasis = SS.addList (SS.empty,
adamc@643:                           ["new_client_source",
adamc@643:                            "get_client_source",
adamc@643:                            "set_client_source",
adamc@643:                            "alert"])
adamc@643: 
adamc@643: fun classify (ds, ps) =
adamc@643:     let
adamc@643:         fun inString {needle, haystack} =
adamc@643:             let
adamc@643:                 val (_, suffix) = Substring.position needle (Substring.full haystack)
adamc@643:             in
adamc@643:                 not (Substring.isEmpty suffix)
adamc@643:             end
adamc@643: 
adamc@643:         fun hasClient csids =
adamc@643:             let
adamc@643:                 fun hasClient e =
adamc@643:                     case #1 e of
adamc@643:                         EPrim (Prim.String s) => inString {needle = "<script", haystack = s}
adamc@643:                       | EPrim _ => false
adamc@643:                       | ERel _ => false
adamc@643:                       | ENamed n => IS.member (csids, n)
adamc@643:                       | ECon (_, _, NONE) => false
adamc@643:                       | ECon (_, _, SOME e) => hasClient e
adamc@643:                       | ENone _ => false
adamc@643:                       | ESome (_, e) => hasClient e
adamc@643:                       | EFfi ("Basis", x) => SS.member (csBasis, x)
adamc@643:                       | EFfi _ => false
adamc@643:                       | EFfiApp ("Basis", x, es) => SS.member (csBasis, x)
adamc@643:                                                     orelse List.exists hasClient es
adamc@643:                       | EFfiApp (_, _, es) => List.exists hasClient es
adamc@643:                       | EApp (e, es) => hasClient e orelse List.exists hasClient es
adamc@643:                       | EUnop (_, e) => hasClient e
adamc@643:                       | EBinop (_, e1, e2) => hasClient e1 orelse hasClient e2
adamc@643:                       | ERecord (_, xes) => List.exists (hasClient o #2) xes
adamc@643:                       | EField (e, _) => hasClient e
adamc@643:                       | ECase (e, pes, _) => hasClient e orelse List.exists (hasClient o #2) pes
adamc@643:                       | EError (e, _) => hasClient e
adamc@643:                       | EWrite e => hasClient e
adamc@643:                       | ESeq (e1, e2) => hasClient e1 orelse hasClient e2
adamc@643:                       | ELet (_, _, e1, e2) => hasClient e1 orelse hasClient e2
adamc@643:                       | EQuery {query, body, initial, ...} => hasClient query orelse hasClient body
adamc@643:                                                               orelse hasClient initial
adamc@643:                       | EDml {dml, ...} => hasClient dml
adamc@643:                       | ENextval {seq, ...} => hasClient seq
adamc@643:                       | EUnurlify (e, _) => hasClient e
adamc@643:             in
adamc@643:                 hasClient
adamc@643:             end
adamc@643: 
adamc@643:         fun decl ((d, _), csids) =
adamc@643:             let
adamc@643:                 val hasClient = hasClient csids
adamc@643:             in
adamc@643:                 case d of
adamc@643:                     DVal (_, n, _, e) => if hasClient e then
adamc@643:                                              IS.add (csids, n)
adamc@643:                                          else
adamc@643:                                              csids
adamc@643:                   | DFun (_, n, _, _, e) => if hasClient e then
adamc@643:                                                 IS.add (csids, n)
adamc@643:                                             else
adamc@643:                                                 csids
adamc@643:                   | DFunRec xes => if List.exists (fn (_, _, _, _, e) => hasClient e) xes then
adamc@643:                                        foldl (fn ((_, n, _, _, _), csids) => IS.add (csids, n))
adamc@643:                                              csids xes
adamc@643:                                    else
adamc@643:                                        csids
adamc@643:                   | _ => csids
adamc@643:             end
adamc@643: 
adamc@643:         val csids = foldl decl IS.empty ds
adamc@643: 
adamc@643:         val ps = map (fn (ek, x, n, ts, t, _) =>
adamc@643:                          (ek, x, n, ts, t,
adamc@643:                           if IS.member (csids, n) then
adamc@643:                               ServerAndClient
adamc@643:                           else
adamc@643:                               ServerOnly)) ps
adamc@643:     in
adamc@643:         (ds, ps)
adamc@643:     end
adamc@643: 
adamc@643: end
adamc@643: