Skip to content

Commit 839f110

Browse files
author
Andy Chambers
committed
Add genertive test for sqlite backend
1 parent 9f23205 commit 839f110

File tree

3 files changed

+174
-80
lines changed

3 files changed

+174
-80
lines changed

‎env/profiling/hitchhiker/bench.clj

+71-72
Original file line numberDiff line numberDiff line change
@@ -196,77 +196,76 @@
196196

197197
(defn -main
198198
[& [root & args]]
199-
(jdbc/with-db-connection [db (sqlite/db-spec ":memory:")]
200-
(let [outputs (atom [])]
201-
(doseq [args (or (->> args
202-
(partition-by #(= % "--"))
203-
(map-indexed vector)
204-
(filter (comp even? first))
205-
(map second)
206-
(seq))
207-
[[]])] ; always do one iteration
208-
(let [{:keys [options arguments errors summary]} (parse-opts args options)
209-
tree-to-test (atom {})
210-
results (atom [])]
211-
(cond
212-
(or (= "-h" root)
213-
(= "--help" root)
214-
(nil? root)
215-
(:help options)) (exit 0 (usage summary))
216-
(not= (count arguments) 0) (exit 1 (usage summary))
217-
errors (exit 1 (error-msg errors)))
218-
(let [backend (case (:backend options)
219-
"testing" (core/->TestingBackend)
220-
"redis" (do (redis/start-expiry-thread!)
221-
(redis/->RedisBackend))
222-
"sqlite" (do (sqlite/ensure-schema db)
223-
(sqlite/->SQLiteBackend db)))
224-
delete-xform (case (:delete-pattern options)
225-
"forward" identity
226-
"reverse" reverse
227-
"shuffle" shuffle
228-
"zero" #(repeat (count %) 0.0))
229-
[tree-name structure]
230-
(case (:data-structure options)
231-
"b-tree" ["b-tree" (core-b-tree (:tree-width options) backend)]
232-
"fractal" ["fractal" (msg-b-tree (:tree-width options) backend)]
233-
"sorted-set" ["sorted-set" (sorted-set-repr)])
234-
flush-freq (:flush-freq options)
235-
codename (str tree-name
236-
"__flush_"
237-
flush-freq
238-
"__b_"
239-
(:tree-width options)
240-
"__"
241-
(:backend options)
242-
"__n_"
243-
(:num-operations options)
244-
"__del_"
245-
(:delete-pattern options))]
246-
(doseq [ds (generate-test-datasets)
247-
:let [codename (str codename
248-
"_"
249-
(:name ds))
250-
out (create-output-dir
251-
root
252-
codename)
253-
_ (println "Doing" codename)
254-
bench-res (benchmark (:num-operations options) ds flush-freq structure out delete-xform)]]
255-
(swap! results conj
256-
{:tree tree-name
257-
:ds (:name ds)
258-
:freq flush-freq
259-
:n (:num-operations options)
260-
:b (:tree-width options)
261-
:delete-pattern (:delete-pattern options)
262-
:results bench-res}))
199+
(let [outputs (atom [])]
200+
(doseq [args (or (->> args
201+
(partition-by #(= % "--"))
202+
(map-indexed vector)
203+
(filter (comp even? first))
204+
(map second)
205+
(seq))
206+
[[]])] ; always do one iteration
207+
(let [{:keys [options arguments errors summary]} (parse-opts args options)
208+
tree-to-test (atom {})
209+
results (atom [])]
210+
(cond
211+
(or (= "-h" root)
212+
(= "--help" root)
213+
(nil? root)
214+
(:help options)) (exit 0 (usage summary))
215+
(not= (count arguments) 0) (exit 1 (usage summary))
216+
errors (exit 1 (error-msg errors)))
217+
(let [backend (case (:backend options)
218+
"testing" (core/->TestingBackend)
219+
"redis" (do (redis/start-expiry-thread!)
220+
(redis/->RedisBackend))
221+
"sqlite" (sqlite/->SQLiteBackend
222+
(sqlite/find-or-create-db "/tmp/yolo.sqlite")))
223+
delete-xform (case (:delete-pattern options)
224+
"forward" identity
225+
"reverse" reverse
226+
"shuffle" shuffle
227+
"zero" #(repeat (count %) 0.0))
228+
[tree-name structure]
229+
(case (:data-structure options)
230+
"b-tree" ["b-tree" (core-b-tree (:tree-width options) backend)]
231+
"fractal" ["fractal" (msg-b-tree (:tree-width options) backend)]
232+
"sorted-set" ["sorted-set" (sorted-set-repr)])
233+
flush-freq (:flush-freq options)
234+
codename (str tree-name
235+
"__flush_"
236+
flush-freq
237+
"__b_"
238+
(:tree-width options)
239+
"__"
240+
(:backend options)
241+
"__n_"
242+
(:num-operations options)
243+
"__del_"
244+
(:delete-pattern options))]
245+
(doseq [ds (generate-test-datasets)
246+
:let [codename (str codename
247+
"_"
248+
(:name ds))
249+
out (create-output-dir
250+
root
251+
codename)
252+
_ (println "Doing" codename)
253+
bench-res (benchmark (:num-operations options) ds flush-freq structure out delete-xform)]]
254+
(swap! results conj
255+
{:tree tree-name
256+
:ds (:name ds)
257+
:freq flush-freq
258+
:n (:num-operations options)
259+
:b (:tree-width options)
260+
:delete-pattern (:delete-pattern options)
261+
:results bench-res}))
263262
;(println "results")
264263
;(clojure.pprint/pprint @results)
265-
(swap! outputs conj (template-one-sheet @results)))))
266-
(excel/render-to-file
267-
"template_benchmark.xlsx"
268-
(.getPath (File. root "analysis.xlsx"))
269-
{"SingleDS"
270-
(map-indexed (fn [i s]
271-
(assoc s :sheet-name (str "Trial " (inc i))))
272-
@outputs)}))))
264+
(swap! outputs conj (template-one-sheet @results)))))
265+
(excel/render-to-file
266+
"template_benchmark.xlsx"
267+
(.getPath (File. root "analysis.xlsx"))
268+
{"SingleDS"
269+
(map-indexed (fn [i s]
270+
(assoc s :sheet-name (str "Trial " (inc i))))
271+
@outputs)})))

‎src/hitchhiker/sqlite.clj

+44-8
Original file line numberDiff line numberDiff line change
@@ -28,10 +28,19 @@
2828
(def query
2929
{:table-exists? "select 1 from sqlite_master where type='table' and name=?"
3030
:index-exists? "select 1 from sqlite_master where type='index' and name=?"
31-
:find-key "select * from hh_key where k=?"})
31+
:find-key "select * from hh_key where k=?"
32+
:dead-keys "select k
33+
from hh_key
34+
where k not in ( select child from hh_ref )"})
3235

3336
(defn drop-ref [db key]
34-
(jdbc/delete! db :hh-key ["k = ?" key]))
37+
(jdbc/delete! db :hh-key ["k = ?" key]
38+
{:entities underscore})
39+
40+
(let [dead-keys (jdbc/query db (query :dead-keys))]
41+
(doseq [{:keys [k] :as dead-key} dead-keys]
42+
(drop-ref db k))))
43+
3544

3645
(defn db-spec [subname]
3746
{:classname "org.sqlite.JDBC"
@@ -86,7 +95,22 @@
8695

8796
(ensure {:items [:hh-ref-by-parent :hh-ref-by-child]
8897
:exists? index-exists?
89-
:create! create-index})))
98+
:create! create-index})
99+
100+
db))
101+
102+
(defonce ^:private db-registry (atom {}))
103+
104+
(defn find-db [subname]
105+
(get @db-registry subname))
106+
107+
(defn create-db [subname]
108+
(-> {:connection (jdbc/get-connection (db-spec subname))}
109+
(ensure-schema)))
110+
111+
(defn find-or-create-db [subname]
112+
(or (find-db subname)
113+
(create-db subname)))
90114

91115
(defn add-node [db {:keys [k v] :as node}]
92116
(try
@@ -96,23 +120,36 @@
96120
{:node node
97121
:db db} e)))))
98122

123+
(defn list-keys [db]
124+
(jdbc/query db "select k from hh_key"))
125+
99126
(defn delete-key [db k]
100127
(jdbc/delete! :hh-key ["k = ?" k]))
101128

102129
(defn add-refs [db {:keys [parent children]}]
103130
(let [mk-ref (fn [child]
104131
[parent child])]
105-
(jdbc/insert-multi! db :hh-ref (for [child children]
106-
{:parent parent
107-
:child child})
108-
{:entities underscore})))
132+
(try
133+
(jdbc/insert-multi! db :hh-ref (for [child children]
134+
{:parent parent
135+
:child child})
136+
{:entities underscore})
137+
(catch Exception e
138+
(throw (ex-info "Failed to link parent with children"
139+
{:parent parent
140+
:children children}
141+
e))))))
109142

110143
(defn synthesize-storage-addr
111144
"Given a key, returns a promise containing that key for use as a storage-addr"
112145
[key]
113146
(doto (promise)
114147
(deliver key)))
115148

149+
;;; TODO: I believe using a dynamic var to hold the DB is a bit of anti-pattern but
150+
;;; not sure how to avoid it and still support caching as it behaves in the
151+
;;; redis backend.
152+
;;;
116153
(def ^:dynamic *db*)
117154

118155
(let [cache (-> {}
@@ -167,7 +204,6 @@
167204
(new-session [_] (atom {:writes 0
168205
:deletes 0}))
169206
(anchor-root [_ {:keys [sqlite-key] :as node}]
170-
;; TODO: figure out how redis gc relates to SQL
171207
node)
172208
(write-node [_ node session]
173209
(swap! session update-in [:writes] inc)

‎test/hitchhiker/sqlite_test.clj

+59
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,59 @@
1+
(ns hitchhiker.sqlite-test
2+
(:require [clojure.test.check.clojure-test :refer [defspec]]
3+
[clojure.test.check.generators :as gen]
4+
[clojure.test.check.properties :as prop]
5+
[hitchhiker.sqlite :as sqlite]
6+
[hitchhiker.tree.core :as core]
7+
hitchhiker.tree.core-test
8+
[hitchhiker.tree.messaging :as msg]
9+
[clojure.java.jdbc :as jdbc]))
10+
11+
(defn insert
12+
[t k]
13+
(msg/insert t k k))
14+
15+
(defn lookup-fwd-iter
16+
[t v]
17+
(seq (map first (msg/lookup-fwd-iter t v))))
18+
19+
(defn mixed-op-seq
20+
"This is like the basic mixed-op-seq tests, but it also mixes in flushes to sqlite
21+
and automatically deletes the old tree"
22+
[add-freq del-freq flush-freq universe-size num-ops]
23+
(let [db (sqlite/find-or-create-db "/tmp/yolo.sqlite")]
24+
(prop/for-all [ops (gen/vector (gen/frequency
25+
[[add-freq (gen/tuple (gen/return :add)
26+
(gen/no-shrink gen/int))]
27+
[flush-freq (gen/return [:flush])]
28+
[del-freq (gen/tuple (gen/return :del)
29+
(gen/no-shrink gen/int))]])
30+
40)]
31+
(assert (empty? (sqlite/list-keys db))
32+
"Start with no keys")
33+
(let [[b-tree root set]
34+
(reduce (fn [[t root set] [op x]]
35+
(let [x-reduced (when x (mod x universe-size))]
36+
(condp = op
37+
:flush (let [t (:tree (core/flush-tree t (sqlite/->SQLiteBackend db)))]
38+
(when root
39+
(sqlite/drop-ref db root))
40+
#_(println "flush" root)
41+
[t @(:storage-addr t) set])
42+
:add (do #_(println "add" x) [(insert t x-reduced) root (conj set x-reduced)])
43+
:del (do #_(println "del" x) [(msg/delete t x-reduced) root (disj set x-reduced)]))))
44+
[(core/b-tree (core/->Config 3 3 2)) nil #{}]
45+
ops)]
46+
#_(println "Make it to the end of a test," root "has" (count (lookup-fwd-iter b-tree -1)) "keys left")
47+
(let [b-tree-order (lookup-fwd-iter b-tree -1)
48+
res (= b-tree-order (seq (sort set)))]
49+
50+
(sqlite/drop-ref db root)
51+
(assert (empty? (sqlite/list-keys db))
52+
"End with no keys")
53+
54+
(assert res (str "These are unequal: " (pr-str b-tree-order) " " (pr-str (seq (sort set)))))
55+
res)))))
56+
57+
(defspec test-many-keys-bigger-trees
58+
100
59+
(mixed-op-seq 800 200 10 1000 1000))

0 commit comments

Comments
 (0)