From 0e1252d5a6330570df698df924a0554b688042e8 Mon Sep 17 00:00:00 2001
From: Ziv Scully <ziv@mit.edu>
Date: Sat, 8 Mar 2014 05:06:22 -0500
Subject: Identifies tables read or touched by queries.

---
 src/sql.sml | 85 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++---
 1 file changed, 81 insertions(+), 4 deletions(-)

(limited to 'src/sql.sml')

diff --git a/src/sql.sml b/src/sql.sml
index c314eb3d..601b3510 100644
--- a/src/sql.sml
+++ b/src/sql.sml
@@ -2,7 +2,7 @@ structure Sql = struct
 
 open Mono
 
-val debug = ref false
+val debug = ref true (*false*)
 
 type lvar = int
 
@@ -238,7 +238,7 @@ fun string chs =
             end
         else
             NONE
-      | _ => NONE                            
+      | _ => NONE
 
 val prim =
     altL [wrap (follow (wrapP (follow (keep Char.isDigit) (follow (const ".") (keep Char.isDigit)))
@@ -267,7 +267,7 @@ fun sqlify chs =
                         ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE), _),
                          (EPrim (Prim.String "FALSE"), _))], _), _) :: chs =>
         SOME (e, chs)
-                          
+
       | _ => NONE
 
 fun constK s = wrap (const s) (fn () => s)
@@ -317,7 +317,7 @@ fun sqexp chs =
 
 and known chs = wrap (follow known' (follow (const "(") (follow sqexp (const ")"))))
                      (fn ((), ((), (e, ()))) => e) chs
-                
+
 and func chs = wrap (follow funcName (follow (const "(") (follow sqexp (const ")"))))
                     (fn (f, ((), (e, ()))) => (f, e)) chs
 
@@ -425,4 +425,81 @@ datatype querydml =
 
 val querydml = log "querydml" (altL [wrap dml Dml, wrap query Query])
 
+(* New stuff. *)
+
+fun subExps' (exp' : Mono.exp') =
+    case exp' of
+        ECon (_,_,SOME exp) => [exp]
+      | ESome (_,exp) => [exp]
+      | EFfiApp (_,_,xs) => map #1 xs
+      | EApp (exp1,exp2) => [exp1, exp2]
+      | EAbs (_,_,_,exp) => [exp]
+      | EUnop (_,exp) => [exp]
+      | EBinop (_,_,exp1,exp2) => [exp1, exp2]
+      | ERecord xs => map #2 xs
+      | EField (exp,_) => [exp]
+      | ECase (exp,xs,_) => exp :: map #2 xs
+      | EStrcat (exp1,exp2) => [exp1,exp2]
+      | EError (exp,_) => [exp]
+      | EReturnBlob {blob=NONE, mimeType, ...} => [mimeType]
+      | EReturnBlob {blob=SOME exp, mimeType, ...} => [exp, mimeType]
+      | ERedirect (exp,_) => [exp]
+      | EWrite exp => [exp]
+      | ESeq (exp1,exp2) => [exp1, exp2]
+      | ELet (_,_,exp1,exp2) => [exp1, exp2]
+      | EClosure (_,xs) => xs
+      | EQuery {query, body, initial, ...} => [query, body, initial]
+      | EDml (exp,_) => [exp]
+      | ENextval exp => [exp]
+      | ESetval (exp1,exp2) => [exp1, exp2]
+      | EUnurlify (exp,_,_) => [exp]
+      | EJavaScript (_,exp) => [exp]
+      | ESignalReturn exp => [exp]
+      | ESignalBind (exp1,exp2) => [exp1, exp2]
+      | ESignalSource exp => [exp]
+      | EServerCall (exp,_,_,_) => [exp]
+      | ERecv (exp,_) => [exp]
+      | ESleep exp => [exp]
+      | ESpawn exp => [exp]
+      | _ => []
+
+val subExps : Mono.exp -> Mono.exp list = subExps' o #1
+
+fun println str = print (str ^ "\n")
+fun printlnExp exp = (Print.print (MonoPrint.p_exp MonoEnv.empty exp); println "")
+
+fun tablesRead (Query1 {From=tablePairs, ...}) = map #1 tablePairs
+  | tablesRead (Union (q1,q2)) = tablesRead q1 @ tablesRead q2
+
+fun tableTouched (Insert (tab,_)) = tab
+  | tableTouched (Delete (tab,_)) = tab
+  | tableTouched (Update (tab,_,_)) = tab
+
+fun goExp (exp : Mono.exp) =
+    case #1 exp of
+        EQuery {query=e, ...} => (
+         case parse query e of
+             SOME q => println ("Query reads from " ^ String.concatWith ", " (tablesRead q))
+           | NONE => println "Couldn't parse query";
+         printlnExp exp; println "")
+      | EDml (e,_) => (
+          case parse dml e of
+              SOME d => println ("DML touches " ^ tableTouched d)
+            | NONE => println "Couldn't parse DML";
+          printlnExp exp; println "")
+      | ENextval _ => (printlnExp exp; println "")
+      | ESetval _ => (printlnExp exp; println "")
+      (* Recurse down the syntax tree. *)
+      | _ => app goExp (subExps exp)
+
+fun goDecl (decl : decl) =
+    case #1 decl of
+        DVal (_,_,_,exp,_) => goExp exp
+      | DValRec xs => app (goExp o #4) xs
+      | _ => ()
+
+fun goFile (file : file) = app goDecl (#1 file)
+
+fun go file = (println "Doing SQL analysis.\n"; goFile file; ())
+
 end
-- 
cgit v1.2.3