greg/mentat
1
0
Fork 0
Code Issues 294 Pull requests Projects Releases 9 Packages Wiki Activity

Implement type-aware querying, fulltext searching, fast importing, and much besides. Fixes #14, #30, #35, #39, #40, #42. r=nalexander

Browse source
This commit is contained in:
Richard Newman 2016-08-30 18:24:12 -07:00
commit b2a1af30ed
34 changed files with 3382 additions and 847 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
project.clj
View file

@ -8,6 +8,8 @@
[org.clojure/core.async "0.2.385"] [org.clojure/core.async "0.2.385"]
[datascript "0.15.1"] [datascript "0.15.1"]
[honeysql "0.8.0"] [honeysql "0.8.0"]
[com.datomic/datomic-free "0.9.5359"]
[com.taoensso/tufte "1.0.2"]
[jamesmacaulay/cljs-promises "0.1.0"]] [jamesmacaulay/cljs-promises "0.1.0"]]
:cljsbuild {:builds {:release { :cljsbuild {:builds {:release {
@ -48,9 +50,12 @@
[org.clojure/tools.nrepl "0.2.10"] [org.clojure/tools.nrepl "0.2.10"]
[org.clojure/java.jdbc "0.6.2-alpha1"] [org.clojure/java.jdbc "0.6.2-alpha1"]
[org.xerial/sqlite-jdbc "3.8.11.2"]] [org.xerial/sqlite-jdbc "3.8.11.2"]]
:jvm-opts ["-Xss4m"]
:repl-options {:nrepl-middleware [cemerick.piggieback/wrap-cljs-repl]} :repl-options {:nrepl-middleware [cemerick.piggieback/wrap-cljs-repl]}
:plugins [[lein-cljsbuild "1.1.3"] :plugins [[lein-cljsbuild "1.1.3"]
[lein-doo "0.1.6"]] [lein-doo "0.1.6"]
[venantius/ultra "0.4.1"]
[com.jakemccrary/lein-test-refresh "0.16.0"]]
}} }}
:doo {:build "test"} :doo {:build "test"}

196
src/datomish/d.clj Normal file
View file

@ -0,0 +1,196 @@
(ns datomish.d
(:require [datomic.db :as db]))
(use '[datomic.api :only [q db] :as d])
(use 'clojure.pprint)
(def uri "datomic:free://localhost:4334//news")
(d/create-database uri)
(def conn (d/connect uri))
(def schema-tx (read-string (slurp "src/datomish/schema.edn")))
(println "schema-tx:")
(pprint schema-tx)
;; alter/attribute does not retract/assert install/attribute.
;; @(d/transact conn [{:db/id :news/baz
;; :db/cardinality :db.cardinality/one
;; :db.alter/_attribute :db.part/db}])
@(d/transact conn schema-tx)
;; add some data:
(def data-tx [{:news/title "Rain Tomorrow", :db/id #db/id[:db.part/user -1000001]}])
@(d/transact conn data-tx)
(def x
@(d/transact conn [[:db/add #db/id[:db.part/user -1] :news/title "Rain Tomorrow 1" #db/id[:db.part/tx -1]]
[:db/add #db/id[:db.part/user -2] :news/title "Rain Tomorrow 2" #db/id[:db.part/tx -2]]
[:db/add #db/id[:db.part/tx -2] :news/title "Test"]]))
;; This drops the tx entirely!
(def x
@(d/transact conn [[:db/add #db/id[:db.part/user -1] :news/title "Rain Tomorrow 3" 13194139534684]]))
(def x
@(d/transact conn [[:db/add #db/id[:db.part/user -1] :news/title "Rain Tomorrow 3" 13194139534684]
{:db/id #db/id[:db.part/db -1] :db/ident :test/test2 :db.install/_partition :db.part/db}
[:db/add #db/id[:db.part/tx -2] :news/title "Test"]]))
(def x
@(d/transact conn [[:db/add #db/id[:test/test2 -1] :news/title "Rain Tomorrow 5"]]))
;; [:db/add #db/id[:db.part/user -2] :news/title "Rain Tomorrow 2" #db/id[:db.part/tx -2]]
;; [:db/add #db/id[:db.part/tx -2] :news/title "Test"]]))
(def results (q '[:find ?n :where [?n :news/title]] (db conn)))
(println (count results))
(pprint results)
(pprint (first results))
(def id (ffirst results))
(def entity (-> conn db (d/entity id)))
;; display the entity map's keys
(pprint (keys entity))
;; display the value of the entity's community name
(println (:news/title entity))
;; @(d/transact conn [[:db/retract )
@(d/transact conn [[:db/add 17592186045427 :news/title "Test"]])
;; 1. Caused by datomic.impl.Exceptions$IllegalArgumentExceptionInfo
;; :db.error/datoms-conflict Two datoms in the same transaction
;; conflict {:d1 [17592186045427 :news/title "Test" 13194139534372
;; true], :d2 [17592186045427 :news/title "Test2" 13194139534372
;; true]}
;; 1. Caused by datomic.impl.Exceptions$IllegalArgumentExceptionInfo
;; :db.error/not-an-entity Unable to resolve entity: [:news/foobar
;; "a"] in datom [[:news/foobar "a"] :news/foobar "b"]
;; {:db/error :db.error/not-an-entity}
;; @(d/transact conn [[:db/add #db/id[db.part/user -1] :news/foobar "a"]
;; [:db/add #db/id[db.part/user -2] :news/zot "a"]])
;; @(d/transact conn [[:db/add #db/id[db.part/user -1] :news/baz #db/id[db.part/user -2]]
;; [:db/add #db/id[db.part/user -2] :news/baz #db/id[db.part/user -1]]])
;; {:db-before datomic.db.Db@a0166706, :db-after datomic.db.Db@5d0d6a62, :tx-data [#datom[13194139534399 50 #inst "2016-07-20T04:45:19.553-00:00" 13194139534399 true] #datom[17592186045504 68 17592186045505 13194139534399 true] #datom[17592186045505 68 17592186045504 13194139534399 true]], :tempids {-9223350046622220289 17592186045504, -9223350046622220290 17592186045505}}
;; @(d/transact conn [[:db/add [:news/foobar "a"] :news/foobar "b"]])
;; @(d/transact conn [[:db/retract 17592186045505 68 17592186045504 13194139534399]])
;; 1. Caused by datomic.impl.Exceptions$IllegalArgumentExceptionInfo
;; :db.error/not-a-data-function Unable to resolve data function:
;; {:news/foobar "a", :news/zot "a", :news/title "test"}
;; {:db/error :db.error/not-a-data-function}
;; 1. Caused by datomic.impl.Exceptions$IllegalArgumentExceptionInfo
;; :db.error/entity-missing-db-id Missing :db/id
;; {:input {:news/foobar "a", :news/zot "a", :news/title "test"}, :db/error :db.error/entity-missing-db-id}
;; @(d/transact conn [{:news/foobar "a" :news/zot "a" :news/title "test"}])
;; ;; 1. Caused by datomic.impl.Exceptions$IllegalStateExceptionInfo
;; ;; :db.error/unique-conflict Unique conflict: :news/zot, value: a
;; ;; already held by: 17592186045489 asserted for: 17592186045483
;; ;; {:db/error :db.error/unique-conflict}
;; @(d/transact conn [{:db/id [:news/foobar "a"] :news/zot "a" :news/title "test"}])
;; ;; 1. Caused by datomic.impl.Exceptions$IllegalStateExceptionInfo
;; ;; :db.error/unique-conflict Unique conflict: :news/zot, value: b
;; ;; already held by: 17592186045492 asserted for: 17592186045483
;; @(d/transact conn [
;; {:db/id #db/id[db.part/user -1] :news/foobar "c" :news/zot "c"}])
;; ;; {:db/id #db/id[db.part/user -1] :news/zot "a"} ])
;; ;; 1. Caused by datomic.impl.Exceptions$IllegalStateExceptionInfo
;; ;; :db.error/unique-conflict Unique conflict: :news/foobar, value: b
;; ;; already held by: 17592186045478 asserted for: 1
;; ;; {:db/error :db.error/unique-conflict}
;; @(d/transact conn [[:db/add 17592186045478 :news/foobar "b"]])
;; @(d/transact conn [[:db/add 17592186045478 :news/foobar "a"]])
;; ;; Datomic accepts two different id-literals resolving to the same entid.
(def txx #db/id[db.part/tx])
(def x @(d/transact conn [[:db/add #db/id[db.part/user -1] :news/foobar "c"]
[:db/add #db/id[db.part/user -2] :news/zot "c"]
[:db/add txx :news/title "x"]
[:db/add #db/id[db.part/tx -5] :news/title "x"]
]))
(def x @(d/transact conn [[:db/add #db/id[db.part/user -1] :news/baz #db/id[db.part/tx]]]))
;; ;; 1. Caused by datomic.impl.Exceptions$IllegalArgumentExceptionInfo
;; ;; :db.error/tempid-not-an-entity tempid used only as value in
;; ;; transaction
;; ;; {:db/error :db.error/tempid-not-an-entity}
;; @(d/transact conn [[:db/add #db/id[db.part/user -1] :news/baz #db/id[db.part/user -3]]
;; [:db/add #db/id[db.part/user -2] :news/baz #db/id[db.part/user -3]]])
;; ;; 2. Unhandled java.util.concurrent.ExecutionException
;; ;; java.lang.IndexOutOfBoundsException
;; @(d/transact conn [[:db/add #db/id[db.part/user -1] :db/ident :news/zot]
;; [:db/add #db/id[db.part/user -2] #db/id[db.part/user -1] "c"]])
(vec
(q '[:find ?added ?a ?v ?tx
:where
[17592186045427 ?a ?v ?tx ?added]
;; [(>= ?e 17592186045427)]
;; [(tx-ids ?log ?t1 ?t2) [?tx ...]]
;; [(tx-data ?log ?tx) [[?e ?a ?v _ ?added]]]
]
(d/db conn)))
;; [[true 63 "Test" 13194139534324]]
(vec
(q '[:find ?e ?added ?a ?v ?tx
:in ?log ?t1 ?t2
:where
[(tx-ids ?log ?t1 ?t2) [?tx ...]]
[(tx-data ?log ?tx) [[?e ?a ?v _ ?added]]]
[(= ?e 17592186045427)]
]
(d/log conn) #inst "2013-08-01" #inst "2017-01-01"))
[[17592186045427 false 63 "Rain Tomorrow" 13194139534324] [17592186045427 true 63 "Test" 13194139534324] [17592186045427 false 63 "Test" 13194139534325] [17592186045427 true 63 "Rain Tomorrow" 13194139534322]]
;; [[17592186045427 false 63 "Rain Tomorrow" 13194139534324] [17592186045427 true 63 "Test" 13194139534324] [17592186045427 true 63 "Rain Tomorrow" 13194139534322]]
@(d/transact conn [[:db/retract 17592186045427 :news/title "Test"]])
(sort-by first (d/q '[:find ?a ?ident :where
[?e ?a ?ident]
[_ :db.install/attribute ?e]] (db/bootstrap-db)))
(def x (db/bootstrap-db))
(pprint (vec (map (juxt :e :a :v :tx :added) (filter #(= 13194139533312 (:tx %)) (d/datoms x :eavt)))))
(pprint (sort (set (map (juxt :tx) (d/datoms x :eavt)))))
(def tx0 13194139533312)
(def tx1 13194139533366)
(def tx2 13194139533368)
(def tx3 13194139533375)
(pprint
(sort-by first (d/q '[:find ?e ?an ?v ?tx
:in $ ?tx
:where
[?e ?a ?v ?tx true]
[?a :db/ident ?an]
] x tx3)))
;; (d/datoms x :eavt))))
;; 13194139533312

592
src/datomish/db.cljc
View file

@ -8,16 +8,19 @@
[datomish.pair-chan :refer [go-pair <?]] [datomish.pair-chan :refer [go-pair <?]]
[cljs.core.async.macros :refer [go]])) [cljs.core.async.macros :refer [go]]))
(:require (:require
[clojure.set]
[datomish.query.context :as context] [datomish.query.context :as context]
[datomish.query.projection :as projection] [datomish.query.projection :as projection]
[datomish.query.source :as source] [datomish.query.source :as source]
[datomish.query :as query] [datomish.query :as query]
[datomish.datom :as dd :refer [datom datom? #?@(:cljs [Datom])]] [datomish.datom :as dd :refer [datom datom? #?@(:cljs [Datom])]]
[datomish.util :as util #?(:cljs :refer-macros :clj :refer) [raise raise-str cond-let]] [datomish.util :as util
#?(:cljs :refer-macros :clj :refer) [raise raise-str cond-let]]
[datomish.schema :as ds] [datomish.schema :as ds]
[datomish.schema-changes]
[datomish.sqlite :as s] [datomish.sqlite :as s]
[datomish.sqlite-schema :as sqlite-schema] [datomish.sqlite-schema :as sqlite-schema]
[taoensso.tufte :as tufte
#?(:cljs :refer-macros :clj :refer) [defnp p profiled profile]]
#?@(:clj [[datomish.pair-chan :refer [go-pair <?]] #?@(:clj [[datomish.pair-chan :refer [go-pair <?]]
[clojure.core.async :as a :refer [chan go <! >!]]]) [clojure.core.async :as a :refer [chan go <! >!]]])
#?@(:cljs [[datomish.pair-chan] #?@(:cljs [[datomish.pair-chan]
@ -34,6 +37,9 @@
(uncaughtException [_ thread ex] (uncaughtException [_ thread ex]
(println ex "Uncaught exception on" (.getName thread)))))) (println ex "Uncaught exception on" (.getName thread))))))
(def max-sql-vars 999) ;; TODO: generalize.
;; ---------------------------------------------------------------------------- ;; ----------------------------------------------------------------------------
;; define data-readers to be made available to EDN readers. in CLJS ;; define data-readers to be made available to EDN readers. in CLJS
;; they're magically available. in CLJ, data_readers.clj may or may ;; they're magically available. in CLJ, data_readers.clj may or may
@ -55,7 +61,7 @@
(->TempId part idx))) (->TempId part idx)))
(defn id-literal? [x] (defn id-literal? [x]
(and (instance? TempId x))) (instance? TempId x))
(defprotocol IClock (defprotocol IClock
(now (now
@ -74,13 +80,13 @@
[db] [db]
"Return the schema of this database.") "Return the schema of this database.")
(idents (entid
[db] [db ident]
"Return the known idents of this database, as a map from keyword idents to entids.") "Returns the entity id associated with a symbolic keyword, or the id itself if passed.")
(current-tx (ident
[db] [db eid]
"TODO: document this interface.") "Returns the keyword associated with an id, or the key itself if passed.")
(in-transaction! (in-transaction!
[db chan-fn] [db chan-fn]
@ -88,29 +94,29 @@
commit the transaction; otherwise, rollback the transaction. Returns a pair-chan resolving to commit the transaction; otherwise, rollback the transaction. Returns a pair-chan resolving to
the pair-chan returned by `chan-fn`.") the pair-chan returned by `chan-fn`.")
(<eavt (<bootstrapped? [db]
[db pattern] "Return true if this database has no transactions yet committed.")
"Search for datoms using the EAVT index.")
(<avet (<av
[db pattern] [db a v]
"Search for datoms using the AVET index.") "Search for a single matching datom using the AVET index.")
(<apply-datoms (<apply-entities
[db datoms] [db tx entities]
"Apply datoms to the store.") "Apply entities to the store, returning sequence of datoms transacted.")
(<apply-db-ident-assertions (<apply-db-ident-assertions
[db added-idents] [db added-idents merge]
"Apply added idents to the store.") "Apply added idents to the store, using `merge` as a `merge-with` function.")
(<apply-db-install-assertions (<apply-db-install-assertions
[db fragment] [db fragment merge]
"Apply added schema fragment to the store.") "Apply added schema fragment to the store, using `merge` as a `merge-with` function.")
(<advance-tx (<next-eid
[db] [db id-literal]
"TODO: document this interface.")) "Return a unique integer for the given id-literal, accounting for the literal's partition. The
returned integer should never be returned again."))
(defn db? [x] (defn db? [x]
(and (satisfies? IDB x) (and (satisfies? IDB x)
@ -140,117 +146,459 @@
] ]
rowid))) rowid)))
(defrecord DB [sqlite-connection schema idents current-tx] (defn datoms-attribute-transform
;; idents is map {ident -> entid} of known idents. See http://docs.datomic.com/identity.html#idents. [db x]
{:pre [(db? db)]}
(entid db x))
(defn datoms-constant-transform
[db x]
{:pre [(db? db)]}
(sqlite-schema/->SQLite x))
(defn datoms-source [db]
(source/map->DatomsSource
{:table :datoms
:schema (:schema db)
:fulltext-table :fulltext_datoms
:fulltext-values :fulltext_values
:fulltext-view :all_datoms
:columns [:e :a :v :tx :added]
:attribute-transform (partial datoms-attribute-transform db)
:constant-transform (partial datoms-constant-transform db)
:table-alias source/gensym-table-alias
:make-constraints nil}))
(defn- retractions->queries [retractions tx fulltext? ->SQLite]
(let
[f-q
"WITH vv AS (SELECT rowid FROM fulltext_values WHERE text = ?)
INSERT INTO tx_lookup (e0, a0, v0, tx0, added0, value_type_tag0, sv, svalue_type_tag)
VALUES (?, ?, (SELECT rowid FROM vv), ?, 0, ?, (SELECT rowid FROM vv), ?)"
non-f-q
"INSERT INTO tx_lookup (e0, a0, v0, tx0, added0, value_type_tag0, sv, svalue_type_tag)
VALUES (?, ?, ?, ?, 0, ?, ?, ?)"]
(map
(fn [[_ e a v]]
(let [[v tag] (->SQLite a v)]
(if (fulltext? a)
[f-q
v e a tx tag tag]
[non-f-q
e a v tx tag v tag])))
retractions)))
(defn- non-fts-many->queries [ops tx ->SQLite indexing? ref? unique?]
(let [q "INSERT INTO tx_lookup (e0, a0, v0, tx0, added0, value_type_tag0, index_avet0, index_vaet0, index_fulltext0, unique_value0, sv, svalue_type_tag) VALUES "
values-part
;; e0, a0, v0, tx0, added0, value_type_tag0
;; index_avet0, index_vaet0, index_fulltext0,
;; unique_value0, sv, svalue_type_tag
"(?, ?, ?, ?, 1, ?, ?, ?, 0, ?, ?, ?)"
repeater (memoize (fn [n] (interpose ", " (repeat n values-part))))]
;; This query takes ten variables per item. So we partition into max-sql-vars / 10.
(map
(fn [chunk]
(cons
;; Query string.
(apply str q (repeater (count chunk)))
;; Bindings.
(mapcat (fn [[_ e a v]]
(let [[v tag] (->SQLite a v)]
[e a v tx tag
(indexing? a) ; index_avet
(ref? a) ; index_vaet
(unique? a) ; unique_value
v tag]))
chunk)))
(partition-all (quot max-sql-vars 10) ops))))
(defn- non-fts-one->queries [ops tx ->SQLite indexing? ref? unique?]
(let [first-values-part
;; TODO: order value and tag closer together.
;; flags0
;; sv, svalue_type_tag
"(?, ?, ?, ?, ?, ?, ?, ?, 0, ?, ?, ?)"
first-repeater (memoize (fn [n] (interpose ", " (repeat n first-values-part))))
second-values-part
"(?, ?, ?, ?, ?, ?)"
second-repeater (memoize (fn [n] (interpose ", " (repeat n second-values-part))))
]
;; :db.cardinality/one takes two queries.
(mapcat
(fn [chunk]
[(cons
(apply
str
"INSERT INTO tx_lookup (e0, a0, v0, tx0, added0, value_type_tag0, index_avet0, index_vaet0, index_fulltext0, unique_value0, sv, svalue_type_tag) VALUES "
(first-repeater (count chunk)))
(mapcat (fn [[_ e a v]]
(let [[v tag] (->SQLite a v)]
[e a v tx 1 tag
(indexing? a) ; index_avet
(ref? a) ; index_vaet
(unique? a) ; unique_value
v tag]))
chunk))
(cons
(apply
str
"INSERT INTO tx_lookup (e0, a0, v0, tx0, added0, value_type_tag0) VALUES "
(second-repeater (count chunk)))
(mapcat (fn [[_ e a v]]
(let [[v tag] (->SQLite a v)]
[e a v tx 0 tag]))
chunk))])
(partition-all (quot max-sql-vars 11) ops))))
(def initial-many-searchid 2000) ; Just to make it more obvious in the DB.
(def initial-one-searchid 5000)
;;; An FTS insertion happens in two parts.
;;;
;;; Firstly, we ensure that the fulltext value is present in the store.
;;; This is effectively an INSERT OR IGNORE… but FTS tables don't support
;;; uniqueness constraints. So we do it through a trigger on a view.
;;;
;;; When we insert the value, we pass with it a searchid. We'll use this
;;; later when inserting the datom, then we'll throw it away. The FTS table
;;; only contains searchids for the duration of the transaction that uses
;;; them.
;;;
;;; Secondly, we insert a row just like for non-FTS. The only difference
;;; is that the value is the rowid into the fulltext_values table.
(defn- fts-many->queries [ops tx ->SQLite indexing? ref? unique?]
;; TODO: operations with the same text value should be
;; coordinated here!
;; It'll work fine without so long as queries are executed
;; in order and not combined, but even so it's inefficient.
(conj
(mapcat
(fn [[_ e a v] searchid]
(let [[v tag] (->SQLite a v)]
;; First query: ensure the value exists.
[["INSERT INTO fulltext_values_view (text, searchid) VALUES (?, ?)"
v searchid]
;; Second query: tx_lookup.
[(str
"WITH vv(rowid) AS (SELECT rowid FROM fulltext_values WHERE searchid = ?) "
"INSERT INTO tx_lookup (e0, a0, v0, tx0, added0, value_type_tag0, index_avet0, index_vaet0, index_fulltext0, unique_value0, sv, svalue_type_tag) VALUES "
"(?, ?, (SELECT rowid FROM vv), ?, 1, ?, ?, ?, 1, ?, (SELECT rowid FROM vv), ?)")
searchid
e a tx tag
(indexing? a) ; index_avet
(ref? a) ; index_vaet
(unique? a) ; unique_value
tag]]))
ops
(range initial-many-searchid 999999999))
["UPDATE fulltext_values SET searchid = NULL WHERE searchid IS NOT NULL"]))
(defn fts-one->queries [ops tx ->SQLite indexing? ref? unique?]
(conj
(mapcat
(fn [[_ e a v] searchid]
(let [[v tag] (->SQLite a v)]
;; First query: ensure the value exists.
[["INSERT INTO fulltext_values_view (text, searchid) VALUES (?, ?)"
v searchid]
;; Second and third queries: tx_lookup.
[(str
"WITH vv(rowid) AS (SELECT rowid FROM fulltext_values WHERE searchid = ?) "
"INSERT INTO tx_lookup (e0, a0, v0, tx0, added0, value_type_tag0, index_avet0, index_vaet0, index_fulltext0, unique_value0, sv, svalue_type_tag) VALUES "
"(?, ?, (SELECT rowid FROM vv), ?, 1, ?, ?, ?, 1, ?, (SELECT rowid FROM vv), ?)")
searchid
e a tx tag
(indexing? a) ; index_avet
(ref? a) ; index_vaet
(unique? a) ; unique_value
tag]
[(str
"INSERT INTO tx_lookup (e0, a0, v0, tx0, added0, value_type_tag0) VALUES "
"(?, ?, (SELECT rowid FROM fulltext_values WHERE searchid = ?), ?, 0, ?)")
e a searchid tx tag]]))
ops
(range initial-one-searchid 999999999))
["UPDATE fulltext_values SET searchid = NULL WHERE searchid IS NOT NULL"]))
(defn- -run-queries [conn queries exception-message]
(go-pair
(try
(doseq [q queries]
(<? (s/execute! conn q)))
(catch #?(:clj java.sql.SQLException :cljs js/Error) e
(throw (ex-info exception-message {} e))))))
(defn- -preamble-drop [conn]
(let [preamble-drop-index ["DROP INDEX IF EXISTS id_tx_lookup_added"]
preamble-delete-tx-lookup ["DELETE FROM tx_lookup"]]
(go-pair
(p :preamble
(doseq [q [preamble-drop-index preamble-delete-tx-lookup]]
(<? (s/execute! conn q)))))))
(defn- -after-drop [conn]
(go-pair
(doseq [q [;; The lookup table takes space on disk, so we purge it aggressively.
["DROP INDEX IF EXISTS id_tx_lookup_added"]
["DELETE FROM tx_lookup"]]]
(<? (s/execute! conn q)))))
(defn- -build-transaction [conn tx]
(let [build-indices ["CREATE INDEX IF NOT EXISTS idx_tx_lookup_added ON tx_lookup (added0)"]
;; First is fast, only one table walk: lookup by exact eav.
;; Second is slower, but still only one table walk: lookup old value by ea.
insert-into-tx-lookup
["INSERT INTO tx_lookup
SELECT t.e0, t.a0, t.v0, t.tx0, t.added0 + 2, t.value_type_tag0, t.index_avet0, t.index_vaet0, t.index_fulltext0, t.unique_value0, t.sv, t.svalue_type_tag, d.rowid, d.e, d.a, d.v, d.tx, d.value_type_tag
FROM tx_lookup AS t
LEFT JOIN datoms AS d
ON t.e0 = d.e AND
t.a0 = d.a AND
t.sv = d.v AND
t.svalue_type_tag = d.value_type_tag AND
t.sv IS NOT NULL
UNION ALL
SELECT t.e0, t.a0, t.v0, t.tx0, t.added0 + 2, t.value_type_tag0, t.index_avet0, t.index_vaet0, t.index_fulltext0, t.unique_value0, t.sv, t.svalue_type_tag, d.rowid, d.e, d.a, d.v, d.tx, d.value_type_tag
FROM tx_lookup AS t,
datoms AS d
WHERE t.sv IS NULL AND
t.e0 = d.e AND
t.a0 = d.a"]
t-datoms-not-already-present
["INSERT INTO transactions (e, a, v, tx, added, value_type_tag)
SELECT e0, a0, v0, ?, 1, value_type_tag0
FROM tx_lookup
WHERE added0 IS 3 AND e IS NULL" tx] ;; TODO: get rid of magic value 3.
t-retract-datoms-carefully
["INSERT INTO transactions (e, a, v, tx, added, value_type_tag)
SELECT e, a, v, ?, 0, value_type_tag
FROM tx_lookup
WHERE added0 IS 2 AND ((sv IS NOT NULL) OR (sv IS NULL AND v0 IS NOT v)) AND v IS NOT NULL" tx] ;; TODO: get rid of magic value 2.
]
(go-pair
(doseq [q [build-indices insert-into-tx-lookup
t-datoms-not-already-present
t-retract-datoms-carefully]]
(<? (s/execute! conn q))))))
(defn- -build-datoms [conn tx]
(let [d-datoms-not-already-present
["INSERT INTO datoms (e, a, v, tx, value_type_tag, index_avet, index_vaet, index_fulltext, unique_value)
SELECT e0, a0, v0, ?, value_type_tag0,
index_avet0, index_vaet0, index_fulltext0, unique_value0
FROM tx_lookup
WHERE added0 IS 3 AND e IS NULL" tx] ;; TODO: get rid of magic value 3.
;; TODO: retract fulltext datoms correctly.
d-retract-datoms-carefully
["WITH ids AS (SELECT l.rid FROM tx_lookup AS l WHERE l.added0 IS 2 AND ((l.sv IS NOT NULL) OR (l.sv IS NULL AND l.v0 IS NOT l.v)))
DELETE FROM datoms WHERE rowid IN ids" ;; TODO: get rid of magic value 2.
]]
(-run-queries conn [d-datoms-not-already-present d-retract-datoms-carefully]
"Transaction violates unique constraint")))
(defn- -<apply-entities [db tx entities]
(let [schema (.-schema db)
->SQLite (partial ds/->SQLite schema)
fulltext? (memoize (partial ds/fulltext? schema))
many? (memoize (fn [a] (ds/multival? schema a)))
indexing? (memoize (fn [a] (ds/indexing? schema a)))
ref? (memoize (fn [a] (ds/ref? schema a)))
unique? (memoize (fn [a] (ds/unique? schema a)))
conn (:sqlite-connection db)
;; Collect all the queries we need to run.
queries (atom [])
operations (group-by first entities)]
(when-not (clojure.set/subset? (keys operations) #{:db/retract :db/add})
(raise (str "Unknown operations " (keys operations))
{:error :transact/syntax, :operations (dissoc operations :db/retract :db/add)}))
;; We can turn all non-FTS operations into simple SQL queries that we run serially.
;; FTS queries require us to get a rowid from the FTS table and use that for
;; insertion, so we need another pass.
;; We can't just freely use `go-pair` here, because this function is so complicated
;; that ClojureScript blows the stack trying to compile it.
(when-let [retractions (:db/retract operations)]
(swap!
queries concat (retractions->queries retractions tx fulltext? ->SQLite)))
;; We want to partition our additions into four groups according to two
;; characteristics: whether they require writing to the FTS value table,
;; and whether the attribute has a 'many' cardinality constraint. Each of
;; these four requires different queries.
(let [additions
(group-by (fn [[op e a v]]
(if (fulltext? a)
(if (many? a)
:fts-many
:fts-one)
(if (many? a)
:non-fts-many
:non-fts-one)))
(:db/add operations))
transforms
{:fts-one fts-one->queries
:fts-many fts-many->queries
:non-fts-one non-fts-one->queries
:non-fts-many non-fts-many->queries}]
(doseq [[key ops] additions]
(when-let [transform (key transforms)]
(swap!
queries concat
(transform ops tx ->SQLite indexing? ref? unique?)))))
;; Now run each query.
;; This code is a little tortured to avoid blowing the compiler stack in cljs.
(go-pair
(<? (-preamble-drop conn))
(p :run-insert-queries
(<? (-run-queries conn @queries "Transaction violates cardinality constraint")))
;; Follow up by building indices, then do the work.
(p :build-and-transaction
(<? (-build-transaction conn tx)))
(p :update-materialized-datoms
(<? (-build-datoms conn tx)))
(<? (-after-drop conn))
;; Return the written transaction.
(p :select-tx-data
(mapv (partial row->Datom schema)
(<?
(s/all-rows
(:sqlite-connection db)
;; We index on tx, so the following is fast.
["SELECT * FROM transactions WHERE tx = ?" tx])))))))
(defrecord DB [sqlite-connection schema ident-map]
;; ident-map maps between keyword idents and integer entids. The set of idents and entids is
;; disjoint, so we represent both directions of the mapping in the same map for simplicity. Also
;; for simplicity, we assume that an entid has at most one associated ident, and vice-versa. See
;; http://docs.datomic.com/identity.html#idents.
;; TODO: cache parts. parts looks like {:db.part/db {:start 0 :current 10}}. It maps between
;; keyword ident part names and integer ranges.
IDB IDB
(query-context [db] (context/->Context (source/datoms-source db) nil nil)) (query-context [db] (context/make-context (datoms-source db)))
(schema [db] (.-schema db)) (schema [db] (.-schema db))
(idents [db] (.-idents db)) (entid [db ident]
(if (keyword? ident)
(get (.-ident-map db) ident ident)
ident))
(current-tx (ident [db eid]
[db] (if-not (keyword? eid)
(inc (:current-tx db))) (get (.-ident-map db) eid eid)
eid))
(in-transaction! [db chan-fn] (in-transaction! [db chan-fn]
(s/in-transaction! (s/in-transaction!
(:sqlite-connection db) chan-fn)) (:sqlite-connection db) chan-fn))
;; TODO: use q for searching? Have q use this for searching for a single pattern? (<bootstrapped? [db]
(<eavt [db pattern]
(let [[e a v] pattern
v (and v (ds/->SQLite schema a v))] ;; We assume e and a are always given.
(go-pair
(->>
{:select [:e :a :v :tx [1 :added]] ;; TODO: generalize columns.
:from [:all_datoms]
:where (cons :and (map #(vector := %1 %2) [:e :a :v] (take-while (comp not nil?) [e a v])))} ;; Must drop nils.
(s/format)
(s/all-rows (:sqlite-connection db))
(<?)
(mapv (partial row->Datom (.-schema db))))))) ;; TODO: understand why (schema db) fails.
(<avet [db pattern]
(let [[a v] pattern
v (ds/->SQLite schema a v)]
(go-pair
(->>
{:select [:e :a :v :tx [1 :added]] ;; TODO: generalize columns.
:from [:all_datoms]
:where [:and [:= :a a] [:= :v v] [:= :index_avet 1]]}
(s/format)
(s/all-rows (:sqlite-connection db))
(<?)
(mapv (partial row->Datom (.-schema db))))))) ;; TODO: understand why (schema db) fails.
(<apply-datoms [db datoms]
(go-pair (go-pair
(let [exec (partial s/execute! (:sqlite-connection db)) (->
schema (.-schema db)] ;; TODO: understand why (schema db) fails. (:sqlite-connection db)
;; TODO: batch insert, batch delete. (s/all-rows ["SELECT EXISTS(SELECT 1 FROM transactions LIMIT 1) AS bootstrapped"])
(doseq [datom datoms] (<?)
(let [[e a v tx added] datom (first)
v (ds/->SQLite schema a v) (:bootstrapped)
fulltext? (ds/fulltext? schema a)] (not= 0))))
;; Append to transaction log.
(<? (exec
["INSERT INTO transactions VALUES (?, ?, ?, ?, ?)" e a v tx (if added 1 0)]))
;; Update materialized datom view.
(if (.-added datom)
(let [v (if fulltext?
(<? (<insert-fulltext-value db v))
v)]
(<? (exec
["INSERT INTO datoms VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?)" e a v tx
(ds/indexing? schema a) ;; index_avet
(ds/ref? schema a) ;; index_vaet
fulltext? ;; index_fulltext
(ds/unique-value? schema a) ;; unique_value
(ds/unique-identity? schema a) ;; unique_identity
])))
(if fulltext?
(<? (exec
;; TODO: in the future, purge fulltext values from the fulltext_datoms table.
["DELETE FROM datoms WHERE (e = ? AND a = ? AND v IN (SELECT rowid FROM fulltext_values WHERE text = ?))" e a v]))
(<? (exec
["DELETE FROM datoms WHERE (e = ? AND a = ? AND v = ?)" e a v])))))))
db))
(<advance-tx [db] (<av [db a v]
(let [schema (.-schema db) ;; TODO: understand why (schema db) fails.
a (entid db a)
[v tag] (ds/->SQLite schema a v)
yield-datom
(fn [rows]
(when-let [row (first rows)]
(row->Datom schema row)))]
(go-pair
(->>
;; TODO: generalize columns.
["SELECT e, a, v, tx, 1 AS added FROM all_datoms
WHERE index_avet = 1 AND a = ? AND value_type_tag = ? AND v = ?
LIMIT 1" a tag v]
(s/all-rows (:sqlite-connection db))
<?
yield-datom))))
(<next-eid [db tempid]
{:pre [(id-literal? tempid)]}
{:post [ds/entid?]}
(go-pair
;; TODO: keep all of these eid allocations in the transaction report and apply them at the end
;; of the transaction.
(let [exec (partial s/execute! (:sqlite-connection db))
part (entid db (:part tempid))]
(when-not (ds/entid? part) ;; TODO: cache parts materialized view.
(raise "Cannot allocate entid for id-literal " tempid " because part " (:part tempid) " is not known"
{:error :db/bad-part
:part (:part tempid)}))
(p :next-eid-body
(<? (exec ["UPDATE parts SET idx = idx + 1 WHERE part = ?" part]))
(:eid (first (<? (s/all-rows (:sqlite-connection db) ["SELECT (start + idx) AS eid FROM parts WHERE part = ?" part]))))))))
(<apply-entities [db tx entities]
{:pre [(db? db) (sequential? entities)]}
(-<apply-entities db tx entities))
(<apply-db-ident-assertions [db added-idents merge]
(go-pair (go-pair
(let [exec (partial s/execute! (:sqlite-connection db))] (let [exec (partial s/execute! (:sqlite-connection db))]
;; (let [ret (<? (exec
;; ;; TODO: be more clever about UPDATE OR ...?
;; ["UPDATE metadata SET current_tx = ? WHERE current_tx = ?" (inc (:current-tx db)) (:current-tx db)]))]
;; TODO: handle exclusion across transactions here.
(update db :current-tx inc))))
(<apply-db-ident-assertions [db added-idents]
(go-pair
(let [->SQLite (get-in ds/value-type-map [:db.type/keyword :->SQLite]) ;; TODO: make this a protocol.
exec (partial s/execute! (:sqlite-connection db))]
;; TODO: batch insert. ;; TODO: batch insert.
(doseq [[ident entid] added-idents] (doseq [[ident entid] added-idents]
(<? (exec (<? (exec
["INSERT INTO idents VALUES (?, ?)" (->SQLite ident) entid])))) ["INSERT INTO idents VALUES (?, ?)" (sqlite-schema/->SQLite ident) entid]))))
db))
(<apply-db-install-assertions [db fragment] (let [db (update db :ident-map #(merge-with merge % added-idents))
db (update db :ident-map #(merge-with merge % (clojure.set/map-invert added-idents)))]
db)))
(<apply-db-install-assertions [db fragment merge]
(go-pair (go-pair
(let [->SQLite (get-in ds/value-type-map [:db.type/keyword :->SQLite]) ;; TODO: make this a protocol. (let [exec (partial s/execute! (:sqlite-connection db))]
exec (partial s/execute! (:sqlite-connection db))]
;; TODO: batch insert. ;; TODO: batch insert.
(doseq [[ident attr-map] fragment] (doseq [[ident attr-map] fragment]
(doseq [[attr value] attr-map] (doseq [[attr value] attr-map]
(<? (exec (<? (exec
["INSERT INTO schema VALUES (?, ?, ?)" (->SQLite ident) (->SQLite attr) (->SQLite value)]))))) ["INSERT INTO schema VALUES (?, ?, ?)" (sqlite-schema/->SQLite ident) (sqlite-schema/->SQLite attr) (sqlite-schema/->SQLite value)])))))
db))
(let [symbolic-schema (merge-with merge (:symbolic-schema db) fragment)
schema (ds/schema (into {} (map (fn [[k v]] [(entid db k) v]) symbolic-schema)))]
(assoc db
:symbolic-schema symbolic-schema
:schema schema))))
(close-db [db] (s/close (.-sqlite-connection db))) (close-db [db] (s/close (.-sqlite-connection db)))
@ -261,6 +609,24 @@
:cljs :cljs
(.getTime (js/Date.))))) (.getTime (js/Date.)))))
(defn with-ident [db ident entid]
(update db :ident-map #(assoc % ident entid, entid ident)))
(defn db [sqlite-connection idents schema]
{:pre [(map? idents)
(every? keyword? (keys idents))
(map? schema)
(every? keyword? (keys schema))]}
(let [entid-schema (ds/schema (into {} (map (fn [[k v]] [(k idents) v]) schema))) ;; TODO: fail if ident missing.
ident-map (into idents (clojure.set/map-invert idents))]
(map->DB
{:sqlite-connection sqlite-connection
:ident-map ident-map
:symbolic-schema schema
:schema entid-schema
;; TODO :parts
})))
;; TODO: factor this into the overall design. ;; TODO: factor this into the overall design.
(defn <?run (defn <?run
"Execute the provided query on the provided DB. "Execute the provided query on the provided DB.

59
src/datomish/db/debug.cljc Normal file
View file

@ -0,0 +1,59 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
(ns datomish.db.debug
#?(:cljs
(:require-macros
[datomish.pair-chan :refer [go-pair <?]]
[cljs.core.async.macros :refer [go]]))
(:require
[datomish.db :as db]
[datomish.datom :as dd :refer [datom datom? #?@(:cljs [Datom])]]
[datomish.util :as util #?(:cljs :refer-macros :clj :refer) [raise raise-str cond-let]]
[datomish.sqlite :as s]
#?@(:clj [[datomish.pair-chan :refer [go-pair <?]]
[clojure.core.async :as a :refer [chan go <! >!]]])
#?@(:cljs [[datomish.pair-chan]
[cljs.core.async :as a :refer [chan <! >!]]]))
#?(:clj
(:import
[datomish.datom Datom])))
(defn <datoms-after [db tx]
(go-pair
(->>
(s/all-rows (:sqlite-connection db) ["SELECT e, a, v, tx FROM datoms WHERE tx > ?" tx])
(<?)
(mapv #(vector (:e %) (db/ident db (:a %)) (:v %)))
(filter #(not (= :db/txInstant (second %))))
(set))))
(defn <datoms [db]
(<datoms-after db 0))
(defn <shallow-entity [db eid]
;; TODO: make this actually be <entity. Handle :db.cardinality/many and :db/isComponent.
(go-pair
(->>
(s/all-rows (:sqlite-connection db) ["SELECT a, v FROM datoms WHERE e = ?" eid])
(<?)
(mapv #(vector (db/ident db (:a %)) (:v %)))
(reduce conj {}))))
(defn <transactions-after [db tx]
(go-pair
(->>
(s/all-rows (:sqlite-connection db) ["SELECT e, a, v, tx, added FROM transactions WHERE tx > ? ORDER BY tx ASC, e, a, v, added" tx])
(<?)
(mapv #(vector (:e %) (db/ident db (:a %)) (:v %) (:tx %) (:added %))))))
(defn <transactions [db]
(<transactions-after db 0))
(defn <fulltext-values [db]
(go-pair
(->>
(s/all-rows (:sqlite-connection db) ["SELECT rowid, text FROM fulltext_values"])
(<?)
(mapv #(vector (:rowid %) (:text %))))))

115
src/datomish/db_factory.cljc
View file

@ -23,60 +23,58 @@
(:import (:import
[datomish.datom Datom]))) [datomish.datom Datom])))
;; TODO: implement support for DB parts?
(def tx0 0x2000000)
(defn <idents [sqlite-connection] (defn <idents [sqlite-connection]
"Read the ident map materialized view from the given SQLite store. "Read the ident map materialized view from the given SQLite store.
Returns a map (keyword ident) -> (integer entid), like {:db/ident 0}." Returns a map (keyword ident) -> (integer entid), like {:db/ident 0}."
(let [<-SQLite (get-in ds/value-type-map [:db.type/keyword :<-SQLite])] ;; TODO: make this a protocol.
(go-pair
(let [rows (<? (->>
{:select [:ident :entid] :from [:idents]}
(s/format)
(s/all-rows sqlite-connection)))]
(into {} (map (fn [row] [(<-SQLite (:ident row)) (:entid row)])) rows)))))
(defn <current-tx [sqlite-connection]
"Find the largest tx written to the SQLite store.
Returns an integer, -1 if no transactions have been written yet."
(go-pair (go-pair
(let [rows (<? (s/all-rows sqlite-connection ["SELECT COALESCE(MAX(tx), -1) AS current_tx FROM transactions"]))] (let [rows (<? (->>
(:current_tx (first rows))))) {:select [:ident :entid] :from [:idents]}
(s/format)
(s/all-rows sqlite-connection)))]
(into {} (map (fn [row] [(sqlite-schema/<-SQLite :db.type/keyword (:ident row)) (:entid row)])) rows))))
(defn <symbolic-schema [sqlite-connection] (defn <symbolic-schema [sqlite-connection]
"Read the schema map materialized view from the given SQLite store. "Read the schema map materialized view from the given SQLite store.
Returns a map (keyword ident) -> (map (keyword attribute -> keyword value)), like Returns a map (keyword ident) -> (map (keyword attribute -> keyword value)), like
{:db/ident {:db/cardinality :db.cardinality/one}}." {:db/ident {:db/cardinality :db.cardinality/one}}."
(let [<-SQLite (get-in ds/value-type-map [:db.type/keyword :<-SQLite])] ;; TODO: make this a protocol. (go-pair
(go-pair (->>
(->> (->>
(->> {:select [:ident :attr :value] :from [:schema]}
{:select [:ident :attr :value] :from [:schema]} (s/format)
(s/format) (s/all-rows sqlite-connection))
(s/all-rows sqlite-connection)) (<?)
(<?)
(group-by (comp <-SQLite :ident)) (group-by (comp (partial sqlite-schema/<-SQLite :db.type/keyword) :ident))
(map (fn [[ident rows]] (map (fn [[ident rows]]
[ident [ident
(into {} (map (fn [row] (into {} (map (fn [row]
[(<-SQLite (:attr row)) (<-SQLite (:value row))]) rows))])) [(sqlite-schema/<-SQLite :db.type/keyword (:attr row))
(into {}))))) (sqlite-schema/<-SQLite :db.type/keyword (:value row))]) rows))])) ;; TODO: this is wrong, it doesn't handle true.
(into {}))))
(defn <initialize-connection [sqlite-connection]
(go-pair
;; Some of these return values when set, and some don't, hence the craziness here.
(<? (s/execute! sqlite-connection ["PRAGMA page_size=32768"]))
(<? (s/all-rows sqlite-connection ["PRAGMA journal_mode=wal"]))
(<? (s/all-rows sqlite-connection ["PRAGMA wal_autocheckpoint=32"]))
(<? (s/all-rows sqlite-connection ["PRAGMA journal_size_limit=3145728"]))
(<? (s/execute! sqlite-connection ["PRAGMA foreign_keys=ON"]))))
(defn <db-with-sqlite-connection (defn <db-with-sqlite-connection
[sqlite-connection] [sqlite-connection]
(go-pair (go-pair
(<? (<initialize-connection sqlite-connection))
(when-not (= sqlite-schema/current-version (<? (sqlite-schema/<ensure-current-version sqlite-connection))) (when-not (= sqlite-schema/current-version (<? (sqlite-schema/<ensure-current-version sqlite-connection)))
(raise "Could not ensure current SQLite schema version.")) (raise "Could not ensure current SQLite schema version."))
(let [current-tx (<? (<current-tx sqlite-connection)) (let [db (db/db sqlite-connection bootstrap/idents bootstrap/symbolic-schema)
bootstrapped (>= current-tx 0) bootstrapped? (<? (db/<bootstrapped? db))]
current-tx (max current-tx tx0)] (when-not bootstrapped?
(when-not bootstrapped
;; We need to bootstrap the DB. ;; We need to bootstrap the DB.
(let [fail-alter-ident (fn [old new] (if-not (= old new) (let [fail-alter-ident (fn [old new] (if-not (= old new)
(raise "Altering idents is not yet supported, got " new " altering existing ident " old (raise "Altering idents is not yet supported, got " new " altering existing ident " old
@ -86,39 +84,40 @@
(raise "Altering schema attributes is not yet supported, got " new " altering existing schema attribute " old (raise "Altering schema attributes is not yet supported, got " new " altering existing schema attribute " old
{:error :schema/alter-schema :old old :new new}) {:error :schema/alter-schema :old old :new new})
new))] new))]
(-> (db/map->DB (do
{:sqlite-connection sqlite-connection (let [exec (partial s/execute! (:sqlite-connection db))]
:idents bootstrap/idents ;; TODO: allow inserting new parts.
:symbolic-schema bootstrap/symbolic-schema ;; TODO: think more carefully about allocating new parts and bitmasking part ranges.
:schema (ds/schema (into {} (map (fn [[k v]] [(k bootstrap/idents) v]) bootstrap/symbolic-schema))) ;; TODO: fail if ident missing. (<? (exec
:current-tx current-tx}) ["INSERT INTO parts VALUES (?, ?, ?)" (db/entid db :db.part/db) 0x0 (inc (apply max (vals bootstrap/idents)))]))
;; We use <with-internal rather than <transact! to apply the bootstrap transaction (<? (exec
;; data but to not follow the regular schema application process. We can't apply the ["INSERT INTO parts VALUES (?, ?, ?)" (db/entid db :db.part/user) 0x10000 0]))
;; schema changes, since the applied datoms would conflict with the bootstrapping (<? (exec
;; idents and schema. (The bootstrapping idents and schema are required to be able to ["INSERT INTO parts VALUES (?, ?, ?)" (db/entid db :db.part/tx) 0x10000000 0])))
;; write to the database conveniently; without them, we'd have to manually write (-> db
;; datoms to the store. It's feasible but awkward.) After bootstrapping, we read ;; We use <with-internal rather than <transact! to apply the bootstrap transaction
;; back the idents and schema, just like when we re-open. ;; data but to not follow the regular schema application process. We can't apply the
(transact/<with-internal (bootstrap/tx-data) fail-alter-ident fail-alter-attr) ;; schema changes, since the applied datoms would conflict with the bootstrapping
(<?)))) ;; idents and schema. (The bootstrapping idents and schema are required to be able to
;; write to the database conveniently; without them, we'd have to manually write
;; datoms to the store. It's feasible but awkward.) After bootstrapping, we read
;; back the idents and schema, just like when we re-open.
(transact/<with-internal (bootstrap/tx-data) fail-alter-ident fail-alter-attr)
(<?)))))
;; We just bootstrapped, or we are returning to an already bootstrapped DB. ;; We just bootstrapped, or we are returning to an already bootstrapped DB.
(let [idents (<? (<idents sqlite-connection)) (let [idents (<? (<idents sqlite-connection))
symbolic-schema (<? (<symbolic-schema sqlite-connection))] symbolic-schema (<? (<symbolic-schema sqlite-connection))]
(when-not bootstrapped (when-not bootstrapped?
;; TODO: parts.
(when (not (= idents bootstrap/idents)) (when (not (= idents bootstrap/idents))
(raise "After bootstrapping database, expected new materialized idents and old bootstrapped idents to be identical" (raise "After bootstrapping database, expected new materialized idents and old bootstrapped idents to be identical"
{:error :bootstrap/bad-idents, {:error :bootstrap/bad-idents,
:new idents :old bootstrap/idents :new idents :old bootstrap/idents
})) }))
(when (not (= symbolic-schema bootstrap/symbolic-schema)) (when (not (= symbolic-schema bootstrap/symbolic-schema))
(raise "After bootstrapping database, expected new materialized symbolic schema and old bootstrapped symbolic schema to be identical" (raise "After bootstrapping database, expected new materialized symbolic schema and old bootstrapped symbolic schema to be identical"
{:error :bootstrap/bad-symbolic-schema, {:error :bootstrap/bad-symbolic-schema,
:new symbolic-schema :old bootstrap/symbolic-schema :new symbolic-schema :old bootstrap/symbolic-schema
}))) })))
(db/map->DB (db/db sqlite-connection idents symbolic-schema)))))
{:sqlite-connection sqlite-connection
:idents idents
:symbolic-schema symbolic-schema
:schema (ds/schema (into {} (map (fn [[k v]] [(k idents) v]) symbolic-schema))) ;; TODO: fail if ident missing.
:current-tx (inc current-tx)})))))

22
src/datomish/exec_repl.cljc
View file

@ -9,6 +9,7 @@
[datomish.pair-chan :refer [go-pair <?]] [datomish.pair-chan :refer [go-pair <?]]
[cljs.core.async.macros :refer [go]])) [cljs.core.async.macros :refer [go]]))
(:require (:require
[datomish.db-factory]
[datomish.db :as db] [datomish.db :as db]
[datomish.sqlite :as s] [datomish.sqlite :as s]
[datomish.sqlite-schema :as ss] [datomish.sqlite-schema :as ss]
@ -44,7 +45,7 @@
#_ #_
(defn xxopen [] (defn xxopen []
(datomish.pair-chan/go-pair (datomish.pair-chan/go-pair
(let [d (datomish.pair-chan/<? (s/<sqlite-connection "/tmp/foo.sqlite"))] (let [d (datomish.pair-chan/<? (s/<sqlite-connection "/tmp/import.sqlite"))]
(clojure.core.async/<!! (ss/<ensure-current-version d)) (clojure.core.async/<!! (ss/<ensure-current-version d))
(def db d)))) (def db d))))
@ -59,19 +60,26 @@
"/tmp/foo.sqlite" "/tmp/foo.sqlite"
'[:find ?page :in $ :where [?page :page/starred true ?t]])) '[:find ?page :in $ :where [?page :page/starred true ?t]]))
#_(require 'datomish.exec-repl)
#_(in-ns 'datomish.exec-repl)
#_ #_
(go-pair (go-pair
(let [connection (<? (s/<sqlite-connection "/tmp/foo.sqlite")) (let [connection (<? (s/<sqlite-connection "/tmp/bigport.db"))
d (<? (db/<with-sqlite-connection connection))] d (<? (datomish.db-factory/<db-with-sqlite-connection connection))]
(println (def db d)))
"Result: "
(<! (db/<?q d '[:find ?page :in $ :where [?page :page/starred true ?t]] {}))))) #_
(go-pair
(println (count (first (time
(<! (db/<?q db
'[:find ?url ?title :in $ :where
[?page :page/visitAt ?v] [(> ?v 1438748166567751)] [?page :page/title ?title] [?page :page/url ?url] ] {})))))))
#_ #_
(go-pair (go-pair
(let [connection (<? (s/<sqlite-connection "/tmp/foo.sqlite")) (let [connection (<? (s/<sqlite-connection "/tmp/foo.sqlite"))
dd (<? (db/<with-sqlite-connection connection))] dd (<? (datomish.db-factory/<db-with-sqlite-connection connection))]
(def *db* dd))) (def *db* dd)))
#_ #_
(clojure.core.async/<!! (clojure.core.async/<!!

1
src/datomish/jdbc_sqlite.clj
View file

@ -31,6 +31,7 @@
(defn open (defn open
[path & {:keys [mode]}] [path & {:keys [mode]}]
(let [spec {:classname "org.sqlite.JDBC" (let [spec {:classname "org.sqlite.JDBC"
:identifiers identity
:subprotocol "sqlite" :subprotocol "sqlite"
:subname path}] ;; TODO: use mode. :subname path}] ;; TODO: use mode.
(go-pair (go-pair

101
src/datomish/places/import.cljc Normal file
View file

@ -0,0 +1,101 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
(ns datomish.places.import
#?(:cljs
(:require-macros
[datomish.pair-chan :refer [go-pair <?]]
[cljs.core.async.macros :refer [go]]))
(:require
[datomish.db :as db]
[datomish.transact :as transact]
[datomish.util :as util #?(:cljs :refer-macros :clj :refer) [raise raise-str cond-let]]
[datomish.sqlite :as s]
#?@(:clj [[datomish.pair-chan :refer [go-pair <?]]
[clojure.core.async :as a :refer [chan go <! >!]]])
#?@(:cljs [[datomish.pair-chan]
[cljs.core.async :as a :refer [chan <! >!]]])))
(def places-schema-fragment
[{:db/id (db/id-literal :db.part/user)
:db/ident :page/url
:db/unique :db.unique/identity
:db/valueType :db.type/string ;; TODO: uri
:db.install/_attribute :db.part/db}
{:db/id (db/id-literal :db.part/user)
:db/ident :page/guid
:db/unique :db.unique/identity
:db/valueType :db.type/string ;; TODO: uuid or guid?
:db.install/_attribute :db.part/db}
{:db/id (db/id-literal :db.part/user)
:db/ident :page/title
:db/cardinality :db.cardinality/one
:db/valueType :db.type/string
:db.install/_attribute :db.part/db}
{:db/id (db/id-literal :db.part/user)
:db/ident :page/visitAt
:db/cardinality :db.cardinality/many
:db/valueType :db.type/long ;; TODO: instant
:db.install/_attribute :db.part/db}
])
(defn- place->entity [[id rows]]
(let [title (:title (first rows))
required {:db/id (db/id-literal :db.part/user)
:page/url (:url (first rows))
:page/guid (:guid (first rows))}
visits (keep :visit_date rows)]
(util/assoc-if required
:page/title title
:page/visitAt visits)))
(defn import-titles [conn places-connection]
(go-pair
(let [rows
(<?
(s/all-rows
places-connection
["SELECT DISTINCT p.title AS title, p.guid
FROM moz_places AS p
WHERE p.title IS NOT NULL AND p.hidden = 0 LIMIT 10"]))]
(<?
(transact/<transact!
conn
(map (fn [row]
{:db/id [:page/guid (:guid row)]
:page/title (:title row)})
rows))))))
(defn import-places [conn places-connection]
(go-pair
;; Ensure schema fragment is in place, even though it may cost a (mostly empty) transaction.
(<? (transact/<transact! conn places-schema-fragment))
(let [rows
(<?
(s/all-rows
places-connection
["SELECT DISTINCT p.id AS id, p.url AS url, p.title AS title, p.visit_count, p.last_visit_date, p.guid,
hv.visit_date
FROM (SELECT * FROM moz_places LIMIT 1000) AS p LEFT JOIN moz_historyvisits AS hv ON p.id = hv.place_id
WHERE p.hidden = 0
ORDER BY p.id, hv.visit_date"]))]
(<?
(transact/<transact!
conn
(map place->entity (group-by :id rows)))))))
(defn import-titles-from-path [db places]
(go-pair
(let [conn (transact/connection-with-db db)
pdb (<? (s/<sqlite-connection places))]
(import-titles conn pdb))))
(defn import-places-from-path [db places]
(go-pair
(let [conn (transact/connection-with-db db)
pdb (<? (s/<sqlite-connection places))]
(import-places conn pdb))))

67
src/datomish/query.cljc
View file

@ -40,14 +40,26 @@
(def sql-quoting-style :ansi) (def sql-quoting-style :ansi)
(defn context->sql-clause [context] (defn context->sql-clause [context]
(merge (let [inner
{:select (projection/sql-projection context) (merge
{:select (projection/sql-projection-for-relation context)
;; Always SELECT DISTINCT, because Datalog is set-based. ;; Always SELECT DISTINCT, because Datalog is set-based.
;; TODO: determine from schema analysis whether we can avoid ;; TODO: determine from schema analysis whether we can avoid
;; the need to do this. ;; the need to do this.
:modifiers [:distinct]} :modifiers [:distinct]}
(clauses/cc->partial-subquery (:cc context)))) (clauses/cc->partial-subquery (:cc context)))]
(if (:has-aggregates? context)
(merge
(when-not (empty? (:group-by-vars context))
;; We shouldn't need to account for types here, until we account for
;; `:or` clauses that bind from different attributes.
{:group-by (map util/var->sql-var (:group-by-vars context))})
{:select (projection/sql-projection-for-aggregation context :preag)
:modifiers [:distinct]
:from [:preag]
:with {:preag inner}})
inner)))
(defn context->sql-string [context args] (defn context->sql-string [context args]
(-> (->
@ -56,8 +68,9 @@
(sql/format args :quoting sql-quoting-style))) (sql/format args :quoting sql-quoting-style)))
(defn- validate-with [with] (defn- validate-with [with]
(when-not (nil? with) (when-not (or (nil? with)
(raise-str "`with` not supported."))) (every? #(instance? Variable %1) with))
(raise "Complex :with not supported." {:with with})))
(defn- validate-in [in] (defn- validate-in [in]
(when (nil? in) (when (nil? in)
@ -91,10 +104,15 @@
(let [{:keys [find in with where]} find] ; Destructure the Datalog query. (let [{:keys [find in with where]} find] ; Destructure the Datalog query.
(validate-with with) (validate-with with)
(validate-in in) (validate-in in)
(let [external-bindings (in->bindings in)] (let [external-bindings (in->bindings in)
elements (:elements find)
known-types {}
group-by-vars (projection/extract-group-by-vars elements with)]
(assoc context (assoc context
:elements (:elements find) :elements elements
:cc (clauses/patterns->cc (:default-source context) where external-bindings))))) :group-by-vars group-by-vars
:has-aggregates? (not (nil? group-by-vars))
:cc (clauses/patterns->cc (:default-source context) where known-types external-bindings)))))
(defn find->sql-clause (defn find->sql-clause
"Take a parsed `find` expression and turn it into a structured SQL "Take a parsed `find` expression and turn it into a structured SQL
@ -116,21 +134,22 @@
[q] [q]
(dp/parse-query q)) (dp/parse-query q))
(comment #_
(def sql-quoting-style nil) (def sql-quoting-style nil)
(datomish.query/find->sql-string
(datomish.query.context/->Context (datomish.query.source/datoms-source nil) nil nil)
(datomish.query/parse
'[:find ?timestampMicros ?page :in $ ?latest :where
[?page :page/starred true ?t]
[?t :db/txInstant ?timestampMicros]
(not [(> ?t ?latest)]) ])
{:latest 5})
)
#_ #_
(datomish.query/find->sql-string (datomish.query/find->sql-string
(datomish.query.context/->Context (datomish.query.source/datoms-source nil) nil nil) (datomish.query.context/make-context (datomish.query.source/datoms-source nil))
(datomish.query/parse
'[:find ?timestampMicros ?page :in $ ?latest :where
[?page :page/starred true ?t]
[?t :db/txInstant ?timestampMicros]
(not [(> ?t ?latest)]) ])
{:latest 5})
#_
(datomish.query/find->sql-string
(datomish.query.context/make-context (datomish.query.source/datoms-source nil))
(datomish.query/parse (datomish.query/parse
'[:find ?page :in $ ?latest :where '[:find ?page :in $ ?latest :where
[?page :page/url "http://example.com/"] [?page :page/url "http://example.com/"]

108
src/datomish/query/cc.cljc
View file

@ -8,6 +8,7 @@
:refer [attribute-in-source :refer [attribute-in-source
constant-in-source]] constant-in-source]]
[datomish.util :as util #?(:cljs :refer-macros :clj :refer) [raise raise-str cond-let]] [datomish.util :as util #?(:cljs :refer-macros :clj :refer) [raise raise-str cond-let]]
[honeysql.core :as sql]
[datascript.parser :as dp [datascript.parser :as dp
#?@(:cljs #?@(:cljs
[:refer [:refer
@ -52,27 +53,97 @@
;; ;;
;; `from` is a list of [source alias] pairs, suitable for passing to honeysql. ;; `from` is a list of [source alias] pairs, suitable for passing to honeysql.
;; `bindings` is a map from var to qualified columns. ;; `bindings` is a map from var to qualified columns.
;; `known-types` is a map from var to type keyword (e.g., :db.type/ref)
;; `extracted-types` is a mapping, similar to `bindings`, but used to pull
;; type tags out of the store at runtime.
;; `wheres` is a list of fragments that can be joined by `:and`. ;; `wheres` is a list of fragments that can be joined by `:and`.
(defrecord ConjoiningClauses [source from external-bindings bindings wheres]) (defrecord ConjoiningClauses
[source
from ; [[:datoms 'datoms123]]
external-bindings ; {?var0 (sql/param :foobar)}
bindings ; {?var1 :datoms123.v}
known-types ; {?var1 :db.type/integer}
extracted-types ; {?var2 :datoms123.value_type_tag}
wheres ; [[:= :datoms123.v 15]]
ctes ; {:name {:select …}}
])
(defn bind-column-to-var [cc variable col] (defn bind-column-to-var [cc variable table position]
(let [var (:symbol variable)] (let [var (:symbol variable)
(util/conj-in cc [:bindings var] col))) col (sql/qualify table (name position))
bound (util/append-in cc [:bindings var] col)]
(if (or (not (= position :v))
(contains? (:known-types cc) var)
(contains? (:extracted-types cc) var))
;; Type known; no need to accumulate a type-binding.
bound
(let [tag-col (sql/qualify table :value_type_tag)]
(assoc-in bound [:extracted-types var] tag-col)))))
(defn constrain-column-to-constant [cc col position value] (defn constrain-column-to-constant [cc table position value]
(util/conj-in cc [:wheres] (let [col (sql/qualify table (name position))]
[:= col (if (= :a position) (util/append-in cc
(attribute-in-source (:source cc) value) [:wheres]
(constant-in-source (:source cc) value))])) [:= col (if (= :a position)
(attribute-in-source (:source cc) value)
(constant-in-source (:source cc) value))])))
(defn augment-cc [cc from bindings wheres] (defprotocol ITypeTagged (->tag-codes [x]))
(extend-protocol ITypeTagged
#?@(:cljs
[string (->tag-codes [x] #{4 10 11 12})
Keyword (->tag-codes [x] #{13}) ; TODO: what about idents?
boolean (->tag-codes [x] #{1})
number (->tag-codes [x]
(if (integer? x)
#{0 4 5} ; Could be a ref or a number or a date.
#{4 5}))]) ; Can't be a ref.
#?@(:clj
[String (->tag-codes [x] #{10})
clojure.lang.Keyword (->tag-codes [x] #{13}) ; TODO: what about idents?
Boolean (->tag-codes [x] #{1})
Integer (->tag-codes [x] #{0 5}) ; Could be a ref or a number.
Long (->tag-codes [x] #{0 5}) ; Could be a ref or a number.
Float (->tag-codes [x] #{5})
Double (->tag-codes [x] #{5})
java.util.UUID (->tag-codes [x] #{11})
java.util.Date (->tag-codes [x] #{4})
java.net.URI (->tag-codes [x] #{12})]))
(defn constrain-value-column-to-constant
"Constrain a `v` column. Note that this can contribute *two*
constraints: one for the column itself, and one for the type tag.
We don't need to do this if the attribute is known and thus
constrains the type."
[cc table-alias value]
(let [possible-type-codes (->tag-codes value)
aliased (sql/qualify table-alias (name :value_type_tag))
clauses (map
(fn [code] [:= aliased code])
possible-type-codes)]
(util/concat-in cc [:wheres]
;; Type checks then value checks.
[(case (count clauses)
0 (raise-str "Unexpected number of clauses.")
1 (first clauses)
(cons :or clauses))
[:= (sql/qualify table-alias (name :v))
(constant-in-source (:source cc) value)]])))
(defn augment-cc [cc from bindings extracted-types wheres]
(assoc cc (assoc cc
:from (concat (:from cc) from) :from (concat (:from cc) from)
:bindings (merge-with concat (:bindings cc) bindings) :bindings (merge-with concat (:bindings cc) bindings)
:extracted-types (merge (:extracted-types cc) extracted-types)
:wheres (concat (:wheres cc) wheres))) :wheres (concat (:wheres cc) wheres)))
(defn merge-ccs [left right] (defn merge-ccs [left right]
(augment-cc left (:from right) (:bindings right) (:wheres right))) (augment-cc left
(:from right)
(:bindings right)
(:extracted-types right)
(:wheres right)))
(defn- bindings->where (defn- bindings->where
"Take a bindings map like "Take a bindings map like
@ -115,16 +186,19 @@
(impose-external-bindings (impose-external-bindings
(assoc cc :wheres (assoc cc :wheres
;; Note that the order of clauses here means that cross-pattern var bindings ;; Note that the order of clauses here means that cross-pattern var bindings
;; come first. That's OK: the SQL engine considers these altogether. ;; come last That's OK: the SQL engine considers these altogether.
(concat (bindings->where (:bindings cc)) (concat (:wheres cc)
(:wheres cc))))) (bindings->where (:bindings cc))))))
(defn binding-for-symbol-or-throw [cc symbol] (defn binding-for-symbol [cc symbol]
(let [internal-bindings (symbol (:bindings cc)) (let [internal-bindings (symbol (:bindings cc))
external-bindings (symbol (:external-bindings cc))] external-bindings (symbol (:external-bindings cc))]
(or (first internal-bindings) (or (first internal-bindings)
(first external-bindings) (first external-bindings))))
(raise-str "No bindings yet for " symbol))))
(defn binding-for-symbol-or-throw [cc symbol]
(or (binding-for-symbol cc symbol)
(raise-str "No bindings yet for " symbol)))
(defn argument->value (defn argument->value
"Take a value from an argument list and resolve it against the CC. "Take a value from an argument list and resolve it against the CC.

197
src/datomish/query/clauses.cljc
View file

@ -4,64 +4,96 @@
(ns datomish.query.clauses (ns datomish.query.clauses
(:require (:require
[datomish.query.cc :as cc] [datomish.query.cc :as cc]
[datomish.query.functions :as functions] [datomish.query.functions :as functions]
[datomish.query.source [datomish.query.source
:refer [attribute-in-source :refer [pattern->schema-value-type
constant-in-source attribute-in-source
source->from constant-in-source
source->constraints]] source->from
[datomish.util :as util #?(:cljs :refer-macros :clj :refer) [raise raise-str cond-let]] source->constraints]]
[datascript.parser :as dp [datomish.schema :as schema]
#?@(:cljs [datomish.util :as util #?(:cljs :refer-macros :clj :refer) [raise raise-str cond-let]]
[:refer [datascript.parser :as dp
[ #?@(:cljs
Constant [:refer
DefaultSrc [
Function Constant
Not DefaultSrc
Or Function
Pattern Not
Placeholder Or
PlainSymbol Pattern
Predicate Placeholder
Variable PlainSymbol
]])] Predicate
[honeysql.core :as sql] Variable
[clojure.string :as str] ]])]
) [honeysql.core :as sql]
[clojure.string :as str]
)
#?(:clj #?(:clj
(:import (:import
[datascript.parser [datascript.parser
Constant Constant
DefaultSrc DefaultSrc
Function Function
Not Not
Or Or
Pattern Pattern
Placeholder Placeholder
PlainSymbol PlainSymbol
Predicate Predicate
Variable Variable
]))) ])))
;; Pattern building is recursive, so we need forward declarations. ;; Pattern building is recursive, so we need forward declarations.
(declare (declare
Not->NotJoinClause not-join->where-fragment Not->NotJoinClause not-join->where-fragment
simple-or? simple-or->cc) simple-or? simple-or->cc)
(defn- check-or-apply-value-type [cc value-type pattern-part]
(if (nil? value-type)
cc
(condp instance? pattern-part
Placeholder
cc
Variable
(let [var-sym (:symbol pattern-part)]
(if-let [existing-type (var-sym (:known-types cc))]
(if (= existing-type value-type)
cc
(raise "Var " var-sym " already has type " existing-type "; this pattern wants " value-type
{:pattern pattern-part :value-type value-type}))
(assoc-in cc [:known-types var-sym] value-type)))
Constant
(do
(or (and (= :db.type/ref value-type)
(or (keyword? (:value pattern-part)) ; ident
(integer? (:value pattern-part)))) ; entid
(schema/ensure-value-matches-type value-type (:value pattern-part)))
cc))))
(defn- apply-pattern-clause-for-alias (defn- apply-pattern-clause-for-alias
"This helper assumes that `cc` has already established a table association "This helper assumes that `cc` has already established a table association
for the provided alias." for the provided alias."
[cc alias pattern] [cc alias pattern]
(let [places (map vector (let [pattern (:pattern pattern)
(:pattern pattern) columns (:columns (:source cc))
(:columns (:source cc)))] places (map vector pattern columns)
value-type (pattern->schema-value-type (:source cc) pattern)] ; Optional; e.g., :db.type/string
(reduce (reduce
(fn [cc (fn [cc
[pattern-part ; ?x, :foo/bar, 42 [pattern-part ; ?x, :foo/bar, 42
position]] ; :a position]] ; :a
(let [col (sql/qualify alias (name position))] ; :datoms123.a (let [cc (case position
;; TODO: we should be able to constrain :e and :a to be
;; entities... but the type checker expects that to be an int.
:v (check-or-apply-value-type cc value-type pattern-part)
:e (check-or-apply-value-type cc :db.type/ref pattern-part)
cc)]
(condp instance? pattern-part (condp instance? pattern-part
;; Placeholders don't contribute any bindings, nor do ;; Placeholders don't contribute any bindings, nor do
;; they constrain the query -- there's no need to produce ;; they constrain the query -- there's no need to produce
@ -70,10 +102,16 @@
cc cc
Variable Variable
(cc/bind-column-to-var cc pattern-part col) (cc/bind-column-to-var cc pattern-part alias position)
Constant Constant
(cc/constrain-column-to-constant cc col position (:value pattern-part)) (if (and (nil? value-type)
(= position :v))
;; If we don't know the type, but we have a constant, generate
;; a :wheres clause constraining the accompanying value_type_tag
;; column.
(cc/constrain-value-column-to-constant cc alias (:value pattern-part))
(cc/constrain-column-to-constant cc alias position (:value pattern-part)))
(raise "Unknown pattern part." {:part pattern-part :clause pattern})))) (raise "Unknown pattern part." {:part pattern-part :clause pattern}))))
@ -105,7 +143,7 @@
(apply-pattern-clause-for-alias (apply-pattern-clause-for-alias
;; Record the new table mapping. ;; Record the new table mapping.
(util/conj-in cc [:from] [table alias]) (util/append-in cc [:from] [table alias])
;; Use the new alias for columns. ;; Use the new alias for columns.
alias alias
@ -114,7 +152,7 @@
(defn- plain-symbol->sql-predicate-symbol [fn] (defn- plain-symbol->sql-predicate-symbol [fn]
(when-not (instance? PlainSymbol fn) (when-not (instance? PlainSymbol fn)
(raise-str "Predicate functions must be named by plain symbols." fn)) (raise-str "Predicate functions must be named by plain symbols." fn))
(#{:> :< :=} (keyword (name (:symbol fn))))) (#{:> :>= :< :<= := :!=} (keyword (name (:symbol fn)))))
(defn apply-predicate-clause [cc predicate] (defn apply-predicate-clause [cc predicate]
(when-not (instance? Predicate predicate) (when-not (instance? Predicate predicate)
@ -124,7 +162,7 @@
(raise-str "Unknown function " (:fn predicate))) (raise-str "Unknown function " (:fn predicate)))
(let [args (map (partial cc/argument->value cc) (:args predicate))] (let [args (map (partial cc/argument->value cc) (:args predicate))]
(util/conj-in cc [:wheres] (cons f args))))) (util/append-in cc [:wheres] (cons f args)))))
(defn apply-not-clause [cc not] (defn apply-not-clause [cc not]
(when-not (instance? Not not) (when-not (instance? Not not)
@ -136,13 +174,19 @@
;; fragment, and include the external bindings so that they match up. ;; fragment, and include the external bindings so that they match up.
;; Otherwise, we need to delay. Right now we're lazy, so we just fail: ;; Otherwise, we need to delay. Right now we're lazy, so we just fail:
;; reorder your query yourself. ;; reorder your query yourself.
(util/conj-in cc [:wheres] ;;
(not-join->where-fragment ;; Note that we don't extract and reuse any types established inside
(Not->NotJoinClause (:source cc) ;; the `not` clause: perhaps those won't make sense outside. But it's
(merge-with concat ;; a filter, so we push the external types _in_.
(:external-bindings cc) (util/append-in cc
(:bindings cc)) [:wheres]
not)))) (not-join->where-fragment
(Not->NotJoinClause (:source cc)
(:known-types cc)
(merge-with concat
(:external-bindings cc)
(:bindings cc))
not))))
(defn apply-or-clause [cc orc] (defn apply-or-clause [cc orc]
(when-not (instance? Or orc) (when-not (instance? Or orc)
@ -163,6 +207,7 @@
(if (simple-or? orc) (if (simple-or? orc)
(cc/merge-ccs cc (simple-or->cc (:source cc) (cc/merge-ccs cc (simple-or->cc (:source cc)
(:known-types cc)
(merge-with concat (merge-with concat
(:external-bindings cc) (:external-bindings cc)
(:bindings cc)) (:bindings cc))
@ -200,14 +245,17 @@
[cc patterns] [cc patterns]
(reduce apply-clause cc patterns)) (reduce apply-clause cc patterns))
(defn patterns->cc [source patterns external-bindings] (defn patterns->cc [source patterns known-types external-bindings]
(cc/expand-where-from-bindings (cc/expand-where-from-bindings
(expand-pattern-clauses (expand-pattern-clauses
(cc/map->ConjoiningClauses (cc/map->ConjoiningClauses
{:source source {:source source
:from [] :from []
:known-types (or known-types {})
:extracted-types {}
:external-bindings (or external-bindings {}) :external-bindings (or external-bindings {})
:bindings {} :bindings {}
:ctes {}
:wheres []}) :wheres []})
patterns))) patterns)))
@ -218,6 +266,8 @@
[cc] [cc]
(merge (merge
{:from (:from cc)} {:from (:from cc)}
(when-not (empty? (:ctes cc))
{:with (:ctes cc)})
(when-not (empty? (:wheres cc)) (when-not (empty? (:wheres cc))
{:where (cons :and (:wheres cc))}))) {:where (cons :and (:wheres cc))})))
@ -230,24 +280,23 @@
;; that a declared variable list is valid for the clauses given. ;; that a declared variable list is valid for the clauses given.
(defrecord NotJoinClause [unify-vars cc]) (defrecord NotJoinClause [unify-vars cc])
(defn make-not-join-clause [source external-bindings unify-vars patterns] (defn Not->NotJoinClause [source known-types external-bindings not]
(->NotJoinClause unify-vars (patterns->cc source patterns external-bindings)))
(defn Not->NotJoinClause [source external-bindings not]
(when-not (instance? DefaultSrc (:source not)) (when-not (instance? DefaultSrc (:source not))
(raise "Non-default sources are not supported in `not` clauses." {:clause not})) (raise "Non-default sources are not supported in `not` clauses." {:clause not}))
(make-not-join-clause source external-bindings (:vars not) (:clauses not))) (map->NotJoinClause
{:unify-vars (:vars not)
:cc (patterns->cc source (:clauses not) known-types external-bindings)}))
(defn not-join->where-fragment [not-join] (defn not-join->where-fragment [not-join]
[:not [:not
(if (empty? (:bindings (:cc not-join))) (if (empty? (:bindings (:cc not-join)))
;; If the `not` doesn't establish any bindings, it means it only contains ;; If the `not` doesn't establish any bindings, it means it only contains
;; expressions that constrain variables established outside itself. ;; expressions that constrain variables established outside itself.
;; We can just return an expression. ;; We can just return an expression.
(cons :and (:wheres (:cc not-join))) (cons :and (:wheres (:cc not-join)))
;; If it does establish bindings, then it has to be a subquery. ;; If it does establish bindings, then it has to be a subquery.
[:exists (merge {:select [1]} (cc->partial-subquery (:cc not-join)))])]) [:exists (merge {:select [1]} (cc->partial-subquery (:cc not-join)))])])
;; A simple Or clause is one in which each branch can be evaluated against ;; A simple Or clause is one in which each branch can be evaluated against
@ -288,15 +337,17 @@
(defn simple-or->cc (defn simple-or->cc
"The returned CC has not yet had bindings expanded." "The returned CC has not yet had bindings expanded."
[source external-bindings orc] [source known-types external-bindings orc]
(validate-or-clause orc) (validate-or-clause orc)
;; We 'fork' a CC for each pattern, then union them together. ;; We 'fork' a CC for each pattern, then union them together.
;; We need to build the first in order that the others use the same ;; We need to build the first in order that the others use the same
;; column names. ;; column names and known types.
(let [cc (cc/map->ConjoiningClauses (let [cc (cc/map->ConjoiningClauses
{:source source {:source source
:from [] :from []
:known-types (or known-types {})
:extracted-types {}
:external-bindings (or external-bindings {}) :external-bindings (or external-bindings {})
:bindings {} :bindings {}
:wheres []}) :wheres []})
@ -307,6 +358,9 @@
;; That was easy. ;; That was easy.
primary primary
;; Note that for a simple `or` clause, the same template is used for each,
;; so we can simply use the `extracted-types` bindings from `primary`.
;; A complex `or` is much harder to handle.
(let [template (assoc primary :wheres []) (let [template (assoc primary :wheres [])
alias (second (first (:from template))) alias (second (first (:from template)))
ccs (map (partial apply-pattern-clause-for-alias template alias) ccs (map (partial apply-pattern-clause-for-alias template alias)
@ -315,7 +369,8 @@
;; Because this is a simple clause, we know that the first pattern established ;; Because this is a simple clause, we know that the first pattern established
;; any necessary bindings. ;; any necessary bindings.
;; Take any new :wheres from each CC and combine them with :or. ;; Take any new :wheres from each CC and combine them with :or.
(assoc primary :wheres (assoc primary
:wheres
[(cons :or [(cons :or
(reduce (fn [acc cc] (reduce (fn [acc cc]
(let [w (:wheres cc)] (let [w (:wheres cc)]

16
src/datomish/query/context.cljc
View file

@ -2,8 +2,18 @@
;; License, v. 2.0. If a copy of the MPL was not distributed with this ;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/. ;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;; A context, very simply, holds on to a default source. Eventually ;; A context, very simply, holds on to a default source and some knowledge
;; it'll also do projection and similar transforms. ;; needed for aggregation.
(ns datomish.query.context) (ns datomish.query.context)
(defrecord Context [default-source elements cc]) (defrecord Context
[
default-source
elements ; The :find list itself.
has-aggregates?
group-by-vars ; A list of variables from :find and :with, used to generate GROUP BY.
cc ; The main conjoining clause.
])
(defn make-context [source]
(->Context source nil false nil nil))

136
src/datomish/query/functions.cljc
View file

@ -6,7 +6,12 @@
(:require (:require
[honeysql.format :as fmt] [honeysql.format :as fmt]
[datomish.query.cc :as cc] [datomish.query.cc :as cc]
[datomish.query.source :as source] [datomish.schema :as schema]
[datomish.sqlite-schema :refer [->tag ->SQLite]]
[datomish.query.source
:as source
:refer [attribute-in-source
constant-in-source]]
[datomish.util :as util #?(:cljs :refer-macros :clj :refer) [raise raise-str cond-let]] [datomish.util :as util #?(:cljs :refer-macros :clj :refer) [raise raise-str cond-let]]
[datascript.parser :as dp [datascript.parser :as dp
#?@(:cljs #?@(:cljs
@ -66,10 +71,8 @@
(when-not (and (instance? SrcVar src) (when-not (and (instance? SrcVar src)
(= "$" (name (:symbol src)))) (= "$" (name (:symbol src))))
(raise "Non-default sources not supported." {:arg src})) (raise "Non-default sources not supported." {:arg src}))
(when-not (instance? Constant attr) (when (and (instance? Constant attr)
(raise "Non-constant fulltext attributes not supported." {:arg attr})) (not (fulltext-attribute? (:source cc) (:value attr))))
(when-not (fulltext-attribute? (:source cc) (:value attr))
(raise-str "Attribute " (:value attr) " is not a fulltext-indexed attribute.")) (raise-str "Attribute " (:value attr) " is not a fulltext-indexed attribute."))
(when-not (and (instance? BindColl bind-coll) (when-not (and (instance? BindColl bind-coll)
@ -89,6 +92,18 @@
;; We do not currently support scoring; the score value will always be 0. ;; We do not currently support scoring; the score value will always be 0.
(let [[src attr search] (:args function) (let [[src attr search] (:args function)
;; Note that DataScript's parser won't allow us to write a term like
;;
;; [(fulltext $ _ "foo") [[?x]]]
;;
;; so we instead have a placeholder attribute. Sigh.
attr-constant (or
(and (instance? Constant attr)
(not (= :any (:value attr)))
(source/attribute-in-source (:source cc) (:value attr)))
(and (instance? Variable attr)
(cc/binding-for-symbol-or-throw cc (:symbol attr))))
;; Pull out the symbols for the binding array. ;; Pull out the symbols for the binding array.
[entity value tx score] [entity value tx score]
(map (comp :symbol :variable) ; This will nil-out placeholders. (map (comp :symbol :variable) ; This will nil-out placeholders.
@ -97,8 +112,8 @@
;; Find the FTS table name and alias. We might have multiple fulltext ;; Find the FTS table name and alias. We might have multiple fulltext
;; expressions so we will generate a query like ;; expressions so we will generate a query like
;; SELECT ttt.a FROM t1 AS ttt WHERE ttt.t1 MATCH 'string' ;; SELECT ttt.a FROM t1 AS ttt WHERE ttt.t1 MATCH 'string'
[fulltext-table fulltext-alias] (source/source->fulltext-from (:source cc)) ; [:t1 :ttt] [fulltext-table fulltext-alias] (source/source->fulltext-values (:source cc)) ; [:t1 :ttt]
match-column (sql/qualify fulltext-alias fulltext-table) ; :ttt.t1 match-column (sql/qualify fulltext-alias fulltext-table) ; :ttt.t1
match-value (cc/argument->value cc search) match-value (cc/argument->value cc search)
[datom-table datom-alias] (source/source->non-fulltext-from (:source cc)) [datom-table datom-alias] (source/source->non-fulltext-from (:source cc))
@ -107,22 +122,27 @@
from [[fulltext-table fulltext-alias] from [[fulltext-table fulltext-alias]
[datom-table datom-alias]] [datom-table datom-alias]]
wheres [[:match match-column match-value] ; The FTS match. extracted-types {} ; TODO
wheres (concat
[[:match match-column match-value] ; The FTS match.
;; The fulltext rowid-to-datom correspondence. ;; The fulltext rowid-to-datom correspondence.
[:= [:=
(sql/qualify datom-alias :v) (sql/qualify datom-alias :v)
(sql/qualify fulltext-alias :rowid)] (sql/qualify fulltext-alias :rowid)]]
;; The attribute itself must match. (when attr-constant
[:= ;; If known, the attribute itself must match.
(sql/qualify datom-alias :a) [[:=
(source/attribute-in-source (:source cc) (:value attr))]] (sql/qualify datom-alias :a)
attr-constant]]))
;; Now compose any bindings for entity, value, tx, and score. ;; Now compose any bindings for entity, value, tx, and score.
;; TODO: do we need to examine existing bindings to capture ;; TODO: do we need to examine existing bindings to capture
;; wheres for any of these? We shouldn't, because the CC will ;; wheres for any of these? We shouldn't, because the CC will
;; be internally cross-where'd when everything is done... ;; be internally cross-where'd when everything is done...
;; TODO: bind attribute?
bindings (into {} bindings (into {}
(filter (filter
(comp not nil? first) (comp not nil? first)
@ -134,11 +154,97 @@
;; if this is a variable rather than a placeholder. ;; if this is a variable rather than a placeholder.
[score [0]]]))] [score [0]]]))]
(cc/augment-cc cc from bindings wheres))) (cc/augment-cc cc from bindings extracted-types wheres)))
;; get-else is how Datalog handles optional attributes.
;;
;; It consists of:
;; * A bound entity
;; * A cardinality-one attribute
;; * A var to bind the value
;; * A default value.
;;
;; We model this as:
;; * A check against known bindings for the entity.
;; * A check against the schema for cardinality-one.
;; * Generating a COALESCE expression with a query inside the projection itself.
;;
;; Note that this will be messy for queries like:
;;
;; [:find ?page ?title :in $
;; :where [?page :page/url _]
;; [(get-else ?page :page/title "<empty>") ?title]
;; [_ :foo/quoted ?title]]
;;
;; or
;; [(some-function ?title)]
;;
;; -- we aren't really establishing a binding, so the subquery will be
;; repeated. But this will do for now.
(defn apply-get-else-clause [cc function]
(let [{:keys [source bindings external-bindings]} cc
schema (:schema source)
{:keys [args binding]} function
[src e a default-val] args]
(when-not (instance? BindScalar binding)
(raise-str "Expected scalar binding."))
(when-not (instance? Variable (:variable binding))
(raise-str "Expected variable binding."))
(when-not (instance? Constant a)
(raise-str "Expected constant attribute."))
(when-not (instance? Constant default-val)
(raise-str "Expected constant default value."))
(when-not (and (instance? SrcVar src)
(= "$" (name (:symbol src))))
(raise "Non-default sources not supported." {:arg src}))
(let [a (attribute-in-source source (:value a))
a-type (get-in (:schema schema) [a :db/valueType])
a-tag (->tag a-type)
default-val (:value default-val)
var (:variable binding)]
;; Schema check.
(when-not (and (integer? a)
(not (datomish.schema/multival? schema a)))
(raise-str "Attribute " a " is not cardinality-one."))
;; TODO: type-check the default value.
(condp instance? e
Variable
(let [e (:symbol e)
e-binding (cc/binding-for-symbol-or-throw cc e)]
(let [[table _] (source/source->from source a) ; We don't need to alias: single pattern.
;; These :limit values shouldn't be needed, but sqlite will
;; appreciate them.
;; Note that we don't extract type tags here: the attribute
;; must be known!
subquery {:select
[(sql/call
:coalesce
{:select [:v]
:from [table]
:where [:and
[:= 'a a]
[:= 'e e-binding]]
:limit 1}
(->SQLite default-val))]
:limit 1}]
(->
(assoc-in cc [:known-types (:symbol var)] a-type)
(util/append-in [:bindings (:symbol var)] subquery))))
(raise-str "Can't handle entity" e)))))
(def sql-functions (def sql-functions
;; Future: versions of this that uses snippet() or matchinfo(). ;; Future: versions of this that uses snippet() or matchinfo().
{"fulltext" apply-fulltext-clause}) {"fulltext" apply-fulltext-clause
"get-else" apply-get-else-clause})
(defn apply-sql-function (defn apply-sql-function
"Either returns an application of `function` to `cc`, or nil to "Either returns an application of `function` to `cc`, or nil to

256
src/datomish/query/projection.cljc
View file

@ -4,18 +4,114 @@
(ns datomish.query.projection (ns datomish.query.projection
(:require (:require
[datomish.util :as util #?(:cljs :refer-macros :clj :refer) [raise-str cond-let]] [honeysql.core :as sql]
[datomish.query.source :as source]
[datomish.sqlite-schema :as ss]
[datomish.util :as util #?(:cljs :refer-macros :clj :refer) [raise raise-str cond-let]]
[datascript.parser :as dp [datascript.parser :as dp
#?@(:cljs [:refer [Pattern DefaultSrc Variable Constant Placeholder]])] #?@(:cljs [:refer [Aggregate Pattern DefaultSrc Variable Constant Placeholder PlainSymbol]])]
) )
#?(:clj (:import [datascript.parser Pattern DefaultSrc Variable Constant Placeholder])) #?(:clj (:import [datascript.parser Aggregate Pattern DefaultSrc Variable Constant Placeholder PlainSymbol]))
) )
(defn lookup-variable [cc variable] (defn lookup-variable [cc variable]
(or (-> cc :bindings variable first) (or (-> cc :bindings variable first)
(raise-str "Couldn't find variable " variable))) (raise-str "Couldn't find variable " variable)))
(defn sql-projection (def aggregate-functions
{:avg :avg
:count :count
:max :max
:min :min
:sum :total
})
(defn- aggregate-symbols->projected-var [fn-symbol var-symbol]
(keyword (str "_" (name fn-symbol) "_" (subs (name var-symbol) 1))))
(defn- aggregate->projected-var [elem]
(aggregate-symbols->projected-var (:symbol (:fn elem))
(:symbol (first (:args elem)))))
(defn simple-aggregate?
"If `elem` is a simple aggregate -- symbolic function, one var arg --
return the variable symbol."
[elem]
(when (instance? Aggregate elem)
(let [{:keys [fn args]} elem]
(when (and (instance? PlainSymbol fn)
(= 1 (count args)))
(let [arg (first args)]
(when (instance? Variable arg)
(:symbol arg)))))))
(defn- aggregate->var [elem]
(when (instance? Aggregate elem)
(when-not (simple-aggregate? elem)
(raise-str "Only know how to handle simple aggregates."))
(:symbol (first (:args elem)))))
(defn- variable->var [elem]
(when (instance? Variable elem)
(:symbol elem)))
(defn- aggregate->projection [elem context lookup-fn]
(when (instance? Aggregate elem)
(when-not (simple-aggregate? elem)
(raise-str "Only know how to handle simple aggregates."))
(let [var-symbol (:symbol (first (:args elem)))
fn-symbol (:symbol (:fn elem))
lookup-var (lookup-fn var-symbol)
aggregate-fn (get aggregate-functions (keyword fn-symbol))]
(when-not aggregate-fn
(raise-str "Unknown aggregate function " fn-symbol))
(let [funcall-var (util/aggregate->sql-var aggregate-fn lookup-var)
project-as (aggregate-symbols->projected-var fn-symbol var-symbol)]
[[funcall-var project-as]]))))
(defn- type-projection
"Produce a projection pair by looking up `var` in the provided
`extracted-types`."
[extracted-types var]
(when-let [t (get extracted-types var)]
[t (util/var->sql-type-var var)]))
(defn- aggregate-type-projection
"Produce a passthrough projection pair for a type field
in an inner query."
[inner var]
(let [type-var (util/var->sql-type-var var)]
[(sql/qualify inner type-var) type-var]))
(defn- symbol->projection
"Given a variable symbol, produce a projection pair.
`lookup-fn` will be used to find a column. For a non-aggregate query,
this will typically be a lookup into the CC's bindings. For an
aggregate query it'll be a qualification of the same var into the
subquery.
`known-types` is a type map to decide whether to project a type tag.
`type-projection-fn` is like `lookup-fn` but for type tag columns."
[var lookup-fn known-types type-projection-fn]
(let [lookup-var (lookup-fn var)
projected-var (util/var->sql-var var)
var-projection [lookup-var projected-var]]
;; If the type of a variable isn't explicitly known, we also select
;; its type column so we can transform it.
(if-let [type-proj (when (not (contains? known-types var))
(type-projection-fn var))]
[var-projection type-proj]
[var-projection])))
(defn- variable->projection [elem lookup-fn known-types type-projection-fn]
(when (instance? Variable elem)
(symbol->projection (:symbol elem) lookup-fn known-types type-projection-fn)))
(defn sql-projection-for-relation
"Take a `find` clause's `:elements` list and turn it into a SQL "Take a `find` clause's `:elements` list and turn it into a SQL
projection clause, suitable for passing as a `:select` clause to projection clause, suitable for passing as a `:select` clause to
honeysql. honeysql.
@ -32,23 +128,145 @@
[[:datoms12.e :foo] [:datoms13.e :bar]] [[:datoms12.e :foo] [:datoms13.e :bar]]
Note that we also look at `:group-by-vars`, because we need to
alias columns and apply `DISTINCT` to those columns in order to
aggregate correctly.
This function unpacks aggregate operations, instead selecting the var.
@param context A Context, containing elements. @param context A Context, containing elements.
@return a sequence of pairs." @return a sequence of pairs."
[context] [context]
(def foo context) (let [{:keys [group-by-vars elements cc]} context
(let [elements (:elements context)] {:keys [known-types extracted-types]} cc]
(when-not (every? #(instance? Variable %1) elements)
(raise-str "Unable to :find non-variables.")) ;; The primary projections from the :find list.
(map (fn [elem] ;; Note that deduplication will be necessary, because we unpack aggregates.
(let [var (:symbol elem)] (let [projected-vars
[(lookup-variable (:cc context) var) (util/var->sql-var var)])) (map (fn [elem]
elements))) (or (aggregate->var elem)
(variable->var elem)
(raise "Only able to :find variables or aggregates."
{:elem elem})))
elements)
;; If we have any GROUP BY requirements from :with, that aren't already
;; included in the above, project them now.
additional-vars
(clojure.set/difference
(set group-by-vars)
(set projected-vars))
full-var-list
(distinct (concat projected-vars additional-vars))
type-proj-fn
(partial type-projection extracted-types)
lookup-fn
(partial lookup-variable cc)]
(mapcat (fn [var]
(symbol->projection var lookup-fn known-types type-proj-fn))
full-var-list))))
(defn sql-projection-for-aggregation
"Project an element list that contains aggregates. This expects a subquery
aliased to `inner-table` which itself will project each var with the
correct name."
[context inner-table]
(let [{:keys [group-by-vars elements cc]} context
{:keys [known-types extracted-types]} cc
lookup-fn (fn [var]
(sql/qualify inner-table (util/var->sql-var var)))
type-proj-fn (partial aggregate-type-projection inner-table)]
(mapcat (fn [elem]
(or (variable->projection elem lookup-fn known-types type-proj-fn)
(aggregate->projection elem context lookup-fn)
(raise "Only able to :find variables or aggregates."
{:elem elem})))
elements)))
(defn make-projectors-for-columns [elements known-types extracted-types]
{:pre [(map? extracted-types)
(map? known-types)]}
(letfn [(variable->projector [elem known-types extracted-types tag-decoder]
(when (instance? Variable elem)
(let [var (:symbol elem)
projected-var (util/var->sql-var var)]
(if-let [type (get known-types var)]
;; We know the type! We already know how to decode it.
;; TODO: most of these tags don't actually require calling through to <-tagged-SQLite.
;; TODO: optimize this without making it horrible.
(let [decoder (tag-decoder (ss/->tag type))]
(fn [row]
(decoder (get row projected-var))))
;; We don't know the type. Find the type projection column
;; and use it to decode the value.
(if (contains? extracted-types var)
(let [type-column (util/var->sql-type-var var)]
(fn [row]
(ss/<-tagged-SQLite
(get row type-column)
(get row projected-var))))
;; We didn't extract a type and we don't know it in advance.
;; Just pass through; the :col will look itself up in the row.
projected-var)))))
;; For now we assume numerics and that everything will shake out in the wash.
(aggregate->projector [elem]
(when (instance? Aggregate elem)
(let [var (aggregate->projected-var elem)]
(fn [row]
(get row var)))))]
(let [tag-decoder (memoize
(fn [tag]
(partial ss/<-tagged-SQLite tag)))]
(map (fn [elem]
(or (variable->projector elem known-types extracted-types tag-decoder)
(aggregate->projector elem)))
elements))))
(defn row-pair-transducer [context] (defn row-pair-transducer [context]
;; For now, we only support straight var lists, so (let [{:keys [elements cc]} context
;; our transducer is trivial. {:keys [source known-types extracted-types]} cc
(let [columns-in-order (map second (sql-projection context))]
(map (fn [[row err]] ;; We know the projection will fail above if these aren't simple variables or aggregates.
(if err projectors
[row err] (make-projectors-for-columns elements known-types extracted-types)]
[(map row columns-in-order) nil])))))
(map
(fn [[row err]]
(if err
[row err]
[(map (fn [projector] (projector row)) projectors) nil])))))
(defn extract-group-by-vars
"Take inputs to :find and, if any aggregates exist in `elements`,
return the variable names upon which we should GROUP BY."
[elements with]
(when (some #(instance? Aggregate %1) elements)
(loop [ignore #{}
group-by (map :symbol with)
e elements]
(if-let [element (first e)]
(if-let [aggregated-var (simple-aggregate? element)]
(recur (conj ignore aggregated-var)
group-by
(rest e))
(if (instance? Variable element)
(let [var (:symbol element)]
(recur ignore
(if (contains? ignore var)
group-by
(conj group-by var))
(rest e)))
(raise-str "Unknown element." {:element element})))
;; Done. Remove any later vars we saw.
(remove ignore group-by)))))

110
src/datomish/query/source.cljc
View file

@ -4,14 +4,16 @@
(ns datomish.query.source (ns datomish.query.source
(:require (:require
[datomish.query.transforms :as transforms] [datomish.query.transforms :as transforms]
[datascript.parser [datomish.schema :as schema]
#?@(:cljs [datomish.util :as util #?(:cljs :refer-macros :clj :refer) [raise raise-str]]
[:refer [Variable Constant Placeholder]])]) [datascript.parser
#?@(:cljs
[:refer [Variable Constant Placeholder]])])
#?(:clj #?(:clj
(:import [datascript.parser Variable Constant Placeholder]))) (:import [datascript.parser Variable Constant Placeholder])))
(defn- gensym-table-alias [table] (defn gensym-table-alias [table]
(gensym (name table))) (gensym (name table)))
;;; ;;;
@ -38,42 +40,63 @@
(source->non-fulltext-from [source]) (source->non-fulltext-from [source])
(source->fulltext-from [source] (source->fulltext-from [source]
"Returns a pair, `[table alias]` for querying the source's fulltext index.") "Returns a pair, `[table alias]` for querying the source's fulltext index.")
(source->fulltext-values [source]
"Returns a pair, `[table alias]` for querying the source's fulltext values")
(source->constraints [source alias]) (source->constraints [source alias])
(pattern->schema-value-type [source pattern])
(attribute-in-source [source attribute]) (attribute-in-source [source attribute])
(constant-in-source [source constant])) (constant-in-source [source constant]))
(defrecord (defrecord
DatomsSource DatomsSource
[table ; Typically :datoms. [table ; Typically :datoms.
fulltext-table ; Typically :fulltext_values fulltext-table ; Typically :fulltext_datoms
fulltext-view ; Typically :all_datoms fulltext-view ; Typically :all_datoms
columns ; e.g., [:e :a :v :tx] fulltext-values ; Typically :fulltext_values
columns ; e.g., [:e :a :v :tx]
schema ; An ISchema instance.
;; `attribute-transform` is a function from attribute to constant value. Used to ;; `attribute-transform` is a function from attribute to constant value. Used to
;; turn, e.g., :p/attribute into an interned integer. ;; turn, e.g., :p/attribute into an interned integer.
;; `constant-transform` is a function from constant value to constant value. Used to ;; `constant-transform` is a function from constant value to constant value. Used to
;; turn, e.g., the literal 'true' into 1. ;; turn, e.g., the literal 'true' into 1.
attribute-transform attribute-transform
constant-transform constant-transform
;; `table-alias` is a function from table to alias, e.g., :datoms => :datoms1234. ;; `table-alias` is a function from table to alias, e.g., :datoms => :datoms1234.
table-alias table-alias
;; Not currently used. ;; Not currently used.
make-constraints ; ?fn [source alias] => [where-clauses] make-constraints ; ?fn [source alias] => [where-clauses]
] ]
Source Source
(source->from [source attribute] (source->from [source attribute]
(let [table (let [schema (:schema source)
(if (and (instance? Constant attribute) int->table (fn [a]
;; TODO: look in the DB schema to see if `attribute` is known to not be (if (schema/fulltext? schema a)
;; a fulltext attribute. (:fulltext-table source)
true) (:table source)))
(:table source) table
(cond
(integer? attribute)
(int->table attribute)
(instance? Constant attribute)
(let [a (:value attribute)
id (if (keyword? a)
(attribute-in-source source a)
a)]
(int->table id))
;; TODO: perhaps we know an external binding already?
(or (instance? Variable attribute)
(instance? Placeholder attribute))
;; It's variable. We must act as if it could be a fulltext datom. ;; It's variable. We must act as if it could be a fulltext datom.
(:fulltext-view source))] (:fulltext-view source)
true
(raise "Unknown source->from attribute " attribute {:attribute attribute}))]
[table ((:table-alias source) table)])) [table ((:table-alias source) table)]))
(source->non-fulltext-from [source] (source->non-fulltext-from [source]
@ -84,24 +107,29 @@
(let [table (:fulltext-table source)] (let [table (:fulltext-table source)]
[table ((:table-alias source) table)])) [table ((:table-alias source) table)]))
(source->fulltext-values [source]
(let [table (:fulltext-values source)]
[table ((:table-alias source) table)]))
(source->constraints [source alias] (source->constraints [source alias]
(when-let [f (:make-constraints source)] (when-let [f (:make-constraints source)]
(f alias))) (f alias)))
(pattern->schema-value-type [source pattern]
(let [[_ a v _] pattern
schema (:schema (:schema source))]
(when (instance? Constant a)
(let [val (:value a)]
(if (keyword? val)
;; We need to find the entid for the keyword attribute,
;; because the schema stores attributes by ID.
(let [id (attribute-in-source source val)]
(get-in schema [id :db/valueType]))
(when (integer? val)
(get-in schema [val :db/valueType])))))))
(attribute-in-source [source attribute] (attribute-in-source [source attribute]
((:attribute-transform source) attribute)) ((:attribute-transform source) attribute))
(constant-in-source [source constant] (constant-in-source [source constant]
((:constant-transform source) constant))) ((:constant-transform source) constant)))
(defn datoms-source [db]
(map->DatomsSource
{:table :datoms
:fulltext-table :fulltext_values
:fulltext-view :all_datoms
:columns [:e :a :v :tx :added]
:attribute-transform transforms/attribute-transform-string
:constant-transform transforms/constant-transform-default
:table-alias gensym-table-alias
:make-constraints nil}))

54
src/datomish/schema.cljc
View file

@ -5,7 +5,12 @@
;; Purloined from DataScript. ;; Purloined from DataScript.
(ns datomish.schema (ns datomish.schema
(:require [datomish.util :as util #?(:cljs :refer-macros :clj :refer) [raise]])) (:require
[datomish.sqlite-schema :as sqlite-schema]
[datomish.util :as util #?(:cljs :refer-macros :clj :refer) [raise]]))
(defn entid? [x]
(and (integer? x) (pos? x)))
(defprotocol ISchema (defprotocol ISchema
(attrs-by (attrs-by
@ -94,19 +99,41 @@
:key k :key k
:value v})))) :value v}))))
;; TODO: consider doing this with a protocol and extending the underlying Clojure(Script) types. #?(:clj
(defn uuidish? [x]
(instance? java.util.UUID x)))
#?(:cljs
(let [uuid-re (js/RegExp. "[0-9a-f]{8}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{12}" "i")]
(defn uuidish? [x]
(and (string? x)
(re-find uuid-re x)))))
(def value-type-map (def value-type-map
{:db.type/ref { :valid? #(and (integer? %) (pos? %)) :->SQLite identity :<-SQLite identity } {:db.type/ref { :valid? entid? }
:db.type/keyword { :valid? keyword? :->SQLite str :<-SQLite #(keyword (subs % 1)) } :db.type/keyword { :valid? keyword? }
:db.type/string { :valid? string? :->SQLite identity :<-SQLite identity } :db.type/string { :valid? string? }
:db.type/boolean { :valid? #?(:clj #(instance? Boolean %) :cljs #(= js/Boolean (type %))) :->SQLite #(if % 1 0) :<-SQLite #(not= % 0) } :db.type/boolean { :valid? #?(:clj #(instance? Boolean %) :cljs #(= js/Boolean (type %))) }
:db.type/integer { :valid? integer? :->SQLite identity :<-SQLite identity } :db.type/long { :valid? integer? }
:db.type/real { :valid? #?(:clj float? :cljs number?) :->SQLite identity :<-SQLite identity } :db.type/uuid { :valid? uuidish? }
:db.type/instant { :valid? #?(:clj #(instance? java.util.Date %) :cljs #(= js/Date (type %))) }
:db.type/uri { :valid? #?(:clj #(instance? java.net.URI %) :cljs string?) }
:db.type/double { :valid? #?(:clj float? :cljs number?) }
}) })
(defn #?@(:clj [^Boolean ensure-value-matches-type]
:cljs [^boolean ensure-value-matches-type]) [type value]
(if-let [valid? (get-in value-type-map [type :valid?])]
(when-not (valid? value)
(raise "Invalid value for type " type "; got " value
{:error :schema/valueType, :type type, :value value}))
(raise "Unknown valueType " type ", expected one of " (sorted-set (keys value-type-map))
{:error :schema/valueType, :type type})))
;; There's some duplication here so we get better error messages.
(defn #?@(:clj [^Boolean ensure-valid-value] (defn #?@(:clj [^Boolean ensure-valid-value]
:cljs [^boolean ensure-valid-value]) [schema attr value] :cljs [^boolean ensure-valid-value]) [schema attr value]
{:pre [(schema? schema)]} {:pre [(schema? schema)
(integer? attr)]}
(let [schema (.-schema schema)] (let [schema (.-schema schema)]
(if-let [valueType (get-in schema [attr :db/valueType])] (if-let [valueType (get-in schema [attr :db/valueType])]
(if-let [valid? (get-in value-type-map [valueType :valid?])] (if-let [valid? (get-in value-type-map [valueType :valid?])]
@ -119,12 +146,13 @@
{:error :schema/valueType, :attribute attr})))) {:error :schema/valueType, :attribute attr}))))
(defn ->SQLite [schema attr value] (defn ->SQLite [schema attr value]
{:pre [(schema? schema)]} {:pre [(schema? schema)
(integer? attr)]}
(let [schema (.-schema schema)] (let [schema (.-schema schema)]
(if-let [valueType (get-in schema [attr :db/valueType])] (if-let [valueType (get-in schema [attr :db/valueType])]
(if-let [valid? (get-in value-type-map [valueType :valid?])] (if-let [valid? (get-in value-type-map [valueType :valid?])]
(if (valid? value) (if (valid? value)
((get-in value-type-map [valueType :->SQLite]) value) [(sqlite-schema/->SQLite value) (sqlite-schema/->tag valueType)]
(raise "Invalid value for attribute " attr ", expected " valueType " but got " value (raise "Invalid value for attribute " attr ", expected " valueType " but got " value
{:error :schema/valueType, :attribute attr, :value value})) {:error :schema/valueType, :attribute attr, :value value}))
(raise "Unknown valueType for attribute " attr ", expected one of " (sorted-set (keys value-type-map)) (raise "Unknown valueType for attribute " attr ", expected one of " (sorted-set (keys value-type-map))
@ -136,8 +164,8 @@
{:pre [(schema? schema)]} {:pre [(schema? schema)]}
(let [schema (.-schema schema)] (let [schema (.-schema schema)]
(if-let [valueType (get-in schema [attr :db/valueType])] (if-let [valueType (get-in schema [attr :db/valueType])]
(if-let [<-SQLite (get-in value-type-map [valueType :<-SQLite])] (if (contains? value-type-map valueType)
(<-SQLite value) (sqlite-schema/<-SQLite valueType value)
(raise "Unknown valueType for attribute " attr ", expected one of " (sorted-set (keys value-type-map)) (raise "Unknown valueType for attribute " attr ", expected one of " (sorted-set (keys value-type-map))
{:error :schema/valueType, :attribute attr})) {:error :schema/valueType, :attribute attr}))
(raise "Unknown attribute " attr ", expected one of " (sorted-set (keys schema)) (raise "Unknown attribute " attr ", expected one of " (sorted-set (keys schema))

59
src/datomish/schema.edn Normal file
View file

@ -0,0 +1,59 @@
[
;; news
{:db/id #db/id[:db.part/db]
:db/ident :news/title
:db/valueType :db.type/string
:db/cardinality :db.cardinality/one
:db/fulltext true
:db/doc "A news story's title"
:db.install/_attribute :db.part/db}
{:db/id #db/id[:db.part/db]
:db/ident :news/foobar
:db/valueType :db.type/string
:db/cardinality :db.cardinality/one
:db/unique :db.unique/identity
:db/fulltext true
:db/doc "A news story's foobar"
:db.install/_attribute :db.part/db}
{:db/id #db/id[:db.part/db]
:db/ident :news/zot
:db/valueType :db.type/string
:db/cardinality :db.cardinality/one
:db/unique :db.unique/identity
:db/fulltext true
:db/doc "A news story's zot"
:db.install/_attribute :db.part/db}
{:db/id #db/id[:db.part/db]
:db/ident :news/baz
:db/valueType :db.type/ref
:db/cardinality :db.cardinality/one
:db/doc "A news story's baz"
:db.install/_attribute :db.part/db}
{:db/id #db/id[:db.part/db]
:db/ident :news/url
:db/valueType :db.type/string
:db/cardinality :db.cardinality/one
:db/doc "A news story's url"
:db.install/_attribute :db.part/db}
{:db/id #db/id[:db.part/db]
:db/ident :news/summary
:db/valueType :db.type/string
:db/cardinality :db.cardinality/one
:db/doc "Automatically generated summary of a news story"
:db.install/_attribute :db.part/db}
{:db/id #db/id[:db.part/db]
:db/ident :news/category
:db/valueType :db.type/string
:db/cardinality :db.cardinality/many
:db/fulltext true
:db/doc "Categories automatically set for a news story"
:db.install/_attribute :db.part/db}
]

3
src/datomish/schema_changes.cljc
View file

@ -6,9 +6,6 @@
(:require (:require
[datomish.util :as util #?(:cljs :refer-macros :clj :refer) [raise raise-str cond-let]])) [datomish.util :as util #?(:cljs :refer-macros :clj :refer) [raise raise-str cond-let]]))
(defn- is-install? [db [_ a & _]]
(= a (get-in db [:idents :db.install/attribute])))
(defn datoms->schema-fragment (defn datoms->schema-fragment
"Turn [[:db.part/db :db.install/attribute e] [e :db/ident :attr]] into {:attr {:db/* v}}. "Turn [[:db.part/db :db.install/attribute e] [e :db/ident :attr]] into {:attr {:db/* v}}.

4
src/datomish/sqlite.cljc
View file

@ -24,7 +24,7 @@
(def sql-quoting-style :ansi) (def sql-quoting-style :ansi)
(defn format [args] (defn format [args]
(honeysql.core/format args :quoting :ansi)) (honeysql.core/format args :quoting sql-quoting-style))
(defprotocol ISQLiteConnection (defprotocol ISQLiteConnection
(-execute! (-execute!
@ -76,7 +76,7 @@
;; channel being rejected and no further row callbacks ;; channel being rejected and no further row callbacks
;; being called. ;; being called.
(when (second result) (when (second result)
(put! result c)) (put! c result))
(close! c)))) (close! c))))
(defn all-rows (defn all-rows

204
src/datomish/sqlite_schema.cljc
View file

@ -8,7 +8,7 @@
[datomish.pair-chan :refer [go-pair <?]] [datomish.pair-chan :refer [go-pair <?]]
[cljs.core.async.macros :refer [go]])) [cljs.core.async.macros :refer [go]]))
(:require (:require
[datomish.util :as util #?(:cljs :refer-macros :clj :refer) [raise-str cond-let]] [datomish.util :as util #?(:cljs :refer-macros :clj :refer) [raise raise-str cond-let]]
[datomish.sqlite :as s] [datomish.sqlite :as s]
#?@(:clj [[datomish.pair-chan :refer [go-pair <?]] #?@(:clj [[datomish.pair-chan :refer [go-pair <?]]
[clojure.core.async :refer [go <! >!]]]) [clojure.core.async :refer [go <! >!]]])
@ -19,34 +19,51 @@
(def v1-statements (def v1-statements
["CREATE TABLE datoms (e INTEGER NOT NULL, a SMALLINT NOT NULL, v BLOB NOT NULL, tx INTEGER NOT NULL, ["CREATE TABLE datoms (e INTEGER NOT NULL, a SMALLINT NOT NULL, v BLOB NOT NULL, tx INTEGER NOT NULL,
value_type_tag SMALLINT NOT NULL,
index_avet TINYINT NOT NULL DEFAULT 0, index_vaet TINYINT NOT NULL DEFAULT 0, index_avet TINYINT NOT NULL DEFAULT 0, index_vaet TINYINT NOT NULL DEFAULT 0,
index_fulltext TINYINT NOT NULL DEFAULT 0, index_fulltext TINYINT NOT NULL DEFAULT 0,
unique_value TINYINT NOT NULL DEFAULT 0, unique_identity TINYINT NOT NULL DEFAULT 0)" unique_value TINYINT NOT NULL DEFAULT 0)"
"CREATE INDEX idx_datoms_eavt ON datoms (e, a, v)" "CREATE UNIQUE INDEX idx_datoms_eavt ON datoms (e, a, value_type_tag, v)"
"CREATE INDEX idx_datoms_aevt ON datoms (a, e, v)" "CREATE UNIQUE INDEX idx_datoms_aevt ON datoms (a, e, value_type_tag, v)"
;; n.b., v0/value_type_tag0 can be NULL, in which case we look up v from datoms;
;; and the datom columns are NULL into the LEFT JOIN fills them in.
;; TODO: update comment about sv.
"CREATE TABLE tx_lookup (e0 INTEGER NOT NULL, a0 SMALLINT NOT NULL, v0 BLOB NOT NULL, tx0 INTEGER NOT NULL, added0 TINYINT NOT NULL,
value_type_tag0 SMALLINT NOT NULL,
index_avet0 TINYINT, index_vaet0 TINYINT,
index_fulltext0 TINYINT,
unique_value0 TINYINT,
sv BLOB,
svalue_type_tag SMALLINT,
rid INTEGER,
e INTEGER, a SMALLINT, v BLOB, tx INTEGER, value_type_tag SMALLINT)"
;; Note that `id_tx_lookup_added` is created and dropped
;; after insertion, which makes insertion slightly faster.
;; Prevent overlapping transactions. TODO: drop added0?
"CREATE UNIQUE INDEX idx_tx_lookup_eavt ON tx_lookup (e0, a0, v0, added0, value_type_tag0) WHERE sv IS NOT NULL"
;; Opt-in index: only if a has :db/index true. ;; Opt-in index: only if a has :db/index true.
"CREATE UNIQUE INDEX idx_datoms_avet ON datoms (a, v, e) WHERE index_avet IS NOT 0" "CREATE UNIQUE INDEX idx_datoms_avet ON datoms (a, value_type_tag, v, e) WHERE index_avet IS NOT 0"
;; Opt-in index: only if a has :db/valueType :db.type/ref. ;; Opt-in index: only if a has :db/valueType :db.type/ref. No need for tag here since all
;; indexed elements are refs.
"CREATE UNIQUE INDEX idx_datoms_vaet ON datoms (v, a, e) WHERE index_vaet IS NOT 0" "CREATE UNIQUE INDEX idx_datoms_vaet ON datoms (v, a, e) WHERE index_vaet IS NOT 0"
;; Opt-in index: only if a has :db/fulltext true; thus, it has :db/valueType :db.type/string, ;; Opt-in index: only if a has :db/fulltext true; thus, it has :db/valueType :db.type/string,
;; which is not :db/valueType :db.type/ref. That is, index_vaet and index_fulltext are mutually ;; which is not :db/valueType :db.type/ref. That is, index_vaet and index_fulltext are mutually
;; exclusive. ;; exclusive.
"CREATE INDEX idx_datoms_fulltext ON datoms (v, a, e) WHERE index_fulltext IS NOT 0" "CREATE INDEX idx_datoms_fulltext ON datoms (value_type_tag, v, a, e) WHERE index_fulltext IS NOT 0"
;; TODO: possibly remove this index. :db.unique/value should be asserted by the transactor in ;; TODO: possibly remove this index. :db.unique/{value,identity} should be asserted by the
;; all cases, but the index may speed up some of SQLite's query planning. For now, it services ;; transactor in all cases, but the index may speed up some of SQLite's query planning. For now,
;; to validate the transactor implementation. ;; it serves to validate the transactor implementation. Note that tag is needed here to
"CREATE UNIQUE INDEX idx_datoms_unique_value ON datoms (v) WHERE unique_value IS NOT 0" ;; differentiate, e.g., keywords and strings.
;; TODO: possibly remove this index. :db.unique/identity should be asserted by the transactor in "CREATE UNIQUE INDEX idx_datoms_unique_value ON datoms (a, value_type_tag, v) WHERE unique_value IS NOT 0"
;; all cases, but the index may speed up some of SQLite's query planning. For now, it serves to
;; validate the transactor implementation.
"CREATE UNIQUE INDEX idx_datoms_unique_identity ON datoms (a, v) WHERE unique_identity IS NOT 0"
"CREATE TABLE transactions (e INTEGER NOT NULL, a SMALLINT NOT NULL, v BLOB NOT NULL, tx INTEGER NOT NULL, added TINYINT NOT NULL DEFAULT 1)" "CREATE TABLE transactions (e INTEGER NOT NULL, a SMALLINT NOT NULL, v BLOB NOT NULL, tx INTEGER NOT NULL, added TINYINT NOT NULL DEFAULT 1, value_type_tag SMALLINT NOT NULL)"
"CREATE INDEX idx_transactions_tx ON transactions (tx)" "CREATE INDEX idx_transactions_tx ON transactions (tx, added)"
;; Fulltext indexing. ;; Fulltext indexing.
;; A fulltext indexed value v is an integer rowid referencing fulltext_values. ;; A fulltext indexed value v is an integer rowid referencing fulltext_values.
@ -57,27 +74,45 @@
;; By default we use Unicode-aware tokenizing (particularly for case folding), but preserve ;; By default we use Unicode-aware tokenizing (particularly for case folding), but preserve
;; diacritics. ;; diacritics.
"CREATE VIRTUAL TABLE fulltext_values "CREATE VIRTUAL TABLE fulltext_values
USING FTS4 (text NOT NULL, tokenize=unicode61 \"remove_diacritics=0\")" USING FTS4 (text NOT NULL, searchid INT, tokenize=unicode61 \"remove_diacritics=0\")"
;; This combination of view and triggers allows you to transparently
;; update-or-insert into FTS. Just INSERT INTO fulltext_values_view (text, searchid).
"CREATE VIEW fulltext_values_view AS SELECT * FROM fulltext_values"
"CREATE TRIGGER replace_fulltext_searchid
INSTEAD OF INSERT ON fulltext_values_view
WHEN EXISTS (SELECT 1 FROM fulltext_values WHERE text = new.text)
BEGIN
UPDATE fulltext_values SET searchid = new.searchid WHERE text = new.text;
END"
"CREATE TRIGGER insert_fulltext_searchid
INSTEAD OF INSERT ON fulltext_values_view
WHEN NOT EXISTS (SELECT 1 FROM fulltext_values WHERE text = new.text)
BEGIN
INSERT INTO fulltext_values (text, searchid) VALUES (new.text, new.searchid);
END"
;; A view transparently interpolating fulltext indexed values into the datom structure. ;; A view transparently interpolating fulltext indexed values into the datom structure.
"CREATE VIEW fulltext_datoms AS "CREATE VIEW fulltext_datoms AS
SELECT e, a, fulltext_values.text AS v, tx, index_avet, index_vaet, index_fulltext, unique_value, unique_identity SELECT e, a, fulltext_values.text AS v, tx, value_type_tag, index_avet, index_vaet, index_fulltext, unique_value
FROM datoms, fulltext_values FROM datoms, fulltext_values
WHERE datoms.index_fulltext IS NOT 0 AND datoms.v = fulltext_values.rowid" WHERE datoms.index_fulltext IS NOT 0 AND datoms.v = fulltext_values.rowid"
;; A view transparently interpolating all entities (fulltext and non-fulltext) into the datom structure. ;; A view transparently interpolating all entities (fulltext and non-fulltext) into the datom structure.
"CREATE VIEW all_datoms AS "CREATE VIEW all_datoms AS
SELECT e, a, v, tx, index_avet, index_vaet, index_fulltext, unique_value, unique_identity SELECT e, a, v, tx, value_type_tag, index_avet, index_vaet, index_fulltext, unique_value
FROM datoms FROM datoms
WHERE index_fulltext IS 0 WHERE index_fulltext IS 0
UNION ALL UNION ALL
SELECT e, a, v, tx, index_avet, index_vaet, index_fulltext, unique_value, unique_identity SELECT e, a, v, tx, value_type_tag, index_avet, index_vaet, index_fulltext, unique_value
FROM fulltext_datoms" FROM fulltext_datoms"
;; Materialized views of the schema. ;; Materialized views of the schema.
"CREATE TABLE idents (ident TEXT NOT NULL PRIMARY KEY, entid INTEGER UNIQUE NOT NULL)" "CREATE TABLE idents (ident TEXT NOT NULL PRIMARY KEY, entid INTEGER UNIQUE NOT NULL)"
;; TODO: allow arbitrary schema values (true/false) and tag the resulting values.
"CREATE TABLE schema (ident TEXT NOT NULL, attr TEXT NOT NULL, value TEXT NOT NULL, FOREIGN KEY (ident) REFERENCES idents (ident))" "CREATE TABLE schema (ident TEXT NOT NULL, attr TEXT NOT NULL, value TEXT NOT NULL, FOREIGN KEY (ident) REFERENCES idents (ident))"
"CREATE INDEX idx_schema_unique ON schema (ident, attr, value)" "CREATE INDEX idx_schema_unique ON schema (ident, attr, value)"
"CREATE TABLE parts (part INTEGER NOT NULL PRIMARY KEY, start INTEGER NOT NULL, idx INTEGER NOT NULL)"
]) ])
(defn <create-current-version (defn <create-current-version
@ -115,3 +150,130 @@
(< v current-version) (< v current-version)
(<? (<update-from-version db v)))))) (<? (<update-from-version db v))))))
;; This is close to the SQLite schema since it may impact the value tag bit.
(defprotocol IEncodeSQLite
(->SQLite [x] "Transforms Clojure{Script} values to SQLite."))
(extend-protocol IEncodeSQLite
#?@(:clj
[String
(->SQLite [x] x)
clojure.lang.Keyword
(->SQLite [x] (str x))
Boolean
(->SQLite [x] (if x 1 0))
Integer
(->SQLite [x] x)
Long
(->SQLite [x] x)
java.util.Date
(->SQLite [x] (.getTime x))
java.util.UUID
(->SQLite [x] (.toString x)) ; TODO: BLOB storage. Issue #44.
Float
(->SQLite [x] x)
Double
(->SQLite [x] x)]
:cljs
[string
(->SQLite [x] x)
Keyword
(->SQLite [x] (str x))
boolean
(->SQLite [x] (if x 1 0))
js/Date
(->SQLite [x] (.getTime x))
number
(->SQLite [x] x)]))
;; Datomish rows are tagged with a numeric representation of :db/valueType:
;; The tag is used to limit queries, and therefore is placed carefully in the relevant indices to
;; allow searching numeric longs and doubles quickly. The tag is also used to convert SQLite values
;; to the correct Datomish value type on query egress.
(def value-type-tag-map
{:db.type/ref 0
:db.type/boolean 1
:db.type/instant 4
:db.type/long 5 ;; SQLite distinguishes integral from decimal types, allowing long and double to share a tag.
:db.type/double 5 ;; SQLite distinguishes integral from decimal types, allowing long and double to share a tag.
:db.type/string 10
:db.type/uuid 11
:db.type/uri 12
:db.type/keyword 13})
(defn ->tag [valueType]
(or
(valueType value-type-tag-map)
(raise "Unknown valueType " valueType ", expected one of " (sorted-set (keys value-type-tag-map))
{:error :SQLite/tag, :valueType valueType})))
#?(:clj
(defn <-tagged-SQLite
"Transforms SQLite values to Clojure with tag awareness."
[tag value]
(case tag
;; In approximate commonality order.
0 value ; ref.
1 (= value 1) ; boolean
4 (java.util.Date. value) ; instant
13 (keyword (subs value 1)) ; keyword
12 (java.net.URI. value) ; URI
11 (java.util.UUID/fromString value) ; UUID
; 5 value ; numeric
; 10 value ; string
value
)))
#?(:cljs
(defn <-tagged-SQLite
"Transforms SQLite values to ClojureScript with tag awareness."
[tag value]
;; In approximate commonality order.
(case tag
0 value ; ref.
1 (= value 1) ; boolean
4 (js/Date. value) ; instant
13 (keyword (subs value 1)) ; keyword
; 12 value ; URI
; 11 value ; UUID
; 5 value ; numeric
; 10 value ; string
value
)))
(defn tagged-SQLite-to-JS
"Transforms SQLite values to JavaScript-compatible values."
[tag value]
(case tag
1 (= value 1) ; boolean.
; 0 value ; No point trying to ident.
; 4 value ; JS doesn't have a Date representation.
; 13 value ; Return the keyword string from the DB: ":foobar".
value))
(defn <-SQLite
"Transforms SQLite values to Clojure{Script}."
[valueType value]
(case valueType
:db.type/ref value
:db.type/keyword (keyword (subs value 1))
:db.type/string value
:db.type/boolean (not= value 0)
:db.type/long value
:db.type/instant (<-tagged-SQLite 4 value)
:db.type/uuid (<-tagged-SQLite 11 value)
:db.type/double value))

21
src/datomish/test_macros.cljc
View file

@ -4,7 +4,9 @@
(ns datomish.test-macros (ns datomish.test-macros
#?(:cljs #?(:cljs
(:require-macros [datomish.test-macros])) (:require-macros
[datomish.test-macros]
[datomish.node-tempfile-macros]))
(:require (:require
[datomish.pair-chan])) [datomish.pair-chan]))
@ -38,3 +40,20 @@
(let [[v# e#] (clojure.core.async/<!! (datomish.pair-chan/go-pair ~@body))] (let [[v# e#] (clojure.core.async/<!! (datomish.pair-chan/go-pair ~@body))]
(when e# (throw e#)) ;; Assert nil just to be safe, even though we should always throw first. (when e# (throw e#)) ;; Assert nil just to be safe, even though we should always throw first.
(clojure.test/is (= e# nil)))))) (clojure.test/is (= e# nil))))))
(defmacro deftest-db
[n conn-var & body]
`(deftest-async ~n
(if-cljs
(datomish.node-tempfile-macros/with-tempfile [t# (datomish.node-tempfile/tempfile)]
(let [~conn-var (datomish.pair-chan/<? (datomish.api/<connect t#))]
(try
~@body
(finally
(datomish.pair-chan/<? (datomish.api/<close ~conn-var))))))
(tempfile.core/with-tempfile [t# (tempfile.core/tempfile)]
(let [~conn-var (datomish.pair-chan/<? (datomish.api/<connect t#))]
(try
~@body
(finally
(datomish.pair-chan/<? (datomish.api/<close ~conn-var)))))))))

272
src/datomish/transact.cljc
View file

@ -13,6 +13,7 @@
[datomish.query.source :as source] [datomish.query.source :as source]
[datomish.query :as query] [datomish.query :as query]
[datomish.db :as db :refer [id-literal id-literal?]] [datomish.db :as db :refer [id-literal id-literal?]]
[datomish.db.debug :as debug]
[datomish.datom :as dd :refer [datom datom? #?@(:cljs [Datom])]] [datomish.datom :as dd :refer [datom datom? #?@(:cljs [Datom])]]
[datomish.util :as util #?(:cljs :refer-macros :clj :refer) [raise raise-str cond-let]] [datomish.util :as util #?(:cljs :refer-macros :clj :refer) [raise raise-str cond-let]]
[datomish.schema :as ds] [datomish.schema :as ds]
@ -21,6 +22,8 @@
[datomish.sqlite-schema :as sqlite-schema] [datomish.sqlite-schema :as sqlite-schema]
[datomish.transact.bootstrap :as bootstrap] [datomish.transact.bootstrap :as bootstrap]
[datomish.transact.explode :as explode] [datomish.transact.explode :as explode]
[taoensso.tufte :as tufte
#?(:cljs :refer-macros :clj :refer) [defnp p profiled profile]]
#?@(:clj [[datomish.pair-chan :refer [go-pair <?]] #?@(:clj [[datomish.pair-chan :refer [go-pair <?]]
[clojure.core.async :as a :refer [chan go <! >!]]]) [clojure.core.async :as a :refer [chan go <! >!]]])
#?@(:cljs [[datomish.pair-chan] #?@(:cljs [[datomish.pair-chan]
@ -56,7 +59,8 @@
(defrecord TxReport [db-before ;; The DB before the transaction. (defrecord TxReport [db-before ;; The DB before the transaction.
db-after ;; The DB after the transaction. db-after ;; The DB after the transaction.
current-tx ;; The tx ID represented by the transaction in this report. tx ;; The tx ID represented by the transaction in this report; refer :db/tx.
txInstant ;; The timestamp instant when the the transaction was processed/committed in this report; refer :db/txInstant.
entities ;; The set of entities (like [:db/add e a v tx]) processed. entities ;; The set of entities (like [:db/add e a v tx]) processed.
tx-data ;; The set of datoms applied to the database, like (Datom. e a v tx added). tx-data ;; The set of datoms applied to the database, like (Datom. e a v tx added).
tempids ;; The map from id-literal -> numeric entid. tempids ;; The map from id-literal -> numeric entid.
@ -106,11 +110,14 @@
entity)) entity))
(defn maybe-ident->entid [db [op e a v tx :as orig]] (defn maybe-ident->entid [db [op e a v tx :as orig]]
(let [e (get (db/idents db) e e) ;; TODO: use ident, entid here. (let [e (db/entid db e)
a (get (db/idents db) a a) a (db/entid db a)
v (if (ds/kw? (db/schema db) a) ;; TODO: decide if this is best. We could also check for ref and numeric types. v (if (ds/kw? (db/schema db) a) ;; TODO: decide if this is best. We could also check for ref and numeric types.
v v
(get (db/idents db) v v))] (db/entid db v))]
(when-not (integer? a)
(raise "Unknown attribute " a
{:form orig :attribute a}))
[op e a v tx])) [op e a v tx]))
(defrecord Transaction [db tempids entities]) (defrecord Transaction [db tempids entities])
@ -120,7 +127,7 @@
(let [tx (:tx report) (let [tx (:tx report)
txInstant (:txInstant report)] txInstant (:txInstant report)]
;; n.b., this must not be symbolic -- it's inserted after we map idents -> entids. ;; n.b., this must not be symbolic -- it's inserted after we map idents -> entids.
[:db/add tx (get-in db [:idents :db/txInstant]) txInstant])) [:db/add tx (db/entid db :db/txInstant) txInstant]))
(defn ensure-entity-form [[op e a v & rest :as entity]] (defn ensure-entity-form [[op e a v & rest :as entity]]
(cond (cond
@ -153,8 +160,8 @@
(defn- tx-instant? [db [op e a & _]] (defn- tx-instant? [db [op e a & _]]
(and (= op :db/add) (and (= op :db/add)
(= e (get-in db [:idents :db/tx])) (= (db/entid db e) (db/entid db :db/tx))
(= a (get-in db [:idents :db/txInstant])))) (= (db/entid db a) (db/entid db :db/txInstant))))
(defn- update-txInstant [db report] (defn- update-txInstant [db report]
"Extract [:db/add :db/tx :db/txInstant ...], and update :txInstant with that value." "Extract [:db/add :db/tx :db/txInstant ...], and update :txInstant with that value."
@ -175,7 +182,7 @@
;; to unify all id-literals in :db.part/tx to the current transaction value, but also seems ;; to unify all id-literals in :db.part/tx to the current transaction value, but also seems
;; inconsistent. ;; inconsistent.
tx (:tx report) tx (:tx report)
db* (assoc-in db [:idents :db/tx] tx)] db* (db/with-ident db :db/tx tx)]
(when-not (sequential? initial-es) (when-not (sequential? initial-es)
(raise "Bad transaction data " initial-es ", expected sequential collection" (raise "Bad transaction data " initial-es ", expected sequential collection"
{:error :transact/syntax, :tx-data initial-es})) {:error :transact/syntax, :tx-data initial-es}))
@ -205,23 +212,48 @@
(->> (update-txInstant db*))))) (->> (update-txInstant db*)))))
(defn- lookup-ref? [x] (defn- lookup-ref? [x]
"Return true if `x` is like [:attr value]." "Return `x` if `x` is like [:attr value], false otherwise."
(and (sequential? x) (and (sequential? x)
(= (count x) 2) (= (count x) 2)
(or (keyword? (first x)) (or (keyword? (first x))
(integer? (first x))))) (integer? (first x)))
x))
(defn <resolve-lookup-refs [db report] (defn <resolve-lookup-refs [db report]
{:pre [(db/db? db) (report? report)]} {:pre [(db/db? db) (report? report)]}
(go-pair (let [entities (:entities report)]
(->> ;; TODO: meta.
(vec (for [[op & entity] (:entities report)] (go-pair
(into [op] (for [field entity] (if (empty? entities)
(if (lookup-ref? field) report
(first (<? (db/<eavt db field))) ;; TODO improve this -- this should be avet, shouldn't it? (assoc-in
field))))) report [:entities]
(assoc-in report [:entities])))) ;; TODO: meta. ;; We can't use `for` because go-pair doesn't traverse function boundaries.
;; Apologies for the tortured nested loop.
(loop [[op & entity] (first entities)
next (rest entities)
acc []]
(if (nil? op)
acc
(recur (first next)
(rest next)
(conj acc
(loop [field (first entity)
rem (rest entity)
acc [op]]
(if (nil? field)
acc
(recur (first rem)
(rest rem)
(conj acc
(if-let [[a v] (lookup-ref? field)]
(or
;; The lookup might fail! If so, throw.
(:e (<? (db/<av db a v)))
(raise "No entity found with attr " a " and val " v "."
{:a a :v v}))
field))))))))))))))
(declare <resolve-id-literals) (declare <resolve-id-literals)
@ -280,7 +312,9 @@
report report
(and (not= op :db/add) (and (not= op :db/add)
(not (empty? (filter id-literal? [e a v])))) (or (id-literal? e)
(id-literal? a)
(id-literal? v)))
(raise "id-literals are resolved for :db/add only" (raise "id-literals are resolved for :db/add only"
{:error :transact/syntax {:error :transact/syntax
:op entity }) :op entity })
@ -289,26 +323,26 @@
(and (id-literal? e) (and (id-literal? e)
(ds/unique-identity? (db/schema db) a) (ds/unique-identity? (db/schema db) a)
(not-any? id-literal? [a v])) (not-any? id-literal? [a v]))
(let [upserted-eid (:e (first (<? (db/<avet db [a v])))) (let [upserted-eid (:e (<? (db/<av db a v)))
allocated-eid (get-in report [:tempids e])] allocated-eid (get-in report [:tempids e])]
(if (and upserted-eid allocated-eid (not= upserted-eid allocated-eid)) (if (and upserted-eid allocated-eid (not= upserted-eid allocated-eid))
(<? (<retry-with-tempid db initial-report initial-entities e upserted-eid)) ;; TODO: not initial report, just the sorted entities here. (<? (<retry-with-tempid db initial-report initial-entities e upserted-eid)) ;; TODO: not initial report, just the sorted entities here.
(let [eid (or upserted-eid allocated-eid (next-eid db))] (let [eid (or upserted-eid allocated-eid (<? (db/<next-eid db e)))]
(recur (allocate-eid report e eid) (cons [op eid a v] entities))))) (recur (allocate-eid report e eid) (cons [op eid a v] entities)))))
;; Start allocating and retrying. We try with e last, so as to eventually upsert it. ;; Start allocating and retrying. We try with e last, so as to eventually upsert it.
(id-literal? v) (id-literal? v)
;; We can't fail with unbound literals here, since we could have multiple. ;; We can't fail with unbound literals here, since we could have multiple.
(let [eid (or (get-in report [:tempids v]) (next-eid db))] (let [eid (or (get-in report [:tempids v]) (<? (db/<next-eid db e)))]
(recur (allocate-eid report v eid) (cons [op e a eid] entities))) (recur (allocate-eid report v eid) (cons [op e a eid] entities)))
(id-literal? a) (id-literal? a)
;; TODO: should we even allow id-literal attributes? Datomic fails in some cases here. ;; TODO: should we even allow id-literal attributes? Datomic fails in some cases here.
(let [eid (or (get-in report [:tempids a]) (next-eid db))] (let [eid (or (get-in report [:tempids a]) (<? (db/<next-eid db e)))]
(recur (allocate-eid report a eid) (cons [op e eid v] entities))) (recur (allocate-eid report a eid) (cons [op e eid v] entities)))
(id-literal? e) (id-literal? e)
(let [eid (or (get-in report [:tempids e]) (next-eid db))] (let [eid (or (get-in report [:tempids e]) (<? (db/<next-eid db e)))]
(recur (allocate-eid report e eid) (cons [op eid a v] entities))) (recur (allocate-eid report e eid) (cons [op eid a v] entities)))
true true
@ -333,127 +367,38 @@
(ds/ensure-valid-value schema a v))) (ds/ensure-valid-value schema a v)))
report)) report))
(defn- <ensure-unique-constraints
"Throw unless all datoms in :tx-data obey the uniqueness constraints."
[db report]
{:pre [(db/db? db) (report? report)]}
;; TODO: consider accumulating errors to show more meaningful error reports.
;; TODO: constrain entities; constrain attributes.
(go-pair
;; TODO: comment on applying datoms that violate uniqueness.
(let [schema (db/schema db)
unique-datoms (transient {})] ;; map (nil, a, v)|(e, a, nil)|(e, a, v) -> datom.
(doseq [[e a v tx added :as datom] (:tx-data report)]
(when added
;; Check for violated :db/unique constraint between datom and existing store.
(when (ds/unique? schema a)
(when-let [found (first (<? (db/<avet db [a v])))]
(raise "Cannot add " datom " because of unique constraint: " found
{:error :transact/unique
:attribute a ;; TODO: map attribute back to ident.
:entity datom})))
;; Check for violated :db/unique constraint between datoms.
(when (ds/unique? schema a)
(let [key [nil a v]]
(when-let [other (get unique-datoms key)]
(raise "Cannot add " datom " and " other " because together they violate unique constraint"
{:error :transact/unique
:attribute a ;; TODO: map attribute back to ident.
:entity datom}))
(assoc! unique-datoms key datom)))
;; Check for violated :db/cardinality :db.cardinality/one constraint between datoms.
(when-not (ds/multival? schema a)
(let [key [e a nil]]
(when-let [other (get unique-datoms key)]
(raise "Cannot add " datom " and " other " because together they violate cardinality constraint"
{:error :transact/unique
:entity datom}))
(assoc! unique-datoms key datom)))
;; Check for duplicated datoms. Datomic doesn't allow overlapping writes, and we don't
;; want to guarantee order, so we don't either.
(let [key [e a v]]
(when-let [other (get unique-datoms key)]
(raise "Cannot add duplicate " datom
{:error :transact/unique
:entity datom}))
(assoc! unique-datoms key datom)))))
report))
(defn <entities->tx-data [db report]
{:pre [(db/db? db) (report? report)]}
(go-pair
(let [initial-report report
{tx :tx} report
schema (db/schema db)]
(loop [report initial-report
es (:entities initial-report)]
(let [[[op e a v :as entity] & entities] es]
(cond
(nil? entity)
report
(= op :db/add)
(if (ds/multival? schema a)
(if (empty? (<? (db/<eavt db [e a v])))
(recur (transact-report report (datom e a v tx true)) entities)
(recur report entities))
(if-let [^Datom old-datom (first (<? (db/<eavt db [e a])))]
(if (= (.-v old-datom) v)
(recur report entities)
(recur (-> report
(transact-report (datom e a (.-v old-datom) tx false))
(transact-report (datom e a v tx true)))
entities))
(recur (transact-report report (datom e a v tx true)) entities)))
(= op :db/retract)
(if (first (<? (db/<eavt db [e a v])))
(recur (transact-report report (datom e a v tx false)) entities)
(recur report entities))
true
(raise "Unknown operation at " entity ", expected :db/add, :db/retract"
{:error :transact/syntax, :operation op, :tx-data entity})))))))
(defn <transact-tx-data (defn <transact-tx-data
[db report] [db report]
{:pre [(db/db? db) (report? report)]} {:pre [(db/db? db) (report? report)]}
(go-pair (let [<apply-entities (fn [db report]
(->> (go-pair
report (let [tx-data (<? (db/<apply-entities db (:tx report) (:entities report)))]
(preprocess db) (assoc report :tx-data tx-data))))]
(go-pair
(->>
report
(preprocess db)
(<resolve-lookup-refs db) (<resolve-lookup-refs db)
(<?) (<?)
(p :resolve-lookup-refs)
(<resolve-id-literals db) (<resolve-id-literals db)
(<?) (<?)
(p :resolve-id-literals)
(<ensure-schema-constraints db) (<ensure-schema-constraints db)
(<?) (<?)
(p :ensure-schema-constraints)
(<entities->tx-data db) (<apply-entities db)
(<?) (<?)
(p :apply-entities)
(<ensure-unique-constraints db) ))))
(<?))))
;; Normalize as [op int|id-literal int|id-literal value|id-literal]. ;; TODO: mention lookup-refs.
;; Replace lookup-refs with entids where possible.
;; Upsert or allocate id-literals.
(defn- is-ident? [db [_ a & _]] (defn- is-ident? [db [_ a & _]]
(= a (get-in db [:idents :db/ident]))) (= a (db/entid db :db/ident)))
(defn collect-db-ident-assertions (defn collect-db-ident-assertions
"Transactions may add idents, install new partitions, and install new schema attributes. "Transactions may add idents, install new partitions, and install new schema attributes.
@ -486,24 +431,22 @@
{:error :schema/idents {:error :schema/idents
:op ia })))))))) :op ia }))))))))
(defn- symbolicate-datom [db [e a v added]]
(let [entids (zipmap (vals (db/idents db)) (keys (db/idents db)))
symbolicate (fn [x]
(get entids x x))]
(datom
(symbolicate e)
(symbolicate a)
(symbolicate v)
added)))
(defn collect-db-install-assertions (defn collect-db-install-assertions
"Transactions may add idents, install new partitions, and install new schema attributes. "Transactions may add idents, install new partitions, and install new schema attributes.
Collect [:db.part/db :db.install/attribute] assertions here." Collect [:db.part/db :db.install/attribute] assertions here."
[db report] [db report]
{:pre [(db/db? db) (report? report)]} {:pre [(db/db? db) (report? report)]}
;; TODO: be more efficient; symbolicating each datom is expensive! ;; Symbolicating is not expensive.
(let [datoms (map (partial symbolicate-datom db) (:tx-data report)) (let [symbolicate-install-datom
(fn [[e a v tx added]]
(datom
(db/ident db e)
(db/ident db a)
(db/ident db v)
tx
added))
datoms (map symbolicate-install-datom (:tx-data report))
schema-fragment (datomish.schema-changes/datoms->schema-fragment datoms)] schema-fragment (datomish.schema-changes/datoms->schema-fragment datoms)]
(assoc-in report [:added-attributes] schema-fragment))) (assoc-in report [:added-attributes] schema-fragment)))
@ -518,7 +461,7 @@
;; transaction ID and transaction timestamp directly from the report; Datomic ;; transaction ID and transaction timestamp directly from the report; Datomic
;; makes this surprisingly difficult: one needs a :db.part/tx temporary and an ;; makes this surprisingly difficult: one needs a :db.part/tx temporary and an
;; explicit upsert of that temporary. ;; explicit upsert of that temporary.
:tx (db/current-tx db) :tx (<? (db/<next-eid db (id-literal :db.part/tx)))
:txInstant (db/now db) :txInstant (db/now db)
:entities tx-data :entities tx-data
:tx-data [] :tx-data []
@ -530,32 +473,25 @@
(<transact-tx-data db) (<transact-tx-data db)
(<?) (<?)
(p :transact-tx-data)
(collect-db-ident-assertions db) (collect-db-ident-assertions db)
(p :collect-db-ident-assertions)
(collect-db-install-assertions db)) (collect-db-install-assertions db)
idents (merge-with merge-ident (:idents db) (:added-idents report)) (p :collect-db-install-assertions))
symbolic-schema (merge-with merge-attr (:symbolic-schema db) (:added-attributes report))
schema (ds/schema (into {} (map (fn [[k v]] [(k idents) v]) symbolic-schema)))
db-after (->
db
(db/<apply-datoms (:tx-data report)) db-after (->
(<?) db
(db/<apply-db-ident-assertions (:added-idents report)) (db/<apply-db-ident-assertions (:added-idents report) merge-ident)
(<?) (<?)
(->> (p :apply-db-ident-assertions))
(db/<apply-db-install-assertions (:added-attributes report)) (db/<apply-db-install-assertions (:added-attributes report) merge-attr)
(<?) (<?)
(->> (p :apply-db-install-assertions)))
;; TODO: abstract this. ]
(assoc :idents idents
:symbolic-schema symbolic-schema
:schema schema)
(db/<advance-tx)
(<?))]
(-> report (-> report
(assoc-in [:db-after] db-after))))) (assoc-in [:db-after] db-after)))))

29
src/datomish/transact/bootstrap.cljc
View file

@ -17,13 +17,15 @@
;; TODO: support user-specified functions in the future. ;; TODO: support user-specified functions in the future.
;; :db.install/function {:db/valueType :db.type/ref ;; :db.install/function {:db/valueType :db.type/ref
;; :db/cardinality :db.cardinality/many} ;; :db/cardinality :db.cardinality/many}
:db/txInstant {:db/valueType :db.type/integer :db/txInstant {:db/valueType :db.type/long
:db/cardinality :db.cardinality/one :db/cardinality :db.cardinality/one
} ;; :db/index true} TODO: Handle this using SQLite protocol. } ;; :db/index true} TODO: Handle this using SQLite protocol.
:db/valueType {:db/valueType :db.type/ref :db/valueType {:db/valueType :db.type/ref
:db/cardinality :db.cardinality/one} :db/cardinality :db.cardinality/one}
:db/cardinality {:db/valueType :db.type/ref :db/cardinality {:db/valueType :db.type/ref
:db/cardinality :db.cardinality/one} :db/cardinality :db.cardinality/one}
:db/doc {:db/valueType :db.type/string
:db/cardinality :db.cardinality/one}
:db/unique {:db/valueType :db.type/ref :db/unique {:db/valueType :db.type/ref
:db/cardinality :db.cardinality/one} :db/cardinality :db.cardinality/one}
:db/isComponent {:db/valueType :db.type/boolean :db/isComponent {:db/valueType :db.type/boolean
@ -52,8 +54,8 @@
:db/noHistory 13 :db/noHistory 13
:db/add 14 :db/add 14
:db/retract 15 :db/retract 15
:db.part/tx 16 :db.part/user 16
:db.part/user 17 :db.part/tx 17
:db/excise 18 :db/excise 18
:db.excise/attrs 19 :db.excise/attrs 19
:db.excise/beforeT 20 :db.excise/beforeT 20
@ -61,15 +63,18 @@
:db.alter/attribute 22 :db.alter/attribute 22
:db.type/ref 23 :db.type/ref 23
:db.type/keyword 24 :db.type/keyword 24
:db.type/integer 25 ;; TODO: :db.type/long, to match Datomic? :db.type/long 25
:db.type/string 26 :db.type/double 26
:db.type/boolean 27 :db.type/string 27
:db.type/instant 28 :db.type/boolean 28
:db.type/bytes 29 :db.type/instant 29
:db.cardinality/one 30 :db.type/bytes 30
:db.cardinality/many 31 :db.cardinality/one 31
:db.unique/value 32 :db.cardinality/many 32
:db.unique/identity 33}) :db.unique/value 33
:db.unique/identity 34
:db/doc 35
})
(defn tx-data [] (defn tx-data []
(concat (concat

28
src/datomish/transact/explode.cljc
View file

@ -34,14 +34,14 @@
(declare explode-entity) (declare explode-entity)
(defn- explode-entity-a-v [db entity eid a v] (defn- explode-entity-a-v [db entity eid a v]
;; a should be symbolic at this point. Map it. TODO: use ident/entid to ensure we have a symbolic attr. (let [a (db/ident db a) ;; We expect a to be an ident, but it's legal to provide an entid.
(let [reverse? (reverse-ref? a) a* (db/entid db a)
reverse? (reverse-ref? a)
straight-a (if reverse? (reverse-ref a) a) straight-a (if reverse? (reverse-ref a) a)
straight-a* (get-in db [:idents straight-a] straight-a) straight-a* (db/entid db straight-a)
_ (when (and reverse? (not (ds/ref? (db/schema db) straight-a*))) _ (when (and reverse? (not (ds/ref? (db/schema db) straight-a*)))
(raise "Bad attribute " a ": reverse attribute name requires {:db/valueType :db.type/ref} in schema" (raise "Bad attribute " a ": reverse attribute name requires {:db/valueType :db.type/ref} in schema"
{:error :transact/syntax, :attribute a, :op entity})) {:error :transact/syntax, :attribute a, :op entity}))]
a* (get-in db [:idents a] a)]
(cond (cond
reverse? reverse?
(explode-entity-a-v db entity v straight-a eid) (explode-entity-a-v db entity v straight-a eid)
@ -60,11 +60,19 @@
:op entity })) :op entity }))
(sequential? v) (sequential? v)
(if (ds/multival? (db/schema db) a*) ;; dm/schema (if (some nil? v)
(mapcat (partial explode-entity-a-v db entity eid a) v) ;; Allow sequences of nested maps, etc. This does mean [[1]] will work. ;; This is a hard one to track down, with a steep stack back in `transact/ensure-entity-form`, so
(raise "Sequential values " v " but attribute " a " is :db.cardinality/one" ;; we error specifically here rather than expanding further.
{:error :transact/entity-sequential-cardinality-one (raise "Sequential attribute value for " a " contains nil."
:op entity })) {:error :transact/sequence-contains-nil
:op entity
:attribute a
:value v})
(if (ds/multival? (db/schema db) a*) ;; dm/schema
(mapcat (partial explode-entity-a-v db entity eid a) v) ;; Allow sequences of nested maps, etc. This does mean [[1]] will work.
(raise "Sequential values " v " but attribute " a " is :db.cardinality/one"
{:error :transact/entity-sequential-cardinality-one
:op entity })))
true true
[[:db/add eid a* v]]))) [[:db/add eid a* v]])))

61
src/datomish/util.cljc
View file

@ -30,25 +30,30 @@
~expr ~expr
(cond-let ~@rest))))) (cond-let ~@rest)))))
(defn ensure-datalog-var [x]
(or (and (symbol? x)
(nil? (namespace x))
(str/starts-with? (name x) "?"))
(throw (ex-info (str x " is not a Datalog var.") {}))))
(defn var->sql-type-var
"Turns '?xyz into :_xyz_type_tag."
[x]
(and
(ensure-datalog-var x)
(keyword (str "_" (subs (name x) 1) "_type_tag"))))
(defn var->sql-var (defn var->sql-var
"Turns '?xyz into :xyz." "Turns '?xyz into :xyz."
[x] [x]
(if (and (symbol? x) (and
(str/starts-with? (name x) "?")) (ensure-datalog-var x)
(keyword (subs (name x) 1)) (keyword (subs (name x) 1))))
(throw (ex-info (str x " is not a Datalog var.") {}))))
(defn conj-in (defn aggregate->sql-var
"Associates a value into a sequence in a nested associative structure, where "Turns (:max 'column) into :%max.column."
ks is a sequence of keys and v is the new value, and returns a new nested [fn-kw x]
structure. (keyword (str "%" (name fn-kw) "." (name x))))
If any levels do not exist, hash-maps will be created. If the destination
sequence does not exist, a new one is created."
{:static true}
[m [k & ks] v]
(if ks
(assoc m k (conj-in (get m k) ks v))
(assoc m k (conj (get m k) v))))
(defn concat-in (defn concat-in
{:static true} {:static true}
@ -57,6 +62,30 @@
(assoc m k (concat-in (get m k) ks vs)) (assoc m k (concat-in (get m k) ks vs))
(assoc m k (concat (get m k) vs)))) (assoc m k (concat (get m k) vs))))
(defn append-in
"Associates a value into a sequence in a nested associative structure, where
ks is a sequence of keys and v is the new value, and returns a new nested
structure.
Always puts the value last.
If any levels do not exist, hash-maps will be created. If the destination
sequence does not exist, a new one is created."
{:static true}
[m path v]
(concat-in m path [v]))
(defn assoc-if
([m k v]
(if v
(assoc m k v)
m))
([m k v & kvs]
(if kvs
(let [[kk vv & remainder] kvs]
(apply assoc-if
(assoc-if m k v)
kk vv remainder))
(assoc-if m k v))))
(defmacro while-let [binding & forms] (defmacro while-let [binding & forms]
`(loop [] `(loop []
(when-let ~binding (when-let ~binding
@ -70,3 +99,5 @@
(f (first xs) (first ys)) (f (first xs) (first ys))
(recur f (rest xs) (rest ys))))) (recur f (rest xs) (rest ys)))))
(defn mapvals [f m]
(into (empty m) (map #(vector (first %) (f (second %))) m)))

19
test/datomish/api.cljc
View file

@ -20,14 +20,9 @@
(defn <connect [uri] (defn <connect [uri]
;; Eventually, URI. For now, just a plain path (no file://). ;; Eventually, URI. For now, just a plain path (no file://).
(go-pair (go-pair
(-> (let [conn (<? (sqlite/<sqlite-connection uri))
(sqlite/<sqlite-connection uri) db (<? (db-factory/<db-with-sqlite-connection conn))]
(<?) (transact/connection-with-db db))))
(db-factory/<db-with-sqlite-connection)
(<?)
(transact/connection-with-db))))
(def <transact! transact/<transact!) (def <transact! transact/<transact!)
@ -38,3 +33,11 @@
(def id-literal db/id-literal) (def id-literal db/id-literal)
(def db transact/db) (def db transact/db)
(def entid db/entid)
(def ident db/ident)
(def <q db/<?q)
(def schema db/schema)

229
test/datomish/db_test.cljc
View file

@ -10,17 +10,20 @@
[cljs.core.async.macros :as a :refer [go]])) [cljs.core.async.macros :as a :refer [go]]))
(:require (:require
[datomish.api :as d] [datomish.api :as d]
[datomish.db.debug :refer [<datoms-after <transactions-after <shallow-entity <fulltext-values]]
[datomish.util :as util #?(:cljs :refer-macros :clj :refer) [raise cond-let]] [datomish.util :as util #?(:cljs :refer-macros :clj :refer) [raise cond-let]]
[datomish.schema :as ds]
[datomish.sqlite :as s] [datomish.sqlite :as s]
[datomish.sqlite-schema] [datomish.sqlite-schema]
[datomish.datom] [datomish.datom]
[datomish.db :as db] #?@(:clj [[datomish.jdbc-sqlite]
#?@(:clj [[datomish.pair-chan :refer [go-pair <?]] [datomish.pair-chan :refer [go-pair <?]]
[tempfile.core :refer [tempfile with-tempfile]] [tempfile.core :refer [tempfile with-tempfile]]
[datomish.test-macros :refer [deftest-async]] [datomish.test-macros :refer [deftest-async]]
[clojure.test :as t :refer [is are deftest testing]] [clojure.test :as t :refer [is are deftest testing]]
[clojure.core.async :refer [go <! >!]]]) [clojure.core.async :refer [go <! >!]]])
#?@(:cljs [[datomish.pair-chan] #?@(:cljs [[datomish.promise-sqlite]
[datomish.pair-chan]
[datomish.test-macros :refer-macros [deftest-async]] [datomish.test-macros :refer-macros [deftest-async]]
[datomish.node-tempfile :refer [tempfile]] [datomish.node-tempfile :refer [tempfile]]
[cljs.test :as t :refer-macros [is are deftest testing async]] [cljs.test :as t :refer-macros [is are deftest testing async]]
@ -36,88 +39,46 @@
(defn- tempids [tx] (defn- tempids [tx]
(into {} (map (juxt (comp :idx first) second) (:tempids tx)))) (into {} (map (juxt (comp :idx first) second) (:tempids tx))))
(defn- <datoms-after [db tx]
(let [entids (zipmap (vals (db/idents db)) (keys (db/idents db)))]
(go-pair
(->>
(s/all-rows (:sqlite-connection db) ["SELECT e, a, v, tx FROM datoms WHERE tx > ?" tx])
(<?)
(mapv #(vector (:e %) (get entids (:a %) (str "fail" (:a %))) (:v %)))
(filter #(not (= :db/txInstant (second %))))
(set)))))
(defn- <datoms [db]
(<datoms-after db 0))
(defn- <shallow-entity [db eid]
;; TODO: make this actually be <entity. Handle :db.cardinality/many and :db/isComponent.
(let [entids (zipmap (vals (db/idents db)) (keys (db/idents db)))]
(go-pair
(->>
(s/all-rows (:sqlite-connection db) ["SELECT a, v FROM datoms WHERE e = ?" eid])
(<?)
(mapv #(vector (entids (:a %)) (:v %)))
(reduce conj {})))))
(defn- <transactions-after [db tx]
(let [entids (zipmap (vals (db/idents db)) (keys (db/idents db)))]
(go-pair
(->>
(s/all-rows (:sqlite-connection db) ["SELECT e, a, v, tx, added FROM transactions WHERE tx > ? ORDER BY tx ASC, e, a, v, added" tx])
(<?)
(mapv #(vector (:e %) (entids (:a %)) (:v %) (:tx %) (:added %)))))))
(defn- <transactions [db]
(<transactions-after db 0))
(defn- <fulltext-values [db]
(go-pair
(->>
(s/all-rows (:sqlite-connection db) ["SELECT rowid, text FROM fulltext_values"])
(<?)
(mapv #(vector (:rowid %) (:text %))))))
;; TODO: use reverse refs!
(def test-schema (def test-schema
[{:db/id (d/id-literal :test -1) [{:db/id (d/id-literal :db.part/user)
:db/ident :x :db/ident :x
:db/unique :db.unique/identity :db/unique :db.unique/identity
:db/valueType :db.type/integer} :db/valueType :db.type/long
{:db/id :db.part/db :db.install/attribute (d/id-literal :test -1)} :db.install/_attribute :db.part/db}
{:db/id (d/id-literal :test -2) {:db/id (d/id-literal :db.part/user)
:db/ident :name :db/ident :name
:db/unique :db.unique/identity :db/unique :db.unique/identity
:db/valueType :db.type/string} :db/valueType :db.type/string
{:db/id :db.part/db :db.install/attribute (d/id-literal :test -2)} :db.install/_attribute :db.part/db}
{:db/id (d/id-literal :test -3) {:db/id (d/id-literal :db.part/user)
:db/ident :y :db/ident :y
:db/cardinality :db.cardinality/many :db/cardinality :db.cardinality/many
:db/valueType :db.type/integer} :db/valueType :db.type/long
{:db/id :db.part/db :db.install/attribute (d/id-literal :test -3)} :db.install/_attribute :db.part/db}
{:db/id (d/id-literal :test -5) {:db/id (d/id-literal :db.part/user)
:db/ident :aka :db/ident :aka
:db/cardinality :db.cardinality/many :db/cardinality :db.cardinality/many
:db/valueType :db.type/string} :db/valueType :db.type/string
{:db/id :db.part/db :db.install/attribute (d/id-literal :test -5)} :db.install/_attribute :db.part/db}
{:db/id (d/id-literal :test -6) {:db/id (d/id-literal :db.part/user)
:db/ident :age :db/ident :age
:db/valueType :db.type/integer} :db/valueType :db.type/long
{:db/id :db.part/db :db.install/attribute (d/id-literal :test -6)} :db.install/_attribute :db.part/db}
{:db/id (d/id-literal :test -7) {:db/id (d/id-literal :db.part/user)
:db/ident :email :db/ident :email
:db/unique :db.unique/identity :db/unique :db.unique/identity
:db/valueType :db.type/string} :db/valueType :db.type/string
{:db/id :db.part/db :db.install/attribute (d/id-literal :test -7)} :db.install/_attribute :db.part/db}
{:db/id (d/id-literal :test -8) {:db/id (d/id-literal :db.part/user)
:db/ident :spouse :db/ident :spouse
:db/unique :db.unique/value :db/unique :db.unique/value
:db/valueType :db.type/string} :db/valueType :db.type/string
{:db/id :db.part/db :db.install/attribute (d/id-literal :test -8)} :db.install/_attribute :db.part/db}
{:db/id (d/id-literal :test -9) {:db/id (d/id-literal :db.part/user)
:db/ident :friends :db/ident :friends
:db/cardinality :db.cardinality/many :db/cardinality :db.cardinality/many
:db/valueType :db.type/ref} :db/valueType :db.type/ref
{:db/id :db.part/db :db.install/attribute (d/id-literal :test -9)} :db.install/_attribute :db.part/db}
]) ])
(deftest-async test-add-one (deftest-async test-add-one
@ -381,10 +342,12 @@
(with-tempfile [t (tempfile)] (with-tempfile [t (tempfile)]
(let [conn (<? (d/<connect t))] (let [conn (<? (d/<connect t))]
(try (try
(is (= :test/ident (d/entid (d/db conn) :test/ident)))
(let [report (<? (d/<transact! conn [[:db/add (d/id-literal :db.part/db -1) :db/ident :test/ident]])) (let [report (<? (d/<transact! conn [[:db/add (d/id-literal :db.part/db -1) :db/ident :test/ident]]))
db-after (:db-after report) eid (get-in report [:tempids (d/id-literal :db.part/db -1)])]
tx (:tx db-after)] (is (= eid (d/entid (d/db conn) :test/ident)))
(is (= (:test/ident (db/idents db-after)) (get-in report [:tempids (d/id-literal :db.part/db -1)])))) (is (= :test/ident (d/ident (d/db conn) eid))))
;; TODO: This should fail, but doesn't, due to stringification of :test/ident. ;; TODO: This should fail, but doesn't, due to stringification of :test/ident.
;; (is (thrown-with-msg? ;; (is (thrown-with-msg?
@ -417,7 +380,7 @@
tx (:tx db-after)] tx (:tx db-after)]
(testing "New ident is allocated" (testing "New ident is allocated"
(is (some? (get-in db-after [:idents :test/attr])))) (is (some? (d/entid db-after :test/attr))))
(testing "Schema is modified" (testing "Schema is modified"
(is (= (get-in db-after [:symbolic-schema :test/attr]) (is (= (get-in db-after [:symbolic-schema :test/attr])
@ -450,34 +413,54 @@
{:db/id :db.part/db :db.install/attribute (d/id-literal :db.part/db -2)} {:db/id :db.part/db :db.install/attribute (d/id-literal :db.part/db -2)}
] ]
tx0 (:tx (<? (d/<transact! conn schema)))] tx0 (:tx (<? (d/<transact! conn schema)))]
(testing "Schema checks"
(is (ds/fulltext? (d/schema (d/db conn))
(d/entid (d/db conn) :test/fulltext))))
(try (try
(testing "Can add fulltext indexed datoms" (testing "Can add fulltext indexed datoms"
(let [r (<? (d/<transact! conn [[:db/add 101 :test/fulltext "test this"]]))] (let [{tx1 :tx txInstant1 :txInstant}
(<? (d/<transact! conn [[:db/add 101 :test/fulltext "test this"]]))]
(is (= (<? (<fulltext-values (d/db conn))) (is (= (<? (<fulltext-values (d/db conn)))
[[1 "test this"]])) [[1 "test this"]]))
(is (= (<? (<datoms-after (d/db conn) tx0)) (is (= (<? (<datoms-after (d/db conn) tx0))
#{[101 :test/fulltext 1]})) ;; Values are raw; 1 is the rowid into fulltext_values. #{[101 :test/fulltext 1]})) ;; Values are raw; 1 is the rowid into fulltext_values.
)) (is (= (<? (<transactions-after (d/db conn) tx0))
[[101 :test/fulltext 1 tx1 1] ;; Values are raw; 1 is the rowid into fulltext_values.
[tx1 :db/txInstant txInstant1 tx1 1]]))
(testing "Can replace fulltext indexed datoms" (testing "Can replace fulltext indexed datoms"
(let [r (<? (d/<transact! conn [[:db/add 101 :test/fulltext "alternate thing"]]))] (let [{tx2 :tx txInstant2 :txInstant} (<? (d/<transact! conn [[:db/add 101 :test/fulltext "alternate thing"]]))]
(is (= (<? (<fulltext-values (d/db conn))) (is (= (<? (<fulltext-values (d/db conn)))
[[1 "test this"] [[1 "test this"]
[2 "alternate thing"]])) [2 "alternate thing"]]))
(is (= (<? (<datoms-after (d/db conn) tx0)) (is (= (<? (<datoms-after (d/db conn) tx0))
#{[101 :test/fulltext 2]})) ;; Values are raw; 2 is the rowid into fulltext_values. #{[101 :test/fulltext 2]})) ;; Values are raw; 2 is the rowid into fulltext_values.
)) (is (= (<? (<transactions-after (d/db conn) tx0))
[[101 :test/fulltext 1 tx1 1] ;; Values are raw; 1 is the rowid into fulltext_values.
[tx1 :db/txInstant txInstant1 tx1 1]
[101 :test/fulltext 1 tx2 0] ;; Values are raw; 1 is the rowid into fulltext_values.
[101 :test/fulltext 2 tx2 1] ;; Values are raw; 2 is the rowid into fulltext_values.
[tx2 :db/txInstant txInstant2 tx2 1]]))
(testing "Can upsert keyed by fulltext indexed datoms" (testing "Can upsert keyed by fulltext indexed datoms"
(let [r (<? (d/<transact! conn [{:db/id (d/id-literal :db.part/user) :test/fulltext "alternate thing" :test/other "other"}]))] (let [{tx3 :tx txInstant3 :txInstant} (<? (d/<transact! conn [{:db/id (d/id-literal :db.part/user) :test/fulltext "alternate thing" :test/other "other"}]))]
(is (= (<? (<fulltext-values (d/db conn))) (is (= (<? (<fulltext-values (d/db conn)))
[[1 "test this"] [[1 "test this"]
[2 "alternate thing"] [2 "alternate thing"]
[3 "other"]])) [3 "other"]]))
(is (= (<? (<datoms-after (d/db conn) tx0)) (is (= (<? (<datoms-after (d/db conn) tx0))
#{[101 :test/fulltext 2] ;; Values are raw; 2, 3 are the rowids into fulltext_values. #{[101 :test/fulltext 2] ;; Values are raw; 2, 3 are the rowids into fulltext_values.
[101 :test/other 3]})) [101 :test/other 3]}))
)) (is (= (<? (<transactions-after (d/db conn) tx0))
[[101 :test/fulltext 1 tx1 1] ;; Values are raw; 1 is the rowid into fulltext_values.
[tx1 :db/txInstant txInstant1 tx1 1]
[101 :test/fulltext 1 tx2 0] ;; Values are raw; 1 is the rowid into fulltext_values.
[101 :test/fulltext 2 tx2 1] ;; Values are raw; 2 is the rowid into fulltext_values.
[tx2 :db/txInstant txInstant2 tx2 1]
[101 :test/other 3 tx3 1] ;; Values are raw; 3 is the rowid into fulltext_values.
[tx3 :db/txInstant txInstant3 tx3 1]]))
))))))
(testing "Can re-use fulltext indexed datoms" (testing "Can re-use fulltext indexed datoms"
(let [r (<? (d/<transact! conn [[:db/add 102 :test/other "test this"]]))] (let [r (<? (d/<transact! conn [[:db/add 102 :test/other "test this"]]))]
@ -632,3 +615,63 @@
(finally (finally
(<? (d/<close conn))))))) (<? (d/<close conn)))))))
(deftest-async test-next-eid
(with-tempfile [t (tempfile)]
(let [conn (<? (d/<connect t))
{tx0 :tx} (<? (d/<transact! conn test-schema))]
(testing "entids are increasing, tx ids are larger than user ids"
(let [r1 (<? (d/<transact! conn [{:db/id (d/id-literal :db.part/user -1) :name "Igor"}]))
r2 (<? (d/<transact! conn [{:db/id (d/id-literal :db.part/user -2) :name "Oleg"}]))
e1 (get (tempids r1) -1)
e2 (get (tempids r2) -2)]
(is (< e1 (:tx r1)))
(is (< e2 (:tx r2)))
(is (< e1 e2))
(is (< (:tx r1) (:tx r2)))
;; Close and re-open same DB.
(<? (d/<close conn))
(let [conn (<? (d/<connect t))]
(try
(testing "entid counters are persisted across re-opens"
(let [r3 (<? (d/<transact! conn [{:db/id (d/id-literal :db.part/user -3) :name "Petr"}]))
e3 (get (tempids r3) -3)]
(is (< e3 (:tx r3)))
(is (< e2 e3))
(is (< (:tx r2) (:tx r3)))))
(finally
(<? (d/<close conn))))))))))
(deftest-async test-unique-value
(with-tempfile [t (tempfile)]
(let [conn (<? (d/<connect t))]
(try
(let [tx0 (:tx (<? (d/<transact! conn [{:db/id (d/id-literal :db.part/user -1)
:db/ident :test/x
:db/unique :db.unique/value
:db/valueType :db.type/long
:db.install/_attribute :db.part/db}
{:db/id (d/id-literal :db.part/user -2)
:db/ident :test/y
:db/unique :db.unique/value
:db/valueType :db.type/long
:db.install/_attribute :db.part/db}])))]
(testing "can insert different :db.unique/value attributes with the same value"
(let [report1 (<? (d/<transact! conn [[:db/add (d/id-literal :db.part/user -1) :test/x 12345]]))
eid1 (get-in report1 [:tempids (d/id-literal :db.part/user -1)])
report2 (<? (d/<transact! conn [[:db/add (d/id-literal :db.part/user -2) :test/y 12345]]))
eid2 (get-in report2 [:tempids (d/id-literal :db.part/user -2)])]
(is (= (<? (<datoms-after (d/db conn) tx0))
#{[eid1 :test/x 12345]
[eid2 :test/y 12345]}))))
(testing "can't upsert a :db.unique/value field"
(is (thrown-with-msg?
ExceptionInfo #"unique constraint"
(<? (d/<transact! conn [{:db/id (d/id-literal :db.part/user -1) :test/x 12345 :test/y 99999}]))))))
(finally
(<? (d/<close conn)))))))

79
test/datomish/places/import_test.cljc Normal file
View file

@ -0,0 +1,79 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
(ns datomish.places.import-test
#?(:cljs
(:require-macros
[datomish.pair-chan :refer [go-pair <?]]
[datomish.node-tempfile-macros :refer [with-tempfile]]
[cljs.core.async.macros :as a :refer [go]]))
(:require
[taoensso.tufte :as tufte
#?(:cljs :refer-macros :clj :refer) [defnp p profiled profile]]
[datomish.api :as d]
[datomish.places.import :as pi]
[datomish.util :as util #?(:cljs :refer-macros :clj :refer) [raise cond-let]]
[datomish.sqlite :as s]
#?@(:clj [[datomish.jdbc-sqlite]
[datomish.pair-chan :refer [go-pair <?]]
[tempfile.core :refer [tempfile with-tempfile]]
[datomish.test-macros :refer [deftest-async]]
[clojure.test :as t :refer [is are deftest testing]]
[clojure.core.async :refer [go <! >!]]])
#?@(:cljs [[datomish.promise-sqlite]
[datomish.pair-chan]
[datomish.test-macros :refer-macros [deftest-async]]
[datomish.node-tempfile :refer [tempfile]]
[cljs.test :as t :refer-macros [is are deftest testing async]]
[cljs.core.async :as a :refer [<! >!]]])))
#?(:cljs
(def Throwable js/Error))
(tufte/add-basic-println-handler! {})
(deftest-async test-import
(with-tempfile [t (tempfile)]
(let [places (<? (s/<sqlite-connection "/tmp/places.sqlite"))
conn (<? (d/<connect t))]
(try
(let [report (profile {:dynamic? true} (<? (pi/import-places conn places)))]
(is (= nil (count (:tx-data report)))))
(finally
(<? (d/<close conn)))))))
(deftest-async test-import-repeat
;; Repeated import is worst possible for the big joins to find datoms that already exist, because
;; *every* datom added in the first import will match in the second.
(with-tempfile [t (tempfile)]
(let [places (<? (s/<sqlite-connection "/tmp/places.sqlite"))
conn (<? (d/<connect t))]
(try
(let [report0 (<? (pi/import-places conn places))
report (profile {:dynamic? true} (<? (pi/import-places conn places)))]
(is (= nil (count (:tx-data report)))))
(finally
(<? (d/<close conn)))))))
#_
(defn <?? [pair-chan]
(datomish.pair-chan/consume-pair (clojure.core.async/<!! pair-chan)))
#_ [
(def places (<?? (s/<sqlite-connection "/tmp/places.sqlite")))
(def conn (<?? (d/<connect "/tmp/testkb.sqlite")))
(def tx0 (:tx (<?? (d/<transact! conn places-schema-fragment))))
(tufte/add-basic-println-handler! {})
(def report (profile {:dynamic? true} (<?? (pi/import conn places))))
;; Empty:
;; "Elapsed time: 5451.610551 msecs"
;; Reimport:
;; "Elapsed time: 25600.358881 msecs"
]

56
test/datomish/query_test.cljc Normal file
View file

@ -0,0 +1,56 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
(ns datomish.query-test
#?(:cljs
(:require-macros
[datomish.pair-chan :refer [go-pair <?]]
[datomish.node-tempfile-macros :refer [with-tempfile]]
[cljs.core.async.macros :as a :refer [go]]))
(:require
[datomish.api :as d]
#?@(:clj [[datomish.jdbc-sqlite]
[datomish.pair-chan :refer [go-pair <?]]
[tempfile.core :refer [tempfile with-tempfile]]
[datomish.test-macros :refer [deftest-async]]
[clojure.test :as t :refer [is are deftest testing]]
[clojure.core.async :refer [go <! >!]]])
#?@(:cljs [[datomish.promise-sqlite]
[datomish.pair-chan]
[datomish.test-macros :refer-macros [deftest-async]]
[datomish.node-tempfile :refer [tempfile]]
[cljs.test :as t :refer-macros [is are deftest testing async]]
[cljs.core.async :as a :refer [<! >!]]]))
#?(:clj
(:import [clojure.lang ExceptionInfo]))
#?(:clj
(:import [datascript.db DB])))
#?(:cljs
(def Throwable js/Error))
(def test-schema
[{:db/id (d/id-literal :db.part/user)
:db/ident :x
:db/unique :db.unique/identity
:db/valueType :db.type/long
:db.install/_attribute :db.part/db}
])
(deftest-async test-q
(with-tempfile [t (tempfile)]
(let [conn (<? (d/<connect t))
{tx0 :tx} (<? (d/<transact! conn test-schema))]
(try
(let [{tx1 :tx} (<? (d/<transact! conn [{:db/id 101 :x 505}]))]
(is (= (<? (d/<q (d/db conn)
[:find '?e '?a '?v '?tx :in '$ :where
'[?e ?a ?v ?tx]
[(list '> '?tx tx0)]
[(list '!= '?a (d/entid (d/db conn) :db/txInstant))] ;; TODO: map ident->entid for values.
] {}))
[[101 (d/entid (d/db conn) :x) 505 tx1]]))) ;; TODO: map entid->ident on egress.
(finally
(<? (d/<close conn)))))))

22
test/datomish/schema_test.cljc Normal file
View file

@ -0,0 +1,22 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
(ns datomish.schema-test
(:require
[datomish.schema :as schema]
#?@(:clj [[datomish.test-macros :refer [deftest-async]]
[clojure.test :as t :refer [is are deftest testing]]])
#?@(:cljs [[datomish.test-macros :refer-macros [deftest-async]]
[cljs.test :as t :refer-macros [is are deftest testing async]]])))
#?(:clj
(deftest test-uuid-validation
(is (not (schema/uuidish? "123e4567-e89b-12d3-a456-426655440000")))
(is (schema/uuidish? (java.util.UUID/fromString "123e4567-e89b-12d3-a456-426655440000")))))
#?(:cljs
(deftest test-uuid-validation
;; Case-insensitive.
(is (schema/uuidish? "123e4567-e89b-12d3-a456-426655440000"))
(is (schema/uuidish? "123E4567-e89b-12d3-a456-426655440000"))))

11
test/datomish/test.cljs
View file

@ -2,18 +2,27 @@
(:require (:require
[doo.runner :refer-macros [doo-tests doo-all-tests]] [doo.runner :refer-macros [doo-tests doo-all-tests]]
[cljs.test :as t :refer-macros [is are deftest testing]] [cljs.test :as t :refer-macros [is are deftest testing]]
datomish.places.import-test
datomish.promise-sqlite-test datomish.promise-sqlite-test
datomish.db-test datomish.db-test
datomish.query-test
datomish.schema-test
datomish.sqlite-user-version-test datomish.sqlite-user-version-test
datomish.tofinoish-test
datomish.test.util datomish.test.util
datomish.test.transforms datomish.test.transforms
datomish.test.query datomish.test.query
datomish.test-macros-test)) datomish.test-macros-test
))
(doo-tests (doo-tests
'datomish.places.import-test
'datomish.promise-sqlite-test 'datomish.promise-sqlite-test
'datomish.db-test 'datomish.db-test
'datomish.query-test
'datomish.schema-test
'datomish.sqlite-user-version-test 'datomish.sqlite-user-version-test
'datomish.tofinoish-test
'datomish.test.util 'datomish.test.util
'datomish.test.transforms 'datomish.test.transforms
'datomish.test.query 'datomish.test.query

613
test/datomish/test/query.cljc
View file

@ -1,18 +1,34 @@
(ns datomish.test.query (ns datomish.test.query
#?(:cljs
(:require-macros
[datomish.pair-chan :refer [go-pair <?]]
[datomish.node-tempfile-macros :refer [with-tempfile]]
[cljs.core.async.macros :as a :refer [go]]))
(:require (:require
[datomish.query.cc :as cc]
[datomish.query.context :as context] [datomish.query.context :as context]
[datomish.query.source :as source] [datomish.query.source :as source]
[datomish.query.transforms :as transforms] [datomish.query.transforms :as transforms]
[datomish.query :as query] [datomish.query :as query]
[datomish.db :as db]
[datomish.schema :as schema]
[datomish.transact :as transact]
[datomish.api :as d]
#?@(:clj #?@(:clj
[ [[datomish.pair-chan :refer [go-pair <?]]
[honeysql.core :as sql :refer [param]] [datomish.jdbc-sqlite]
[clojure.test :as t :refer [is are deftest testing]]]) [datomish.test-macros :refer [deftest-db]]
[honeysql.core :as sql :refer [param]]
[tempfile.core :refer [tempfile with-tempfile]]
[clojure.test :as t :refer [is are deftest testing]]])
#?@(:cljs #?@(:cljs
[ [[datomish.promise-sqlite]
[honeysql.core :as sql :refer-macros [param]] [datomish.test-macros :refer-macros [deftest-db]]
[cljs.test :as t :refer-macros [is are deftest testing]]]) [honeysql.core :as sql :refer-macros [param]]
)) [datomish.node-tempfile :refer [tempfile]]
[cljs.test :as t :refer-macros [is are deftest testing]]]))
#?(:clj
(:import [clojure.lang ExceptionInfo])))
(defn- fgensym [s c] (defn- fgensym [s c]
(symbol (str s c))) (symbol (str s c)))
@ -25,144 +41,479 @@
([s] ([s]
(fgensym s (dec (swap! counter inc))))))) (fgensym s (dec (swap! counter inc)))))))
(defn mock-source [db] (def simple-schema
(source/map->DatomsSource [{:db/id (d/id-literal :db.part/user)
{:table :datoms :db.install/_attribute :db.part/db
:fulltext-table :fulltext_values :db/ident :db/txInstant
:fulltext-view :all_datoms :db/valueType :db.type/long
:columns [:e :a :v :tx :added] :db/cardinality :db.cardinality/one}
:attribute-transform transforms/attribute-transform-string {:db/id (d/id-literal :db.part/user)
:constant-transform transforms/constant-transform-default :db.install/_attribute :db.part/db
:table-alias (comp (make-predictable-gensym) name) :db/ident :foo/bar
:make-constraints nil})) :db/valueType :db.type/string
:db/cardinality :db.cardinality/many}
{:db/id (d/id-literal :db.part/user)
:db.install/_attribute :db.part/db
:db/ident :foo/int
:db/valueType :db.type/long
:db/cardinality :db.cardinality/one}
{:db/id (d/id-literal :db.part/user)
:db.install/_attribute :db.part/db
:db/ident :foo/str
:db/valueType :db.type/string
:db/cardinality :db.cardinality/many}])
(defn- expand [find] (def page-schema
(let [context (context/->Context (mock-source nil) nil nil) [{:db/id (d/id-literal :db.part/user)
:db.install/_attribute :db.part/db
:db/ident :page/loves
:db/valueType :db.type/ref
:db/cardinality :db.cardinality/many}
{:db/id (d/id-literal :db.part/user)
:db.install/_attribute :db.part/db
:db/ident :page/likes
:db/valueType :db.type/ref
:db/cardinality :db.cardinality/many}
{:db/id (d/id-literal :db.part/user)
:db.install/_attribute :db.part/db
:db/ident :page/url
:db/valueType :db.type/string
:db/unique :db.unique/identity
:db/cardinality :db.cardinality/one}
{:db/id (d/id-literal :db.part/user)
:db.install/_attribute :db.part/db
:db/ident :page/title
:db/valueType :db.type/string
:db/cardinality :db.cardinality/one}
{:db/id (d/id-literal :db.part/user)
:db.install/_attribute :db.part/db
:db/ident :page/starred
:db/valueType :db.type/boolean
:db/cardinality :db.cardinality/one}])
(def aggregate-schema
[{:db/id (d/id-literal :db.part/user)
:db.install/_attribute :db.part/db
:db/ident :page/url
:db/valueType :db.type/string
:db/unique :db.unique/identity
:db/cardinality :db.cardinality/one}
{:db/id (d/id-literal :db.part/user)
:db.install/_attribute :db.part/db
:db/ident :foo/points
:db/valueType :db.type/long
:db/cardinality :db.cardinality/many}
{:db/id (d/id-literal :db.part/user)
:db.install/_attribute :db.part/db
:db/ident :foo/visitedAt
:db/valueType :db.type/instant
:db/cardinality :db.cardinality/many}])
(def schema-with-page
(concat
simple-schema
page-schema))
(defn mock-source [db]
(assoc (datomish.db/datoms-source db)
:table-alias (comp (make-predictable-gensym) name)))
(defn conn->context [conn]
(context/make-context (mock-source (d/db conn))))
(defn- expand [find conn]
(let [context (conn->context conn)
parsed (query/parse find)] parsed (query/parse find)]
(query/find->sql-clause context parsed))) (query/find->sql-clause context parsed)))
(deftest test-basic-join (defn- populate [find conn]
(is (= {:select '([:datoms1.v :timestampMicros] [:datoms0.e :page]), (let [context (conn->context conn)
:modifiers [:distinct], parsed (query/parse find)]
:from '[[:datoms datoms0] (query/find-into-context context parsed)))
[:datoms datoms1]],
:where (list
:and
[:= :datoms1.e :datoms0.tx]
[:= :datoms0.a "page/starred"]
[:= :datoms0.v 1]
[:= :datoms1.a "db/txInstant"]
[:not
(list :and (list :> :datoms1.e (sql/param :latest)))])}
(expand
'[:find ?timestampMicros ?page :in $ ?latest :where
[?page :page/starred true ?t]
[?t :db/txInstant ?timestampMicros]
(not [(> ?t ?latest)])]))))
(deftest test-pattern-not-join (defn <initialize-with-schema [conn schema]
(is (= '{:select ([:datoms1.v :timestampMicros] [:datoms0.e :page]), (go-pair
:modifiers [:distinct], (let [tx (<? (d/<transact! conn schema))]
:from [[:datoms datoms0] (let [idents (map :db/ident schema)
[:datoms datoms1]], db (d/db conn)]
:where (:and (into {}
[:= :datoms1.e :datoms0.tx] (map (fn [ident]
[:= :datoms0.a "page/starred"] [ident (d/entid db ident)])
idents))))))
(deftest-db test-type-extraction conn
;; We expect to be able to look up the default types.
(is (integer? (d/entid (d/db conn) :db.type/ref)))
(is (integer? (d/entid (d/db conn) :db.type/long)))
;; Add our own schema.
(<? (<initialize-with-schema conn simple-schema))
(testing "Variable entity."
(is (= (->
(populate '[:find ?e ?v :in $ :where [?e :foo/int ?v]] conn)
:cc :known-types)
{'?v :db.type/long
'?e :db.type/ref})))
(testing "Numeric entid."
(is (= (->
(populate '[:find ?v :in $ :where [6 :foo/int ?v]] conn)
:cc :known-types)
{'?v :db.type/long})))
(testing "Keyword entity."
(is (= (->
(populate '[:find ?v :in $ :where [:my/thing :foo/int ?v]] conn)
:cc :known-types)
{'?v :db.type/long}))))
(deftest-db test-value-constant-constraint-descends-into-not-and-or conn
(let [attrs (<? (<initialize-with-schema conn simple-schema))]
(testing "Elision of types inside a join."
(is (= {:select '([:datoms0.e :e]
[:datoms0.v :v]),
:modifiers [:distinct],
:from [[:datoms 'datoms0]],
:where (list :and
[:= :datoms0.a (:foo/int attrs)]
[:not
[:exists
{:select [1],
:from [[:all_datoms 'all_datoms1]],
:where (list :and
[:= :all_datoms1.e 999]
[:= :datoms0.v :all_datoms1.v])}]])}
(expand
'[:find ?e ?v :in $ :where
[?e :foo/int ?v]
(not [999 ?a ?v])]
conn))))
(testing "Type collisions inside :not."
(is (thrown-with-msg?
ExceptionInfo #"v already has type :db.type.long"
(expand
'[:find ?e ?v :in $ :where
[?e :foo/int ?v]
(not [999 :foo/str ?v])]
conn))))
(testing "Type collisions inside :or"
(is (thrown-with-msg?
ExceptionInfo #"v already has type :db.type.long"
(expand
'[:find ?e ?v :in $ :where
[?e :foo/int ?v]
(or
[999 :foo/str ?v]
[666 :foo/int ?v])]
conn))))))
(deftest-db test-type-collision conn
(<? (<initialize-with-schema conn simple-schema))
(let [find '[:find ?e ?v :in $
:where
[?e :foo/int ?v]
[?x :foo/str ?v]]]
(is (thrown-with-msg?
ExceptionInfo #"v already has type :db.type.long"
(populate find conn)))))
(deftest-db test-value-constant-constraint conn
(<? (<initialize-with-schema conn simple-schema))
(is (= {:select '([:all_datoms0.e :foo]),
:modifiers [:distinct],
:from '[[:all_datoms all_datoms0]],
:where (list :and
(list :or
[:= :all_datoms0.value_type_tag 0]
;; In CLJS, this can also be an `instant`.
#?@(:cljs [[:= :all_datoms0.value_type_tag 4]])
[:= :all_datoms0.value_type_tag 5])
[:= :all_datoms0.v 99])}
(expand
'[:find ?foo :in $ :where
[?foo _ 99]]
conn))))
(deftest-db test-value-constant-constraint-elided-using-schema conn
(let [attrs (<? (<initialize-with-schema conn schema-with-page))]
(testing "Our attributes were interned."
(is (integer? (d/entid (d/db conn) :foo/str)))
(is (integer? (d/entid (d/db conn) :page/starred))))
(testing "There's no need to produce value_type_tag constraints when the attribute is specified."
(is
(= {:select '([:datoms1.v :timestampMicros] [:datoms0.e :page]),
:modifiers [:distinct],
:from [[:datoms 'datoms0]
[:datoms 'datoms1]],
:where (list :and
;; We don't need a type check on the range of page/starred...
[:= :datoms0.a (:page/starred attrs)]
[:= :datoms0.v 1]
[:= :datoms1.a (:db/txInstant attrs)]
[:not
[:exists
{:select [1],
:from [[:datoms 'datoms2]],
:where (list :and
[:= :datoms2.a (:foo/bar attrs)]
[:= :datoms0.e :datoms2.e])}]]
[:= :datoms0.tx :datoms1.e])}
(expand
'[:find ?timestampMicros ?page :in $ ?latest :where
[?page :page/starred true ?t]
[?t :db/txInstant ?timestampMicros]
(not [?page :foo/bar _])]
conn))))))
(deftest-db test-basic-join conn
;; Note that we use a schema without :page/starred, so we
;; don't know what type it is.
(let [attrs (<? (<initialize-with-schema conn simple-schema))]
(is (= {:select '([:datoms1.v :timestampMicros] [:datoms0.e :page]),
:modifiers [:distinct],
:from '([:datoms datoms0]
[:datoms datoms1]),
:where (list
:and
;; Note that :page/starred is literal, because
;; it's not present in the interned schema.
[:= :datoms0.a :page/starred]
[:= :datoms0.value_type_tag 1] ; boolean
[:= :datoms0.v 1] [:= :datoms0.v 1]
[:= :datoms1.a "db/txInstant"] [:= :datoms1.a (:db/txInstant attrs)]
[:not
(list :and (list :> :datoms0.tx (sql/param :latest)))]
[:= :datoms0.tx :datoms1.e])}
(expand
'[:find ?timestampMicros ?page :in $ ?latest :where
[?page :page/starred true ?t]
[?t :db/txInstant ?timestampMicros]
(not [(> ?t ?latest)])]
conn)))))
(deftest-db test-pattern-not-join conn
(let [attrs (<? (<initialize-with-schema conn simple-schema))]
(is (= {:select '([:datoms1.v :timestampMicros] [:datoms0.e :page]),
:modifiers [:distinct],
:from [[:datoms 'datoms0]
[:datoms 'datoms1]],
:where (list
:and
;; Note that :page/starred is literal, because
;; it's not present in the interned schema.
[:= :datoms0.a :page/starred]
[:= :datoms0.value_type_tag 1] ; boolean
[:= :datoms0.v 1]
[:= :datoms1.a (:db/txInstant attrs)]
[:not [:not
[:exists [:exists
{:select [1], {:select [1],
:from [[:datoms datoms2]], :from [[:datoms 'datoms2]],
:where (:and :where (list :and
[:= :datoms2.a "foo/bar"] [:= :datoms2.a (:foo/bar attrs)]
[:= :datoms0.e :datoms2.e])}]])} [:= :datoms0.e :datoms2.e])}]]
(expand [:= :datoms0.tx :datoms1.e])}
'[:find ?timestampMicros ?page :in $ ?latest :where (expand
[?page :page/starred true ?t] '[:find ?timestampMicros ?page :in $ ?latest :where
[?t :db/txInstant ?timestampMicros] [?page :page/starred true ?t]
(not [?page :foo/bar _])])))) [?t :db/txInstant ?timestampMicros]
(not [?page :foo/bar _])]
conn)))))
;; Note that clause ordering is not directly correlated to the output: cross-bindings end up ;; Note that clause ordering is not directly correlated to the output: cross-bindings end up
;; at the front. The SQL engine will do its own analysis. See `clauses/expand-where-from-bindings`. ;; at the front. The SQL engine will do its own analysis. See `clauses/expand-where-from-bindings`.
(deftest test-not-clause-ordering-preserved (deftest-db test-not-clause-ordering-preserved conn
(is (= {:select '([:datoms1.v :timestampMicros] [:datoms0.e :page]), (let [attrs (<? (<initialize-with-schema conn schema-with-page))]
:modifiers [:distinct], (is (= {:select '([:datoms1.v :timestampMicros] [:datoms0.e :page]),
:from '[[:datoms datoms0] :modifiers [:distinct],
[:datoms datoms1]], :from '[[:datoms datoms0]
:where (list [:datoms datoms1]],
:and :where (list
[:= :datoms1.e :datoms0.tx] :and
[:= :datoms0.a "page/starred"] ;; We don't need a value tag constraint -- we know the range of the attribute.
[:= :datoms0.v 1] [:= :datoms0.a (:page/starred attrs)]
[:not
(list :and (list :> :datoms0.tx (sql/param :latest)))]
[:= :datoms1.a "db/txInstant"])}
(expand
'[:find ?timestampMicros ?page :in $ ?latest :where
[?page :page/starred true ?t]
(not [(> ?t ?latest)])
[?t :db/txInstant ?timestampMicros]]))))
(deftest test-pattern-not-join-ordering-preserved
(is (= '{:select ([:datoms2.v :timestampMicros] [:datoms0.e :page]),
:modifiers [:distinct],
:from [[:datoms datoms0]
[:datoms datoms2]],
:where (:and
[:= :datoms2.e :datoms0.tx]
[:= :datoms0.a "page/starred"]
[:= :datoms0.v 1] [:= :datoms0.v 1]
[:not [:not
[:exists (list :and (list :> :datoms0.tx (sql/param :latest)))]
{:select [1], [:= :datoms1.a (:db/txInstant attrs)]
:from [[:datoms datoms1]], [:= :datoms0.tx :datoms1.e]
:where (:and
[:= :datoms1.a "foo/bar"]
[:= :datoms0.e :datoms1.e])}]]
[:= :datoms2.a "db/txInstant"]
)} )}
(expand (expand
'[:find ?timestampMicros ?page :in $ ?latest :where '[:find ?timestampMicros ?page :in $ ?latest :where
[?page :page/starred true ?t] [?page :page/starred true ?t]
(not [?page :foo/bar _]) (not [(> ?t ?latest)])
[?t :db/txInstant ?timestampMicros]])))) [?t :db/txInstant ?timestampMicros]]
conn)))))
(deftest test-single-or (deftest-db test-pattern-not-join-ordering-preserved conn
(is (= '{:select ([:datoms1.e :page]), (let [attrs (<? (<initialize-with-schema conn schema-with-page))]
:modifiers [:distinct], (is (= {:select '([:datoms2.v :timestampMicros] [:datoms0.e :page]),
:from ([:datoms datoms0] [:datoms datoms1] [:datoms datoms2]), :modifiers [:distinct],
:where (:and :from [[:datoms 'datoms0]
[:= :datoms1.e :datoms0.e] [:datoms 'datoms2]],
[:= :datoms1.e :datoms2.v] :where (list :and
[:= :datoms0.a "page/url"] ;; We don't need a value tag constraint -- we know the range of the attribute.
[:= :datoms0.v "http://example.com/"] [:= :datoms0.a (:page/starred attrs)]
[:= :datoms1.a "page/title"] [:= :datoms0.v 1]
[:= :datoms2.a "page/loves"])} [:not
(expand [:exists
'[:find ?page :in $ ?latest :where {:select [1],
[?page :page/url "http://example.com/"] :from [[:datoms 'datoms1]],
[?page :page/title ?title] :where (list :and
(or [:= :datoms1.a (:foo/bar attrs)]
[?entity :page/loves ?page])])))) [:= :datoms0.e :datoms1.e])}]]
[:= :datoms2.a (:db/txInstant attrs)]
[:= :datoms0.tx :datoms2.e])}
(expand
'[:find ?timestampMicros ?page :in $ ?latest :where
[?page :page/starred true ?t]
(not [?page :foo/bar _])
[?t :db/txInstant ?timestampMicros]]
conn)))))
(deftest test-simple-or (deftest-db test-single-or conn
(is (= '{:select ([:datoms1.e :page]), (let [attrs (<? (<initialize-with-schema conn schema-with-page))]
:modifiers [:distinct], (is (= {:select '([:datoms0.e :page]),
:from ([:datoms datoms0] [:datoms datoms1] [:datoms datoms2]), :modifiers [:distinct],
:where (:and :from '([:datoms datoms0] [:datoms datoms1] [:datoms datoms2]),
[:= :datoms1.e :datoms0.e] :where (list :and
[:= :datoms1.e :datoms2.v] [:= :datoms0.a (:page/url attrs)]
[:= :datoms0.a "page/url"] [:= :datoms0.v "http://example.com/"]
[:= :datoms0.v "http://example.com/"] [:= :datoms1.a (:page/title attrs)]
[:= :datoms1.a "page/title"] [:= :datoms2.a (:page/loves attrs)]
(:or [:= :datoms0.e :datoms1.e]
[:= :datoms2.a "page/likes"] [:= :datoms0.e :datoms2.v])}
[:= :datoms2.a "page/loves"]))} (expand
(expand '[:find ?page :in $ ?latest :where
'[:find ?page :in $ ?latest :where [?page :page/url "http://example.com/"]
[?page :page/url "http://example.com/"] [?page :page/title ?title]
[?page :page/title ?title] (or
(or [?entity :page/loves ?page])]
[?entity :page/likes ?page] conn)))))
[?entity :page/loves ?page])]))))
(deftest-db test-simple-or conn
(let [attrs (<? (<initialize-with-schema conn schema-with-page))]
(is (= {:select '([:datoms0.e :page]),
:modifiers [:distinct],
:from '([:datoms datoms0] [:datoms datoms1] [:datoms datoms2]),
:where (list :and
[:= :datoms0.a (:page/url attrs)]
[:= :datoms0.v "http://example.com/"]
[:= :datoms1.a (:page/title attrs)]
(list :or
[:= :datoms2.a (:page/likes attrs)]
[:= :datoms2.a (:page/loves attrs)])
[:= :datoms0.e :datoms1.e]
[:= :datoms0.e :datoms2.v])}
(expand
'[:find ?page :in $ ?latest :where
[?page :page/url "http://example.com/"]
[?page :page/title ?title]
(or
[?entity :page/likes ?page]
[?entity :page/loves ?page])]
conn)))))
(defn tag-clauses [column input]
(let [codes (cc/->tag-codes input)]
(if (= 1 (count codes))
[:= column (first codes)]
(cons :or (map (fn [tag]
[:= column tag])
codes)))))
(deftest-db test-url-tag conn
(let [attrs (<? (<initialize-with-schema conn schema-with-page))]
(is (= {:select '([:all_datoms0.e :page]
[:datoms1.v :thing]),
:modifiers [:distinct],
:from '([:all_datoms all_datoms0]
[:datoms datoms1]),
:where (list
:and
(tag-clauses :all_datoms0.value_type_tag "http://example.com/")
[:= :all_datoms0.v "http://example.com/"]
(list
:or
[:= :datoms1.a (:page/likes attrs)]
[:= :datoms1.a (:page/loves attrs)])
[:= :all_datoms0.e :datoms1.e])}
(expand
'[:find ?page ?thing :in $ ?latest :where
[?page _ "http://example.com/"]
(or
[?page :page/likes ?thing]
[?page :page/loves ?thing])]
conn)))))
(deftest-db test-tag-projection conn
(let [attrs (<? (<initialize-with-schema conn schema-with-page))]
(is (= {:select '([:all_datoms0.e :page]
[:all_datoms0.v :thing]
[:all_datoms0.value_type_tag :_thing_type_tag]),
:modifiers [:distinct],
:from '([:all_datoms all_datoms0])}
(expand
'[:find ?page ?thing :in $ :where
[?page _ ?thing]]
conn)))))
(deftest-db test-aggregates conn
(let [attrs (<? (<initialize-with-schema conn aggregate-schema))
context
(populate '[:find ?date (max ?v)
:with ?e
:in $ ?then
:where
[?e :foo/visitedAt ?date]
[(> ?date ?then)]
[?e :foo/points ?v]] conn)]
(is (= (:group-by-vars context)
['?date '?e]))
(is (= {:select '([:preag.date :date]
[:%max.preag.v :_max_v])
:modifiers [:distinct]
:group-by '(:date :e),
:with {:preag
{:select '([:datoms0.v :date]
[:datoms1.v :v]
[:datoms0.e :e]), ; Because we need to group on it.
:modifiers [:distinct],
:from '([:datoms datoms0] [:datoms datoms1]),
:where (list
:and
[:= :datoms0.a (:foo/visitedAt attrs)]
(list :> :datoms0.v (sql/param :then))
[:= :datoms1.a (:foo/points attrs)]
[:= :datoms0.e :datoms1.e])}}
:from [:preag]}
(query/context->sql-clause context)))))
(deftest-db test-get-else conn
(let [attrs (<? (<initialize-with-schema conn page-schema))]
(is (= {:select (list
[:datoms0.e :page]
[{:select [(sql/call
:coalesce
{:select [:v],
:from [:datoms],
:where [:and
[:= 'a 65540]
[:= 'e :datoms0.e]],
:limit 1}
"No title")],
:limit 1} :title]),
:modifiers [:distinct],
:from '([:datoms datoms0]),
:where (list :and [:= :datoms0.a 65539])}
(expand '[:find ?page ?title :in $
:where
[?page :page/url _]
[(get-else $ ?page :page/title "No title") ?title]]
conn)))))

16
test/datomish/test/util.cljc
View file

@ -9,6 +9,22 @@
(is (= :x (util/var->sql-var '?x))) (is (= :x (util/var->sql-var '?x)))
(is (= :XX (util/var->sql-var '?XX)))) (is (= :XX (util/var->sql-var '?XX))))
#?(:cljs
(deftest test-integer?-js
(is (integer? 0))
(is (integer? 5))
(is (integer? 50000000000))
(is (integer? 5.00)) ; Because JS.
(is (not (integer? 5.1)))))
#?(:clj
(deftest test-integer?-clj
(is (integer? 0))
(is (integer? 5))
(is (integer? 50000000000))
(is (not (integer? 5.00)))
(is (not (integer? 5.1)))))
#?(:cljs #?(:cljs
(deftest test-raise (deftest test-raise
(let [caught (let [caught

466
test/datomish/tofinoish_test.cljc Normal file
View file

@ -0,0 +1,466 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
(ns datomish.tofinoish-test
#?(:cljs
(:require-macros
[datomish.pair-chan :refer [go-pair <?]]
[datomish.node-tempfile-macros :refer [with-tempfile]]
[cljs.core.async.macros :as a :refer [go]]))
(:require
[datomish.api :as d]
[datomish.util :as util]
#?@(:clj [[datomish.jdbc-sqlite]
[datomish.pair-chan :refer [go-pair <?]]
[tempfile.core :refer [tempfile with-tempfile]]
[datomish.test-macros :refer [deftest-async deftest-db]]
[clojure.test :as t :refer [is are deftest testing]]
[clojure.core.async :refer [go <! >!]]])
#?@(:cljs [[datomish.promise-sqlite]
[datomish.pair-chan]
[datomish.test-macros :refer-macros [deftest-async deftest-db]]
[datomish.node-tempfile :refer [tempfile]]
[cljs.test :as t :refer-macros [is are deftest testing async]]
[cljs.core.async :as a :refer [<! >!]]]))
#?(:clj
(:import [clojure.lang ExceptionInfo]))
#?(:clj
(:import [datascript.db DB])))
#?(:cljs
(def Throwable js/Error))
(def page-schema
[{:db/id (d/id-literal :db.part/user)
:db/ident :page/url
:db/valueType :db.type/string ; Because not all URLs are java.net.URIs. For JS we may want to use /uri.
:db/cardinality :db.cardinality/one
:db/unique :db.unique/identity
:db/doc "A page's URL."
:db.install/_attribute :db.part/db}
{:db/id (d/id-literal :db.part/user)
:db/ident :page/title
:db/valueType :db.type/string
:db/cardinality :db.cardinality/one ; We supersede as we see new titles.
:db/doc "A page's title."
:db.install/_attribute :db.part/db}
{:db/id (d/id-literal :db.part/user)
:db/ident :page/starred
:db/valueType :db.type/boolean
:db/cardinality :db.cardinality/one
:db/doc "Whether the page is starred."
:db.install/_attribute :db.part/db}
{:db/id (d/id-literal :db.part/user)
:db/ident :page/visit
:db/valueType :db.type/ref
:db/cardinality :db.cardinality/many
:db/doc "A visit to the page."
:db.install/_attribute :db.part/db}])
(def visit-schema
[{:db/id (d/id-literal :db.part/user)
:db/ident :visit/visitAt
:db/valueType :db.type/instant
:db/cardinality :db.cardinality/many
:db/doc "The instant of the visit."
:db.install/_attribute :db.part/db}])
(def session-schema
[{:db/id (d/id-literal :db.part/user)
:db/ident :session/startedFromAncestor
:db/valueType :db.type/ref ; To a session.
:db/cardinality :db.cardinality/one
:db/doc "The ancestor of a session."
:db.install/_attribute :db.part/db}
{:db/id (d/id-literal :db.part/user)
:db/ident :session/startedInScope
:db/valueType :db.type/string
:db/cardinality :db.cardinality/one
:db/doc "The parent scope of a session."
:db.install/_attribute :db.part/db}
{:db/id (d/id-literal :db.part/user)
:db/ident :session/startReason
:db/valueType :db.type/string ; TODO: enum?
:db/cardinality :db.cardinality/many
:db/doc "The start reasons of a session."
:db.install/_attribute :db.part/db}
{:db/id (d/id-literal :db.part/user)
:db/ident :session/endReason
:db/valueType :db.type/string ; TODO: enum?
:db/cardinality :db.cardinality/many
:db/doc "The end reasons of a session."
:db.install/_attribute :db.part/db}
{:db/id (d/id-literal :db.part/user)
:db/ident :event/session
:db/valueType :db.type/ref ; To a session.
:db/cardinality :db.cardinality/one
:db/doc "The session in which a tx took place."
:db.install/_attribute :db.part/db}])
(def save-schema
[{:db/id (d/id-literal :db.part/user)
:db.install/_attribute :db.part/db
:db/cardinality :db.cardinality/one
:db/valueType :db.type/ref
:db/ident :save/page}
{:db/id (d/id-literal :db.part/user)
:db.install/_attribute :db.part/db
:db/cardinality :db.cardinality/one
:db/valueType :db.type/instant
:db/ident :save/savedAt}
{:db/id (d/id-literal :db.part/user)
:db.install/_attribute :db.part/db
:db/cardinality :db.cardinality/one
:db/valueType :db.type/string
:db/fulltext true
:db/ident :save/title}
{:db/id (d/id-literal :db.part/user)
:db.install/_attribute :db.part/db
:db/cardinality :db.cardinality/one
:db/valueType :db.type/string
:db/fulltext true
:db/ident :save/excerpt}
{:db/id (d/id-literal :db.part/user)
:db.install/_attribute :db.part/db
:db/cardinality :db.cardinality/one
:db/valueType :db.type/string
:db/fulltext true
:db/ident :save/content}])
(def tofino-schema (concat page-schema visit-schema session-schema save-schema))
(defn instant [x]
#?(:cljs x)
#?(:clj (.getTime x)))
(defn now []
#?(:cljs (js/Date.))
#?(:clj (java.util.Date.)))
;; Returns the session ID.
(defn <start-session [conn {:keys [ancestor scope reason]
:or {reason "none"}}]
(let [id (d/id-literal :db.part/user -1)
base {:db/id id
:session/startedInScope (str scope)
:session/startReason reason}
datoms
(if ancestor
[(assoc base :session/startedFromAncestor ancestor)
{:db/id :db/tx
:event/session ancestor}]
[base])]
(go-pair
(->
(<? (d/<transact! conn datoms))
:tempids
(get id)))))
(defn <end-session [conn {:keys [session reason]
:or {reason "none"}}]
(d/<transact!
conn
[{:db/id :db/tx
:event/session session} ; So meta!
{:db/id session
:session/endReason reason}]))
(defn <active-sessions [db]
(d/<q
db
'[:find ?id ?reason ?ts :in $
:where
[?id :session/startReason ?reason ?tx]
[?tx :db/txInstant ?ts]
(not-join [?id]
[?id :session/endReason _])]
{}))
(defn <ended-sessions [db]
(d/<q
db
'[:find ?id ?endReason ?ts :in $
:where
[?id :session/endReason ?endReason ?tx]
[?tx :db/txInstant ?ts]]
{}))
(defn <star-page [conn {:keys [url uri title session]}]
(let [page (d/id-literal :db.part/user -1)]
(d/<transact!
conn
[{:db/id :db/tx
:event/session session}
(merge
(when title
{:page/title title})
{:db/id page
:page/url (or uri url)
:page/starred true})])))
(defn <starred-pages [db]
(go-pair
(->>
(<?
(d/<q
db
'[:find ?page ?uri ?title ?starredOn
:in $
:where
[?page :page/starred true ?tx]
[?tx :db/txInstant ?starredOn]
[?page :page/url ?uri]
[?page :page/title ?title] ; N.B., this means we will exclude pages with no title.
]
{}))
(map (fn [[page uri title starredOn]]
{:page page :uri uri :title title :starredOn starredOn})))))
(defn <save-page [conn {:keys [url uri title session excerpt content]}]
(let [save (d/id-literal :db.part/user -1)
page (d/id-literal :db.part/user -2)]
(d/<transact!
conn
[{:db/id :db/tx
:event/session session}
{:db/id page
:page/url (or uri url)}
(merge
{:db/id save
:save/savedAt (now)
:save/page page}
(when title
{:save/title title})
(when excerpt
{:save/excerpt excerpt})
(when content
{:save/content content}))])))
(defn <saved-pages [db]
(d/<q db
'[:find ?page ?url ?title ?excerpt
:in $
:where
[?save :save/page ?page]
[?page :page/url ?url]
[(get-else $ ?save :save/title "") ?title]
[(get-else $ ?save :save/excerpt "") ?excerpt]]
{}))
(defn <saved-pages-matching-string [db string]
(d/<q db
{:find '[?page ?url ?title ?excerpt]
:in '[$]
:where [[(list 'fulltext '$ :any string) '[[?save]]]
'[?save :save/page ?page]
'[?page :page/url ?url]
'[(get-else $ ?save :save/title "") ?title]
'[(get-else $ ?save :save/excerpt "") ?excerpt]]}
{}))
;; TODO: return ID?
(defn <add-visit [conn {:keys [url uri title session]}]
(let [visit (d/id-literal :db.part/user -1)
page (d/id-literal :db.part/user -2)]
(d/<transact!
conn
[{:db/id :db/tx
:event/session session}
{:db/id visit
:visit/visitAt (now)}
(merge
(when title
{:page/title title})
{:db/id page
:page/url (or uri url)
:page/visit visit})])))
(defn- third [x]
(nth x 2))
(defn <visited [db
{:keys [limit since]
:or {limit 10}}]
(let [where
(if since
'[[?visit :visit/visitAt ?time]
[(> ?time ?since)]
[?page :page/visit ?visit]
[?page :page/url ?uri]
[(get-else $ ?page :page/title "") ?title]]
'[[?page :page/visit ?visit]
[?visit :visit/visitAt ?time]
[?page :page/url ?uri]
[(get-else $ ?page :page/title "") ?title]])]
(go-pair
(let [rows (<? (d/<q
db
{:find '[?uri ?title (max ?time)]
:in (if since '[$ ?since] '[$])
:where where}
{:since since}))]
(->>
rows
(sort-by (comp unchecked-negate third)) ;; TODO: these should be dates!
(take limit)
(map (fn [[uri title lastVisited]]
{:uri uri :title title :lastVisited lastVisited})))))))
(defn <find-title [db url]
;; Until we support [:find ?title . :in…] we crunch this by hand.
(go-pair
(first
(first
(<?
(d/<q db
'[:find ?title :in $ ?url
:where
[?page :page/url ?url]
[(get-else $ ?page :page/title "") ?title]]
{:url url}))))))
;; Ensure that we can grow the schema over time.
(deftest-db test-schema-evolution conn
(<? (d/<transact! conn page-schema))
(<? (d/<transact! conn tofino-schema)))
(deftest-db test-starring conn
(<? (d/<transact! conn tofino-schema))
(let [session (<? (<start-session conn {:ancestor nil :scope "foo"}))
earliest (instant (now))]
(<? (<star-page conn {:uri "http://mozilla.org/"
:title "Mozilla"
:session session}))
(let [[moz & starred] (<? (<starred-pages (d/db conn)))]
(is (empty? starred))
(is (= "Mozilla" (:title moz)))
(is (<= earliest (:starredOn moz) (instant (now)))))))
(deftest-db test-simple-sessions conn
(<? (d/<transact! conn tofino-schema))
;; Start a session.
(let [session (<? (<start-session conn {:ancestor nil :scope "foo"}))]
(is (integer? session))
;; Now it's active.
(let [active (<? (<active-sessions (d/db conn)))]
(is (= 1 (count active)))
(is (= (first (first active))
session)))
;; There are no ended sessions yet.
(is (empty? (<? (<ended-sessions (d/db conn)))))
(let [earliest (instant (now))]
(<? (<add-visit conn {:uri "http://example.org/"
:title "Example Philanthropy Old"
:session session}))
(<? (<add-visit conn {:uri "http://example.com/"
:title "Example Commercial"
:session session}))
(<? (<add-visit conn {:uri "http://example.org/"
:title "Example Philanthropy New"
:session session}))
(let [latest (instant (now))
visited (<? (<visited (d/db conn) {:limit 3}))]
(is (= 2 (count visited)))
(is (= "http://example.org/" (:uri (first visited))))
(is (= "http://example.com/" (:uri (second visited))))
(is (<= earliest (:lastVisited (first visited)) latest))
(is (<= earliest (:lastVisited (second visited)) latest))
(is (>= (:lastVisited (first visited)) (:lastVisited (second visited))))))
(is (= "Example Philanthropy New"
(<? (<find-title (d/db conn) "http://example.org/"))))
;; Add a page with no title.
(<? (<add-visit conn {:uri "http://notitle.example.org/"
:session session}))
(is (= "" (<? (<find-title (d/db conn) "http://notitle.example.org/"))))
(is (= (select-keys (first (<? (<visited (d/db conn) {:limit 1})))
[:uri :title])
{:uri "http://notitle.example.org/"
:title ""}))
;; If we end this one, then it's no longer active but is ended.
(<? (<end-session conn {:session session}))
(is (empty? (<? (<active-sessions (d/db conn)))))
(is (= 1 (count (<? (<ended-sessions (d/db conn))))))))
(deftest-db test-saved-pages conn
(<? (d/<transact! conn tofino-schema))
;; Start a session.
(let [session (<? (<start-session conn {:ancestor nil :scope "foo"}))]
(<? (<save-page conn {:uri "http://example.com/apples/1"
:title "A page about apples."
:session session
:excerpt "This page tells you things about apples."
:content "<html><head><title>A page about apples.</title></head><body><p>Fruit content goes here.</p></body></html>"}))
(<? (<save-page conn {:uri "http://example.com/apricots/1"
:title "A page about apricots."
:session session
:excerpt nil
:content "<html><head><title>A page about apricots.</title></head><body><p>Fruit content goes here.</p></body></html>"}))
(<? (<save-page conn {:uri "http://example.com/bananas/2"
:title "A page about bananas"
:session session
:excerpt nil
:content nil}))
(let [db (d/db conn)]
;; Fetch all.
(let [all (sort-by first (<? (<saved-pages db)))]
(is (= 3 (count all)))
(let [[[apple-id apple-url apple-title apple-excerpt]
[apricot-id apricot-url apricot-title apricot-excerpt]
[banana-id banana-url banana-title banana-excerpt]]
all]
(is (= apple-url "http://example.com/apples/1"))
(is (= apple-title "A page about apples."))
(is (= apple-excerpt "This page tells you things about apples."))
(is (= apricot-url "http://example.com/apricots/1"))
(is (= apricot-title "A page about apricots."))
(is (= apricot-excerpt ""))
(is (= banana-url "http://example.com/bananas/2"))
(is (= banana-title "A page about bananas"))
(is (= banana-excerpt ""))))
;; Match against title.
(let [this-page (sort-by first (<? (<saved-pages-matching-string db "about apricots")))]
(is (= 1 (count this-page)))
(let [[[apricot-id apricot-url apricot-title apricot-excerpt]]
this-page]
(is (= apricot-url "http://example.com/apricots/1"))
(is (= apricot-title "A page about apricots."))
(is (= apricot-excerpt ""))))
;; Match against excerpt.
(let [this-page (sort-by first (<? (<saved-pages-matching-string db "This page")))]
(is (= 1 (count this-page)))
(let [[[apple-id apple-url apple-title apple-excerpt]]
this-page]
(is (= apple-url "http://example.com/apples/1"))
(is (= apple-title "A page about apples."))
(is (= apple-excerpt "This page tells you things about apples."))))
;; Match against content.
(let [fruit-content (sort-by first (<? (<saved-pages-matching-string db "Fruit content")))]
(is (= 2 (count fruit-content)))
(let [[[apple-id apple-url apple-title apple-excerpt]
[apricot-id apricot-url apricot-title apricot-excerpt]]
fruit-content]
(is (= apple-url "http://example.com/apples/1"))
(is (= apple-title "A page about apples."))
(is (= apple-excerpt "This page tells you things about apples."))
(is (= apricot-url "http://example.com/apricots/1"))
(is (= apricot-title "A page about apricots."))
(is (= apricot-excerpt "")))))))