Mercurial > urweb

changeset 2202:606af2c9b828

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Identifies tables read or touched by queries.
author Ziv Scully <ziv@mit.edu>
date Sat, 08 Mar 2014 05:06:22 -0500
parents 94529780bbcf
children 39faa4a037f4
files sqlcache-tests/test.ur sqlcache-tests/test.urp sqlcache-tests/test.urs src/compiler.sig src/compiler.sml src/sql.sml
diffstat 6 files changed, 126 insertions(+), 13 deletions(-) [+]
line wrap: on
line diff
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/sqlcache-tests/test.ur	Sat Mar 08 05:06:22 2014 -0500
@@ -0,0 +1,22 @@
+table foo : {Id : int, Bar : string} PRIMARY KEY Id
+
+(* val query = (SELECT * FROM foo WHERE foo.Bar = "baz") *)
+(* val insert = (INSERT INTO foo (Id, Bar) VALUES (42, "baz")) *)
+
+fun main () : transaction page =
+    dml (INSERT INTO foo (Id, Bar) VALUES (42, "baz"));
+    res <- oneOrNoRows (SELECT foo.Id, foo.Bar
+                        FROM foo
+                        WHERE foo.Bar = "baz"
+                          UNION
+                        SELECT *
+                        FROM foo
+                        WHERE foo.Bar = "qux");
+    return
+        <xml>
+          <body>
+            {case res of
+                 None => <xml></xml>
+               | Some row => <xml>{[row.Foo.Bar]}</xml>}
+          </body>
+        </xml>
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/sqlcache-tests/test.urp	Sat Mar 08 05:06:22 2014 -0500
@@ -0,0 +1,4 @@
+database dbname=test
+safeGet Test/main
+
+test
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/sqlcache-tests/test.urs	Sat Mar 08 05:06:22 2014 -0500
@@ -0,0 +1,1 @@
+val main : unit -> transaction page
--- a/src/compiler.sig	Fri Mar 07 11:50:45 2014 -0500
+++ b/src/compiler.sig	Sat Mar 08 05:06:22 2014 -0500
@@ -16,7 +16,7 @@
  * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
- * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
  * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
  * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
@@ -122,6 +122,7 @@
     val pathcheck : (Mono.file, Mono.file) phase
     val sidecheck : (Mono.file, Mono.file) phase
     val sigcheck : (Mono.file, Mono.file) phase
+    val sqlcache : (Mono.file, Mono.file) phase
     val cjrize : (Mono.file, Cjr.file) phase
     val prepare : (Cjr.file, Cjr.file) phase
     val checknest : (Cjr.file, Cjr.file) phase
@@ -137,12 +138,12 @@
     val toCorify : (string, Core.file) transform
     val toCore_untangle : (string, Core.file) transform
     val toShake1 : (string, Core.file) transform
-    val toEspecialize1' : (string, Core.file) transform 
+    val toEspecialize1' : (string, Core.file) transform
     val toShake1' : (string, Core.file) transform
     val toRpcify : (string, Core.file) transform
     val toCore_untangle2 : (string, Core.file) transform
     val toShake2 : (string, Core.file) transform
-    val toEspecialize1 : (string, Core.file) transform 
+    val toEspecialize1 : (string, Core.file) transform
     val toCore_untangle3 : (string, Core.file) transform
     val toShake3 : (string, Core.file) transform
     val toTag : (string, Core.file) transform
@@ -186,6 +187,7 @@
     val toPathcheck : (string, Mono.file) transform
     val toSidecheck : (string, Mono.file) transform
     val toSigcheck : (string, Mono.file) transform
+    val toSqlcache : (string, Mono.file) transform
     val toCjrize : (string, Cjr.file) transform
     val toPrepare : (string, Cjr.file) transform
     val toChecknest : (string, Cjr.file) transform
--- a/src/compiler.sml	Fri Mar 07 11:50:45 2014 -0500
+++ b/src/compiler.sml	Sat Mar 08 05:06:22 2014 -0500
@@ -16,7 +16,7 @@
  * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
- * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
  * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
  * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
@@ -25,7 +25,7 @@
  * POSSIBILITY OF SUCH DAMAGE.
  *)
 
-structure Compiler :> COMPILER = struct 
+structure Compiler :> COMPILER = struct
 
 structure UrwebLrVals = UrwebLrValsFn(structure Token = LrParser.Token)
 structure Lex = UrwebLexFn(structure Tokens = UrwebLrVals.Tokens)
@@ -268,7 +268,7 @@
                     | _ => absyn
               end
               handle LrParser.ParseError => [],
-     print = SourcePrint.p_file}    
+     print = SourcePrint.p_file}
 
 fun p_job ({prefix, database, exe, sql, sources, debug, profile,
             timeout, ffi, link, headers, scripts,
@@ -1090,7 +1090,7 @@
                                               ErrorMsg.error ("Rooted module " ^ full ^ " has multiple versions.")
                                           else
                                               ();
-                                          
+
                                           makeD true "" pieces
                                           before ignore (foldl (fn (new, path) =>
                                                                    let
@@ -1438,12 +1438,19 @@
 
 val toSigcheck = transform sigcheck "sigcheck" o toSidecheck
 
+val sqlcache = {
+    func = (fn file => (Sql.go file; file)),
+    print = MonoPrint.p_file MonoEnv.empty
+}
+
+val toSqlcache = transform sqlcache "sqlcache" o toSigcheck
+
 val cjrize = {
     func = Cjrize.cjrize,
     print = CjrPrint.p_file CjrEnv.empty
 }
 
-val toCjrize = transform cjrize "cjrize" o toSigcheck
+val toCjrize = transform cjrize "cjrize" o toSqlcache
 
 val prepare = {
     func = Prepare.prepare,
@@ -1596,7 +1603,7 @@
 
                      compileC {cname = cname, oname = oname, ename = ename, libs = libs,
                                profile = #profile job, debug = #debug job, linker = #linker job, link = #link job}
-                     
+
                      before cleanup ())
             end
             handle ex => (((cleanup ()) handle _ => ()); raise ex)
--- a/src/sql.sml	Fri Mar 07 11:50:45 2014 -0500
+++ b/src/sql.sml	Sat Mar 08 05:06:22 2014 -0500
@@ -2,7 +2,7 @@
 
 open Mono
 
-val debug = ref false
+val debug = ref true (*false*)
 
 type lvar = int
 
@@ -238,7 +238,7 @@
             end
         else
             NONE
-      | _ => NONE                            
+      | _ => NONE
 
 val prim =
     altL [wrap (follow (wrapP (follow (keep Char.isDigit) (follow (const ".") (keep Char.isDigit)))
@@ -267,7 +267,7 @@
                         ((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 @@
 
 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 @@
 
 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