Add genertive test for sqlite backend

Author: Andy Chambers

env/profiling/hitchhiker/bench.clj

@@ -196,77 +196,76 @@
 
 (defn -main
   [& [root & args]]
-  (jdbc/with-db-connection [db (sqlite/db-spec ":memory:")]
-    (let [outputs (atom [])]
-      (doseq [args (or (->> args
-                            (partition-by #(= % "--"))
-                            (map-indexed vector)
-                            (filter (comp even? first))
-                            (map second)
-                            (seq))
-                       [[]])] ; always do one iteration
-        (let [{:keys [options arguments errors summary]} (parse-opts args options)
-              tree-to-test (atom {})
-              results (atom [])]
-          (cond
-            (or (= "-h" root)
-                (= "--help" root)
-                (nil? root)
-                (:help options)) (exit 0 (usage summary))
-            (not= (count arguments) 0) (exit 1 (usage summary))
-            errors (exit 1 (error-msg errors)))
-          (let [backend (case (:backend options)
-                          "testing" (core/->TestingBackend)
-                          "redis" (do (redis/start-expiry-thread!)
-                                      (redis/->RedisBackend))
-                          "sqlite" (do (sqlite/ensure-schema db)
-                                       (sqlite/->SQLiteBackend db)))
-                delete-xform (case (:delete-pattern options)
-                               "forward" identity
-                               "reverse" reverse
-                               "shuffle" shuffle
-                               "zero" #(repeat (count %) 0.0))
-                [tree-name structure]
-                (case (:data-structure options)
-                  "b-tree" ["b-tree" (core-b-tree (:tree-width options) backend)]
-                  "fractal" ["fractal" (msg-b-tree (:tree-width options) backend)]
-                  "sorted-set" ["sorted-set" (sorted-set-repr)])
-                flush-freq (:flush-freq options)
-                codename (str tree-name
-                              "__flush_"
-                              flush-freq
-                              "__b_"
-                              (:tree-width options)
-                              "__"
-                              (:backend options)
-                              "__n_"
-                              (:num-operations options)
-                              "__del_"
-                              (:delete-pattern options))]
-            (doseq [ds (generate-test-datasets)
-                    :let [codename (str codename
-                                        "_"
-                                        (:name ds))
-                          out (create-output-dir
-                               root
-                               codename)
-                          _ (println "Doing" codename)
-                          bench-res (benchmark (:num-operations options) ds flush-freq structure out delete-xform)]]
-              (swap! results conj
-                     {:tree tree-name
-                      :ds (:name ds)
-                      :freq flush-freq
-                      :n (:num-operations options)
-                      :b (:tree-width options)
-                      :delete-pattern (:delete-pattern options)
-                      :results bench-res}))
+  (let [outputs (atom [])]
+    (doseq [args (or (->> args
+                          (partition-by #(= % "--"))
+                          (map-indexed vector)
+                          (filter (comp even? first))
+                          (map second)
+                          (seq))
+                     [[]])] ; always do one iteration
+      (let [{:keys [options arguments errors summary]} (parse-opts args options)
+            tree-to-test (atom {})
+            results (atom [])]
+        (cond
+          (or (= "-h" root)
+              (= "--help" root)
+              (nil? root)
+              (:help options)) (exit 0 (usage summary))
+          (not= (count arguments) 0) (exit 1 (usage summary))
+          errors (exit 1 (error-msg errors)))
+        (let [backend (case (:backend options)
+                        "testing" (core/->TestingBackend)
+                        "redis" (do (redis/start-expiry-thread!)
+                                    (redis/->RedisBackend))
+                        "sqlite" (sqlite/->SQLiteBackend
+                                  (sqlite/find-or-create-db "/tmp/yolo.sqlite")))
+              delete-xform (case (:delete-pattern options)
+                             "forward" identity
+                             "reverse" reverse
+                             "shuffle" shuffle
+                             "zero" #(repeat (count %) 0.0))
+              [tree-name structure]
+              (case (:data-structure options)
+                "b-tree" ["b-tree" (core-b-tree (:tree-width options) backend)]
+                "fractal" ["fractal" (msg-b-tree (:tree-width options) backend)]
+                "sorted-set" ["sorted-set" (sorted-set-repr)])
+              flush-freq (:flush-freq options)
+              codename (str tree-name
+                            "__flush_"
+                            flush-freq
+                            "__b_"
+                            (:tree-width options)
+                            "__"
+                            (:backend options)
+                            "__n_"
+                            (:num-operations options)
+                            "__del_"
+                            (:delete-pattern options))]
+          (doseq [ds (generate-test-datasets)
+                  :let [codename (str codename
+                                      "_"
+                                      (:name ds))
+                        out (create-output-dir
+                              root
+                              codename)
+                        _ (println "Doing" codename)
+                        bench-res (benchmark (:num-operations options) ds flush-freq structure out delete-xform)]]
+            (swap! results conj
+                   {:tree tree-name
+                    :ds (:name ds)
+                    :freq flush-freq
+                    :n (:num-operations options)
+                    :b (:tree-width options)
+                    :delete-pattern (:delete-pattern options)
+                    :results bench-res}))
                                         ;(println "results")
                                         ;(clojure.pprint/pprint @results)
-            (swap! outputs conj (template-one-sheet @results)))))
-      (excel/render-to-file
-       "template_benchmark.xlsx"
-       (.getPath (File. root "analysis.xlsx"))
-       {"SingleDS"
-        (map-indexed (fn [i s]
-                       (assoc s :sheet-name (str "Trial " (inc i))))
-                     @outputs)}))))
+          (swap! outputs conj (template-one-sheet @results)))))
+    (excel/render-to-file
+     "template_benchmark.xlsx"
+     (.getPath (File. root "analysis.xlsx"))
+     {"SingleDS"
+      (map-indexed (fn [i s]
+                     (assoc s :sheet-name (str "Trial " (inc i))))
+                   @outputs)})))

src/hitchhiker/sqlite.clj

@@ -28,10 +28,19 @@
 (def query
   {:table-exists? "select 1 from sqlite_master where type='table' and name=?"
    :index-exists? "select 1 from sqlite_master where type='index' and name=?"
-   :find-key      "select * from hh_key where k=?"})
+   :find-key      "select * from hh_key where k=?"
+   :dead-keys     "select k
+                     from hh_key
+                    where k not in ( select child from hh_ref )"})
 
 (defn drop-ref [db key]
-  (jdbc/delete! db :hh-key ["k = ?" key]))
+  (jdbc/delete! db :hh-key ["k = ?" key]
+                {:entities underscore})
+
+  (let [dead-keys (jdbc/query db (query :dead-keys))]
+    (doseq [{:keys [k] :as dead-key} dead-keys]
+      (drop-ref db k))))
+
 
 (defn db-spec [subname]
   {:classname   "org.sqlite.JDBC"
@@ -86,7 +95,22 @@
 
     (ensure {:items [:hh-ref-by-parent :hh-ref-by-child]
              :exists? index-exists?
-             :create! create-index})))
+             :create! create-index})
+
+    db))
+
+(defonce ^:private db-registry (atom {}))
+
+(defn find-db [subname]
+  (get @db-registry subname))
+
+(defn create-db [subname]
+  (-> {:connection (jdbc/get-connection (db-spec subname))}
+      (ensure-schema db)))
+
+(defn find-or-create-db [subname]
+  (or (find-db subname)
+      (create-db subname)))
 
 (defn add-node [db {:keys [k v] :as node}]
   (try
@@ -96,23 +120,36 @@
                       {:node node
                        :db db} e)))))
 
+(defn list-keys [db]
+  (jdbc/query db "select k from hh_key"))
+
 (defn delete-key [db k]
   (jdbc/delete! :hh-key ["k = ?" k]))
 
 (defn add-refs [db {:keys [parent children]}]
   (let [mk-ref (fn [child]
                  [parent child])]
-    (jdbc/insert-multi! db :hh-ref (for [child children]
-                                     {:parent parent
-                                      :child child})
-                        {:entities underscore})))
+    (try
+      (jdbc/insert-multi! db :hh-ref (for [child children]
+                                       {:parent parent
+                                        :child child})
+                          {:entities underscore})
+      (catch Exception e
+        (throw (ex-info "Failed to link parent with children"
+                        {:parent parent
+                         :children children}
+                        e))))))
 
 (defn synthesize-storage-addr
   "Given a key, returns a promise containing that key for use as a storage-addr"
   [key]
   (doto (promise)
     (deliver key)))
 
+;;; TODO: I believe using a dynamic var to hold the DB is a bit of anti-pattern but
+;;;       not sure how to avoid it and still support caching as it behaves in the
+;;;       redis backend.
+;;;
 (def ^:dynamic *db*)
 
 (let [cache (-> {}
@@ -167,7 +204,6 @@
   (new-session [_] (atom {:writes 0
                           :deletes 0}))
   (anchor-root [_ {:keys [sqlite-key] :as node}]
-    ;; TODO: figure out how redis gc relates to SQL
     node)
   (write-node [_ node session]
     (swap! session update-in [:writes] inc)

test/hitchhiker/sqlite_test.clj

@@ -0,0 +1,59 @@
+(ns hitchhiker.sqlite-test
+  (:require [clojure.test.check.clojure-test :refer [defspec]]
+            [clojure.test.check.generators :as gen]
+            [clojure.test.check.properties :as prop]
+            [hitchhiker.sqlite :as sqlite]
+            [hitchhiker.tree.core :as core]
+            hitchhiker.tree.core-test
+            [hitchhiker.tree.messaging :as msg]
+            [clojure.java.jdbc :as jdbc]))
+
+(defn insert
+  [t k]
+  (msg/insert t k k))
+
+(defn lookup-fwd-iter
+  [t v]
+  (seq (map first (msg/lookup-fwd-iter t v))))
+
+(defn mixed-op-seq
+  "This is like the basic mixed-op-seq tests, but it also mixes in flushes to sqlite
+   and automatically deletes the old tree"
+  [add-freq del-freq flush-freq universe-size num-ops]
+  (let [db (sqlite/find-or-create-db "/tmp/yolo.sqlite")]
+    (prop/for-all [ops (gen/vector (gen/frequency
+                                    [[add-freq (gen/tuple (gen/return :add)
+                                                          (gen/no-shrink gen/int))]
+                                     [flush-freq (gen/return [:flush])]
+                                     [del-freq (gen/tuple (gen/return :del)
+                                                          (gen/no-shrink gen/int))]])
+                                   40)]
+      (assert (empty? (sqlite/list-keys db))
+              "Start with no keys")
+      (let [[b-tree root set]
+            (reduce (fn [[t root set] [op x]]
+                      (let [x-reduced (when x (mod x universe-size))]
+                        (condp = op
+                          :flush (let [t (:tree (core/flush-tree t (sqlite/->SQLiteBackend db)))]
+                                   (when root
+                                     (sqlite/drop-ref db root))
+                                   #_(println "flush" root)
+                                   [t @(:storage-addr t) set])
+                          :add (do #_(println "add" x) [(insert t x-reduced) root (conj set x-reduced)])
+                          :del (do #_(println "del" x) [(msg/delete t x-reduced) root (disj set x-reduced)]))))
+                    [(core/b-tree (core/->Config 3 3 2)) nil #{}]
+                    ops)]
+        (println "Make it to the end of a test," root "has" (count (lookup-fwd-iter b-tree -1)) "keys left")
+        (let [b-tree-order (lookup-fwd-iter b-tree -1)
+              res (= b-tree-order (seq (sort set)))]
+
+          (sqlite/drop-ref db root)
+          (assert (empty? (sqlite/list-keys db))
+                  "End with no keys")
+
+          (assert res (str "These are unequal: " (pr-str b-tree-order) " " (pr-str (seq (sort set)))))
+          res)))))
+
+(defspec test-many-keys-bigger-trees
+  100
+  (mixed-op-seq 800 200 10 1000 1000))