Respect :db/unique constraints; test upserts.
This version includes SQLite-level unique indexes; these should never be needed. I've included them as a fail-safe while testing; they'll help us catch errors in the transaction layer above.
This commit is contained in:
parent
80742242e2
commit
9497d69b44
4 changed files with 343 additions and 95 deletions
|
@ -77,7 +77,7 @@
|
||||||
(let [e (:e row)
|
(let [e (:e row)
|
||||||
a (:a row)
|
a (:a row)
|
||||||
v (:v row)]
|
v (:v row)]
|
||||||
(Datom. e a (ds/<-SQLite schema a v) (:tx row) (:added row))))
|
(Datom. e a (ds/<-SQLite schema a v) (:tx row) (and (some? (:added row)) (not= 0 (:added row))))))
|
||||||
|
|
||||||
(defrecord DB [sqlite-connection schema idents current-tx]
|
(defrecord DB [sqlite-connection schema idents current-tx]
|
||||||
;; idents is map {ident -> entid} of known idents. See http://docs.datomic.com/identity.html#idents.
|
;; idents is map {ident -> entid} of known idents. See http://docs.datomic.com/identity.html#idents.
|
||||||
|
@ -98,7 +98,7 @@
|
||||||
v (and v (ds/->SQLite schema a v))] ;; We assume e and a are always given.
|
v (and v (ds/->SQLite schema a v))] ;; We assume e and a are always given.
|
||||||
(go-pair
|
(go-pair
|
||||||
(->>
|
(->>
|
||||||
{:select [:*] ;; e :a :v :tx] ;; TODO: generalize columns.
|
{:select [:e :a :v :tx [1 :added]] ;; TODO: generalize columns.
|
||||||
:from [:datoms]
|
:from [:datoms]
|
||||||
:where (cons :and (map #(vector := %1 %2) [:e :a :v :tx] (take-while (comp not nil?) [e a v tx])))} ;; Must drop nils.
|
:where (cons :and (map #(vector := %1 %2) [:e :a :v :tx] (take-while (comp not nil?) [e a v tx])))} ;; Must drop nils.
|
||||||
(sql/format)
|
(sql/format)
|
||||||
|
@ -113,7 +113,9 @@
|
||||||
v (ds/->SQLite schema a v)]
|
v (ds/->SQLite schema a v)]
|
||||||
(go-pair
|
(go-pair
|
||||||
(->>
|
(->>
|
||||||
{:select [:*] :from [:datoms] :where [:and [:= :a a] [:= :v v]]}
|
{:select [:e :a :v :tx [1 :added]] ;; TODO: generalize columns.
|
||||||
|
:from [:datoms]
|
||||||
|
:where [:and [:= :a a] [:= :v v] [:= :index_avet 1]]}
|
||||||
(sql/format)
|
(sql/format)
|
||||||
|
|
||||||
(s/all-rows (:sqlite-connection db))
|
(s/all-rows (:sqlite-connection db))
|
||||||
|
@ -134,8 +136,12 @@
|
||||||
;; Update materialized datom view.
|
;; Update materialized datom view.
|
||||||
(if (.-added datom)
|
(if (.-added datom)
|
||||||
(<? (exec
|
(<? (exec
|
||||||
;; TODO: use schema to insert correct indexing flags.
|
["INSERT INTO datoms VALUES (?, ?, ?, ?, ?, ?, ?, ?)" e a v tx
|
||||||
["INSERT INTO datoms VALUES (?, ?, ?, ?, 0, 0)" e a v tx]))
|
(ds/indexing? (.-schema db) a) ;; index_avet
|
||||||
|
(ds/ref? (.-schema db) a) ;; index_vaet
|
||||||
|
(ds/unique-value? (.-schema db) a) ;; unique_value
|
||||||
|
(ds/unique-identity? (.-schema db) a) ;; unique_identity
|
||||||
|
]))
|
||||||
(<? (exec
|
(<? (exec
|
||||||
;; TODO: verify this is correct.
|
;; TODO: verify this is correct.
|
||||||
["DELETE FROM datoms WHERE (e = ? AND a = ? AND v = ?)" e a v]))))))
|
["DELETE FROM datoms WHERE (e = ? AND a = ? AND v = ?)" e a v]))))))
|
||||||
|
@ -202,9 +208,22 @@
|
||||||
(defn id-literal? [x]
|
(defn id-literal? [x]
|
||||||
(and (instance? TempId x)))
|
(and (instance? TempId x)))
|
||||||
|
|
||||||
(defn temp-literal? [x]
|
(defrecord TxReport [db-before db-after entities tx-data tempids])
|
||||||
(and (id-literal? x)
|
|
||||||
(= :db.part/temp (:part x))))
|
(defn- report? [x]
|
||||||
|
(and (instance? TxReport x)))
|
||||||
|
|
||||||
|
(defonce -eid (atom (- 0x200 1)))
|
||||||
|
|
||||||
|
;; TODO: better here.
|
||||||
|
(defn- next-eid [db]
|
||||||
|
(swap! -eid inc))
|
||||||
|
|
||||||
|
(defn- allocate-eid
|
||||||
|
[report id-literal eid]
|
||||||
|
{:pre [(report? report) (id-literal? id-literal) (and (integer? eid) (not (neg? eid)))]}
|
||||||
|
|
||||||
|
(assoc-in report [:tempids id-literal] eid))
|
||||||
|
|
||||||
;; (def data-readers {'db/id id-literal})
|
;; (def data-readers {'db/id id-literal})
|
||||||
|
|
||||||
|
@ -235,7 +254,7 @@
|
||||||
(go-pair
|
(go-pair
|
||||||
(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 [idents (into (<? (<idents sqlite-connection)) {:db/txInstant 100 :db/ident 101 :x 102 :y 103 :name 104 :aka 105 :test/kw 106})] ;; TODO: pre-populate idents and SQLite tables?
|
(let [idents (into (<? (<idents sqlite-connection)) {:db/txInstant 100 :db/ident 101 :x 102 :y 103 :name 104 :aka 105 :test/kw 106 :age 107 :email 108 :spouse 109})] ;; TODO: pre-populate idents and SQLite tables?
|
||||||
(map->DB
|
(map->DB
|
||||||
{:sqlite-connection sqlite-connection
|
{:sqlite-connection sqlite-connection
|
||||||
:idents idents
|
:idents idents
|
||||||
|
@ -245,11 +264,6 @@
|
||||||
(defn connection-with-db [db]
|
(defn connection-with-db [db]
|
||||||
(map->Connection {:current-db (atom db)}))
|
(map->Connection {:current-db (atom db)}))
|
||||||
|
|
||||||
(defrecord TxReport [db-before db-after entities tx-data tempids])
|
|
||||||
|
|
||||||
(defn- report? [x]
|
|
||||||
(and (instance? TxReport x)))
|
|
||||||
|
|
||||||
;; ;; TODO: persist max-tx and max-eid in SQLite.
|
;; ;; TODO: persist max-tx and max-eid in SQLite.
|
||||||
|
|
||||||
(defn maybe-datom->entity [entity]
|
(defn maybe-datom->entity [entity]
|
||||||
|
@ -265,21 +279,28 @@
|
||||||
true
|
true
|
||||||
entity))
|
entity))
|
||||||
|
|
||||||
(defn maybe-explode [schema entity] ;; TODO db? schema?
|
(defn explode-entities [schema report]
|
||||||
(cond
|
(let [initial-es (:entities report)
|
||||||
(map? entity)
|
initial-report (assoc report :entities [])]
|
||||||
;; TODO: reverse refs, lists, nested maps
|
(loop [report initial-report
|
||||||
(let [eid (or (:db/id entity)
|
es initial-es]
|
||||||
(id-literal :db.part/temp))] ;; Must upsert if no ID given. TODO: check if this fails in Datomic/DS.
|
(let [[entity & entities] es]
|
||||||
(for [[a v] (dissoc entity :db/id)]
|
(cond
|
||||||
[:db/add eid a v]))
|
(nil? entity)
|
||||||
|
report
|
||||||
|
|
||||||
;; (raise "Map entities are not yet supported, got " entity
|
(map? entity)
|
||||||
;; {:error :transact/syntax
|
;; TODO: reverse refs, lists, nested maps
|
||||||
;; :op entity })
|
(if-let [eid (:db/id entity)]
|
||||||
|
(let [exploded (for [[a v] (dissoc entity :db/id)]
|
||||||
|
[:db/add eid a v])]
|
||||||
|
(recur report (concat exploded entities)))
|
||||||
|
(raise "Map entity missing :db/id, got " entity
|
||||||
|
{:error :transact/entity-missing-db-id
|
||||||
|
:op entity }))
|
||||||
|
|
||||||
true
|
true
|
||||||
[entity]))
|
(recur (util/conj-in report [:entities] entity) entities))))))
|
||||||
|
|
||||||
(defn maybe-ident->entid [db [op & entity :as orig]]
|
(defn maybe-ident->entid [db [op & entity :as orig]]
|
||||||
;; TODO: use something faster than `into` here.
|
;; TODO: use something faster than `into` here.
|
||||||
|
@ -302,32 +323,30 @@
|
||||||
(defn preprocess [db report]
|
(defn preprocess [db report]
|
||||||
{:pre [(db? db) (report? report)]}
|
{:pre [(db? db) (report? report)]}
|
||||||
|
|
||||||
(let [initial-es (conj (or (:entities report) []) (tx-entity db))]
|
(let [initial-es (or (:entities report) [])]
|
||||||
(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}))
|
||||||
|
|
||||||
(->>
|
;; TODO: find an approach that generates less garbage.
|
||||||
(->
|
(->
|
||||||
(comp
|
report
|
||||||
;; Track the provenance of each assertion for error reporting.
|
|
||||||
(map #(with-meta % {:source %}))
|
|
||||||
|
|
||||||
;; Normalize Datoms into :db/add or :db/retract vectors.
|
(update :entities conj (tx-entity db))
|
||||||
(map maybe-datom->entity)
|
|
||||||
|
|
||||||
;; Explode map shorthand, such as {:db/id e :attr value :_reverse ref},
|
;; Normalize Datoms into :db/add or :db/retract vectors.
|
||||||
;; to a list of vectors, like
|
(update :entities (partial map maybe-datom->entity))
|
||||||
;; [[:db/add e :attr value] [:db/add ref :reverse e]].
|
|
||||||
(mapcat (partial maybe-explode (schema db)))
|
|
||||||
|
|
||||||
;; Replace idents with entids where possible.
|
;; Explode map shorthand, such as {:db/id e :attr value :_reverse ref},
|
||||||
(map (partial maybe-ident->entid db))
|
;; to a list of vectors, like
|
||||||
|
;; [[:db/add e :attr value] [:db/add ref :reverse e]].
|
||||||
|
(->> (explode-entities (schema db)))
|
||||||
|
|
||||||
;; Add tx if not given.
|
;; Replace idents with entids where possible.
|
||||||
(map (partial maybe-add-current-tx (current-tx db))))
|
(update :entities (partial map (partial maybe-ident->entid db)))
|
||||||
(transduce conj [] initial-es))
|
|
||||||
(assoc-in report [:entities]))))
|
;; Add tx if not given.
|
||||||
|
(update :entities (partial map (partial maybe-add-current-tx (current-tx db)))))))
|
||||||
|
|
||||||
(defn- lookup-ref? [x]
|
(defn- lookup-ref? [x]
|
||||||
(and (sequential? x)
|
(and (sequential? x)
|
||||||
|
@ -376,16 +395,6 @@
|
||||||
field)))))
|
field)))))
|
||||||
(assoc-in report [:entities])))) ;; TODO: meta.
|
(assoc-in report [:entities])))) ;; TODO: meta.
|
||||||
|
|
||||||
(defonce -eid (atom (- 0x200 1)))
|
|
||||||
|
|
||||||
;; TODO: better here.
|
|
||||||
(defn- next-eid [db]
|
|
||||||
(swap! -eid inc))
|
|
||||||
|
|
||||||
(defn- allocate-eid
|
|
||||||
[report id-literal eid]
|
|
||||||
(assoc-in report [:tempids id-literal] eid))
|
|
||||||
|
|
||||||
(declare <resolve-id-literals)
|
(declare <resolve-id-literals)
|
||||||
|
|
||||||
(defn <retry-with-tempid [db report es tempid upserted-eid]
|
(defn <retry-with-tempid [db report es tempid upserted-eid]
|
||||||
|
@ -437,17 +446,10 @@
|
||||||
initial-entities (sort-by keyfn (:entities report))]
|
initial-entities (sort-by keyfn (:entities report))]
|
||||||
(loop [report initial-report
|
(loop [report initial-report
|
||||||
es initial-entities]
|
es initial-entities]
|
||||||
(if (report? initial-report)
|
|
||||||
(update report :tempids #(into {} (filter (comp not temp-literal? first) %)))
|
|
||||||
(raise "fail" {:initial-report report}))
|
|
||||||
|
|
||||||
(let [[[op e a v tx :as entity] & entities] es]
|
(let [[[op e a v tx :as entity] & entities] es]
|
||||||
(cond
|
(cond
|
||||||
(nil? entity)
|
(nil? entity)
|
||||||
;; We can add :db.part/temp id-literals; remove them.
|
report
|
||||||
(if (report? report)
|
|
||||||
(update report :tempids #(into {} (filter (comp not temp-literal? first) %)))
|
|
||||||
(raise "fail" {:report report}))
|
|
||||||
|
|
||||||
(and (not= op :db/add)
|
(and (not= op :db/add)
|
||||||
(not (empty? (filter id-literal? [e a v tx]))))
|
(not (empty? (filter id-literal? [e a v tx]))))
|
||||||
|
@ -457,9 +459,9 @@
|
||||||
|
|
||||||
;; Upsert!
|
;; Upsert!
|
||||||
(and (id-literal? e)
|
(and (id-literal? e)
|
||||||
(ds/unique-identity? (schema db) a) ;; TODO: schema.
|
(ds/unique-identity? (schema db) a)
|
||||||
(not-any? id-literal? [a v tx]))
|
(not-any? id-literal? [a v tx]))
|
||||||
(let [upserted-eid (:e (first (<? (<avet db [a v])))) ;; TODO: define this interface.
|
(let [upserted-eid (:e (first (<? (<avet 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.
|
||||||
|
@ -493,21 +495,73 @@
|
||||||
(defn- transact-report [report datom]
|
(defn- transact-report [report datom]
|
||||||
(update-in report [:tx-data] conj datom))
|
(update-in report [:tx-data] conj datom))
|
||||||
|
|
||||||
(defn- ensure-schema-constraints
|
(defn- <ensure-schema-constraints
|
||||||
"Verify that all entities obey the schema constraints."
|
"Throw unless all entities in :entities obey the schema constraints."
|
||||||
|
|
||||||
[db report]
|
[db report]
|
||||||
{:pre [(db? db) (report? report)]}
|
{:pre [(db? db) (report? report)]}
|
||||||
|
|
||||||
;; TODO: :db/unique :db.unique/value.
|
|
||||||
;; TODO: consider accumulating errors to show more meaningful error reports.
|
;; TODO: consider accumulating errors to show more meaningful error reports.
|
||||||
;; TODO: constrain entities; constrain attributes.
|
;; TODO: constrain entities; constrain attributes.
|
||||||
|
|
||||||
(doseq [[op e a v tx] (:entities report)]
|
(go-pair
|
||||||
(ds/ensure-valid-value (schema db) a v))
|
(doseq [[op e a v tx] (:entities report)]
|
||||||
report)
|
(ds/ensure-valid-value (schema db) a v))
|
||||||
|
report))
|
||||||
|
|
||||||
(defn <postprocess [db report]
|
(defn- <ensure-unique-constraints
|
||||||
|
"Throw unless all datoms in :tx-data obey the uniqueness constraints."
|
||||||
|
|
||||||
|
[db report]
|
||||||
|
{:pre [(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 [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 db) a)
|
||||||
|
(when-let [found (first (<? (<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 db) 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 db) 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) (report? report)]}
|
{:pre [(db? db) (report? report)]}
|
||||||
(go-pair
|
(go-pair
|
||||||
(let [initial-report report]
|
(let [initial-report report]
|
||||||
|
@ -546,19 +600,24 @@
|
||||||
{:pre [(db? db) (report? report)]}
|
{:pre [(db? db) (report? report)]}
|
||||||
|
|
||||||
(go-pair
|
(go-pair
|
||||||
(->> report
|
(->>
|
||||||
(preprocess db)
|
report
|
||||||
|
(preprocess db)
|
||||||
|
|
||||||
(<resolve-lookup-refs db)
|
(<resolve-lookup-refs db)
|
||||||
(<?)
|
(<?)
|
||||||
|
|
||||||
(<resolve-id-literals db)
|
(<resolve-id-literals db)
|
||||||
(<?)
|
(<?)
|
||||||
|
|
||||||
(ensure-schema-constraints db)
|
(<ensure-schema-constraints db)
|
||||||
|
(<?)
|
||||||
|
|
||||||
(<postprocess db)
|
(<entities->tx-data db)
|
||||||
(<?))))
|
(<?)
|
||||||
|
|
||||||
|
(<ensure-unique-constraints db)
|
||||||
|
(<?))))
|
||||||
|
|
||||||
;; Normalize as [op int|id-literal int|id-literal value|id-literal tx|id-literal]. ;; TODO: mention lookup-refs.
|
;; Normalize as [op int|id-literal int|id-literal value|id-literal tx|id-literal]. ;; TODO: mention lookup-refs.
|
||||||
|
|
||||||
|
@ -573,9 +632,8 @@
|
||||||
"Transactions may add idents, install new partitions, and install new schema attributes.
|
"Transactions may add idents, install new partitions, and install new schema attributes.
|
||||||
Handle :db/ident assertions here."
|
Handle :db/ident assertions here."
|
||||||
[db tx-data]
|
[db tx-data]
|
||||||
{:pre [(db? db)
|
{:pre [(db? db)]}
|
||||||
;; (report? report)
|
|
||||||
]}
|
|
||||||
;; TODO: use q to filter the report!
|
;; TODO: use q to filter the report!
|
||||||
(let [original-db db
|
(let [original-db db
|
||||||
original-ident-assertions (filter (partial is-ident? db) tx-data)]
|
original-ident-assertions (filter (partial is-ident? db) tx-data)]
|
||||||
|
|
|
@ -32,6 +32,10 @@
|
||||||
:cljs [^boolean indexing?]) [schema attr]
|
:cljs [^boolean indexing?]) [schema attr]
|
||||||
(is-attr? schema attr :db/index))
|
(is-attr? schema attr :db/index))
|
||||||
|
|
||||||
|
(defn #?@(:clj [^Boolean unique?]
|
||||||
|
:cljs [^boolean unique?]) [schema attr]
|
||||||
|
(is-attr? schema attr :db/unique))
|
||||||
|
|
||||||
(defn #?@(:clj [^Boolean unique-identity?]
|
(defn #?@(:clj [^Boolean unique-identity?]
|
||||||
:cljs [^boolean unique-identity?]) [schema attr]
|
:cljs [^boolean unique-identity?]) [schema attr]
|
||||||
(is-attr? schema attr :db.unique/identity))
|
(is-attr? schema attr :db.unique/identity))
|
||||||
|
|
|
@ -18,11 +18,15 @@
|
||||||
(def current-version 1)
|
(def current-version 1)
|
||||||
|
|
||||||
(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, index_avet TINYINT NOT NULL DEFAULT 0, index_vaet TINYINT NOT NULL DEFAULT 0)"
|
["CREATE TABLE datoms (e INTEGER NOT NULL, a SMALLINT NOT NULL, v BLOB NOT NULL, tx INTEGER NOT NULL,
|
||||||
|
index_avet TINYINT NOT NULL DEFAULT 0, index_vaet TINYINT NOT NULL DEFAULT 0,
|
||||||
|
unique_value TINYINT NOT NULL DEFAULT 0, unique_identity TINYINT NOT NULL DEFAULT 0)"
|
||||||
"CREATE INDEX eavt ON datoms (e, a)" ;; No v -- that's an opt-in index.
|
"CREATE INDEX eavt ON datoms (e, a)" ;; No v -- that's an opt-in index.
|
||||||
"CREATE INDEX aevt ON datoms (a, e)" ;; No v -- that's an opt-in index.
|
"CREATE INDEX aevt ON datoms (a, e)" ;; No v -- that's an opt-in index.
|
||||||
"CREATE INDEX avet ON datoms (a, v, e) WHERE index_avet = 1" ;; Opt-in index: only if a has :db/index true.
|
"CREATE UNIQUE INDEX avet ON datoms (a, v, e) WHERE index_avet = 1" ;; Opt-in index: only if a has :db/index true.
|
||||||
"CREATE INDEX vaet ON datoms (v, a, e) WHERE index_vaet = 1" ;; Opt-in index: only if a has :db/valueType :db.type/ref
|
"CREATE UNIQUE INDEX vaet ON datoms (v, a, e) WHERE index_vaet = 1" ;; Opt-in index: only if a has :db/valueType :db.type/ref
|
||||||
|
"CREATE UNIQUE INDEX unique_value ON datoms (v) WHERE unique_value = 1" ;; TODO.
|
||||||
|
"CREATE UNIQUE INDEX unique_identity ON datoms (a, v) WHERE unique_identity = 1" ;; TODO.
|
||||||
"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)"
|
||||||
"CREATE INDEX tx ON transactions (tx)"
|
"CREATE INDEX tx ON transactions (tx)"
|
||||||
"CREATE TABLE attributes (name TEXT NOT NULL PRIMARY KEY, a INTEGER UNIQUE NOT NULL)"])
|
"CREATE TABLE attributes (name TEXT NOT NULL PRIMARY KEY, a INTEGER UNIQUE NOT NULL)"])
|
||||||
|
|
|
@ -45,6 +45,15 @@
|
||||||
(filter #(not (= :db/txInstant (second %))))
|
(filter #(not (= :db/txInstant (second %))))
|
||||||
(set)))))
|
(set)))))
|
||||||
|
|
||||||
|
(defn- <shallow-entity [db eid]
|
||||||
|
(let [entids (zipmap (vals (dm/idents db)) (keys (dm/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 [db]
|
(defn- <transactions [db]
|
||||||
(let [entids (zipmap (vals (dm/idents db)) (keys (dm/idents db)))]
|
(let [entids (zipmap (vals (dm/idents db)) (keys (dm/idents db)))]
|
||||||
(go-pair
|
(go-pair
|
||||||
|
@ -57,14 +66,20 @@
|
||||||
(get-in report [:db-after :current-tx]))
|
(get-in report [:db-after :current-tx]))
|
||||||
|
|
||||||
(def test-schema
|
(def test-schema
|
||||||
{:x {:db/unique :db.unique/identity
|
{:x {:db/unique :db.unique/identity
|
||||||
:db/valueType :db.type/integer}
|
:db/valueType :db.type/integer}
|
||||||
:y {:db/cardinality :db.cardinality/many
|
:y {:db/cardinality :db.cardinality/many
|
||||||
:db/valueType :db.type/integer}
|
:db/valueType :db.type/integer}
|
||||||
:name {:db/unique :db.unique/identity
|
:name {:db/unique :db.unique/identity
|
||||||
:db/valueType :db.type/string}
|
:db/valueType :db.type/string}
|
||||||
:aka {:db/cardinality :db.cardinality/many
|
:aka {:db/cardinality :db.cardinality/many
|
||||||
:db/valueType :db.type/string}})
|
:db/valueType :db.type/string}
|
||||||
|
:age {:db/valueType :db.type/integer}
|
||||||
|
:email {:db/unique :db.unique/identity
|
||||||
|
:db/valueType :db.type/string}
|
||||||
|
:spouse {:db/unique :db.unique/value
|
||||||
|
:db/valueType :db.type/string}
|
||||||
|
})
|
||||||
|
|
||||||
(deftest-async test-add-one
|
(deftest-async test-add-one
|
||||||
(with-tempfile [t (tempfile)]
|
(with-tempfile [t (tempfile)]
|
||||||
|
@ -159,6 +174,28 @@
|
||||||
(finally
|
(finally
|
||||||
(<? (dm/close-db db)))))))
|
(<? (dm/close-db db)))))))
|
||||||
|
|
||||||
|
(deftest-async test-unique
|
||||||
|
(with-tempfile [t (tempfile)]
|
||||||
|
(let [c (<? (s/<sqlite-connection t))
|
||||||
|
db (<? (dm/<db-with-sqlite-connection c test-schema))
|
||||||
|
conn (dm/connection-with-db db)
|
||||||
|
now -1]
|
||||||
|
(try
|
||||||
|
(testing "Multiple :db/unique values in tx-data violate unique constraint, no tempid"
|
||||||
|
(is (thrown-with-msg?
|
||||||
|
ExceptionInfo #"unique constraint"
|
||||||
|
(<? (dm/<transact! conn [[:db/add 1 :x 0]
|
||||||
|
[:db/add 2 :x 0]] now)))))
|
||||||
|
|
||||||
|
(testing "Multiple :db/unique values in tx-data violate unique constraint, tempid"
|
||||||
|
(is (thrown-with-msg?
|
||||||
|
ExceptionInfo #"unique constraint"
|
||||||
|
(<? (dm/<transact! conn [[:db/add (dm/id-literal :db.part/user -1) :spouse "Dana"]
|
||||||
|
[:db/add (dm/id-literal :db.part/user -2) :spouse "Dana"]] now)))))
|
||||||
|
|
||||||
|
(finally
|
||||||
|
(<? (dm/close-db db)))))))
|
||||||
|
|
||||||
(deftest-async test-add-ident
|
(deftest-async test-add-ident
|
||||||
(with-tempfile [t (tempfile)]
|
(with-tempfile [t (tempfile)]
|
||||||
(let [c (<? (s/<sqlite-connection t))
|
(let [c (<? (s/<sqlite-connection t))
|
||||||
|
@ -219,3 +256,148 @@
|
||||||
|
|
||||||
(finally
|
(finally
|
||||||
(<? (dm/close-db db)))))))
|
(<? (dm/close-db db)))))))
|
||||||
|
|
||||||
|
(deftest-async test-vector-upsert
|
||||||
|
(with-tempfile [t (tempfile)]
|
||||||
|
(let [c (<? (s/<sqlite-connection t))
|
||||||
|
db (<? (dm/<db-with-sqlite-connection c test-schema))
|
||||||
|
conn (dm/connection-with-db db)
|
||||||
|
now 0xdeadbeef]
|
||||||
|
(try
|
||||||
|
;; Not having DB-as-value really hurts us here.
|
||||||
|
(let [<with-base-and (fn [entities]
|
||||||
|
(go-pair
|
||||||
|
(<? (s/execute! (:sqlite-connection (dm/db conn)) ["DELETE FROM datoms"]))
|
||||||
|
(<? (s/execute! (:sqlite-connection (dm/db conn)) ["DELETE FROM transactions"]))
|
||||||
|
;; TODO: don't rely on explicit IDs.
|
||||||
|
(<? (dm/<transact! conn [{:db/id 1 :name "Ivan" :email "@1"}
|
||||||
|
{:db/id 2 :name "Petr" :email "@2"}] now))
|
||||||
|
(<? (dm/<transact! conn entities now))))
|
||||||
|
tempids (fn [tx] (into {} (map (juxt (comp :idx first) second) (:tempids tx))))]
|
||||||
|
|
||||||
|
(testing "upsert with tempid"
|
||||||
|
(let [tx (<? (<with-base-and [[:db/add (dm/id-literal :db.part/user -1) :name "Ivan"]
|
||||||
|
[:db/add (dm/id-literal :db.part/user -1) :age 12]]))]
|
||||||
|
(is (= (<? (<shallow-entity (dm/db conn) 1))
|
||||||
|
{:name "Ivan" :age 12 :email "@1"}))
|
||||||
|
(is (= (tempids tx)
|
||||||
|
{-1 1}))))
|
||||||
|
|
||||||
|
(testing "upsert with tempid, order does not matter"
|
||||||
|
(let [tx (<? (<with-base-and [[:db/add (dm/id-literal :db.part/user -1) :age 12]
|
||||||
|
[:db/add (dm/id-literal :db.part/user -1) :name "Ivan"]]))]
|
||||||
|
(is (= (<? (<shallow-entity (dm/db conn) 1))
|
||||||
|
{:name "Ivan" :age 12 :email "@1"}))
|
||||||
|
(is (= (tempids tx)
|
||||||
|
{-1 1}))))
|
||||||
|
|
||||||
|
(testing "Conflicting upserts fail"
|
||||||
|
(is (thrown-with-msg? Throwable #"Conflicting upsert: #datomish.db.TempId\{:part :db.part/user, :idx -\d+\} resolves both to \d+ and \d+"
|
||||||
|
(<? (dm/<with db [[:db/add (dm/id-literal :db.part/user -1) :name "Ivan"]
|
||||||
|
[:db/add (dm/id-literal :db.part/user -1) :age 35]
|
||||||
|
[:db/add (dm/id-literal :db.part/user -1) :name "Petr"]
|
||||||
|
[:db/add (dm/id-literal :db.part/user -1) :age 36]]))))))
|
||||||
|
(finally
|
||||||
|
(<? (dm/close-db db)))))))
|
||||||
|
|
||||||
|
(deftest-async test-map-upsert
|
||||||
|
(with-tempfile [t (tempfile)]
|
||||||
|
(let [c (<? (s/<sqlite-connection t))
|
||||||
|
db (<? (dm/<db-with-sqlite-connection c test-schema))
|
||||||
|
conn (dm/connection-with-db db)
|
||||||
|
now 0xdeadbeef]
|
||||||
|
(try
|
||||||
|
;; Not having DB-as-value really hurts us here.
|
||||||
|
(let [<with-base-and (fn [entities]
|
||||||
|
(go-pair
|
||||||
|
(<? (s/execute! (:sqlite-connection (dm/db conn)) ["DELETE FROM datoms"]))
|
||||||
|
(<? (s/execute! (:sqlite-connection (dm/db conn)) ["DELETE FROM transactions"]))
|
||||||
|
;; TODO: don't rely on explicit IDs.
|
||||||
|
(<? (dm/<transact! conn [{:db/id 1 :name "Ivan" :email "@1"}
|
||||||
|
{:db/id 2 :name "Petr" :email "@2"}] now))
|
||||||
|
(<? (dm/<transact! conn entities now))))
|
||||||
|
tempids (fn [tx] (into {} (map (juxt (comp :idx first) second) (:tempids tx))))]
|
||||||
|
|
||||||
|
(testing "upsert with tempid"
|
||||||
|
(let [tx (<? (<with-base-and [{:db/id (dm/id-literal :db.part/user -1) :name "Ivan" :age 35}]))]
|
||||||
|
(is (= (<? (<shallow-entity (dm/db conn) 1))
|
||||||
|
{:name "Ivan" :email "@1" :age 35}))
|
||||||
|
(is (= (tempids tx)
|
||||||
|
{-1 1}))))
|
||||||
|
|
||||||
|
(testing "upsert by 2 attrs with tempid"
|
||||||
|
(let [tx (<? (<with-base-and [{:db/id (dm/id-literal :db.part/user -1) :name "Ivan" :email "@1" :age 35}]))]
|
||||||
|
(is (= (<? (<shallow-entity (dm/db conn) 1))
|
||||||
|
{:name "Ivan" :email "@1" :age 35}))
|
||||||
|
(is (= (tempids tx)
|
||||||
|
{-1 1}))))
|
||||||
|
|
||||||
|
(testing "upsert to two entities, resolve to same tempid, fails due to overlapping writes"
|
||||||
|
(is (thrown-with-msg? Throwable #"cardinality constraint"
|
||||||
|
(<? (<with-base-and [{:db/id (dm/id-literal :db.part/user -1) :name "Ivan" :age 35}
|
||||||
|
{:db/id (dm/id-literal :db.part/user -1) :name "Ivan" :age 36}])))))
|
||||||
|
|
||||||
|
(testing "upsert to two entities, two tempids, fails due to overlapping writes"
|
||||||
|
(is (thrown-with-msg? Throwable #"cardinality constraint"
|
||||||
|
(<? (<with-base-and [{:db/id (dm/id-literal :db.part/user -1) :name "Ivan" :age 35}
|
||||||
|
{:db/id (dm/id-literal :db.part/user -2) :name "Ivan" :age 36}])))))
|
||||||
|
|
||||||
|
(testing "upsert with existing id"
|
||||||
|
(let [tx (<? (<with-base-and [{:db/id 1 :name "Ivan" :age 35}]))]
|
||||||
|
(is (= (<? (<shallow-entity (dm/db conn) 1))
|
||||||
|
{:name "Ivan" :email "@1" :age 35}))
|
||||||
|
(is (= (tempids tx)
|
||||||
|
{}))))
|
||||||
|
|
||||||
|
(testing "upsert by 2 attrs with existing id"
|
||||||
|
(let [tx (<? (<with-base-and [{:db/id 1 :name "Ivan" :email "@1" :age 35}]))]
|
||||||
|
(is (= (<? (<shallow-entity (dm/db conn) 1))
|
||||||
|
{:name "Ivan" :email "@1" :age 35}))
|
||||||
|
(is (= (tempids tx)
|
||||||
|
{})))))
|
||||||
|
|
||||||
|
(finally
|
||||||
|
(<? (dm/close-db db)))))))
|
||||||
|
|
||||||
|
(deftest-async test-map-upsert-conflicts
|
||||||
|
(with-tempfile [t (tempfile)]
|
||||||
|
(let [c (<? (s/<sqlite-connection t))
|
||||||
|
db (<? (dm/<db-with-sqlite-connection c test-schema))
|
||||||
|
conn (dm/connection-with-db db)
|
||||||
|
now 0xdeadbeef]
|
||||||
|
(try
|
||||||
|
;; Not having DB-as-value really hurts us here.
|
||||||
|
(let [<with-base-and (fn [entities]
|
||||||
|
(go-pair
|
||||||
|
(<? (s/execute! (:sqlite-connection (dm/db conn)) ["DELETE FROM datoms"]))
|
||||||
|
(<? (s/execute! (:sqlite-connection (dm/db conn)) ["DELETE FROM transactions"]))
|
||||||
|
;; TODO: don't rely on explicit IDs.
|
||||||
|
(<? (dm/<transact! conn [{:db/id 1 :name "Ivan" :email "@1"}
|
||||||
|
{:db/id 2 :name "Petr" :email "@2"}] now))
|
||||||
|
(<? (dm/<transact! conn entities now))))
|
||||||
|
tempids (fn [tx] (into {} (map (juxt (comp :idx first) second) (:tempids tx))))]
|
||||||
|
|
||||||
|
;; TODO: improve error message to refer to upsert inputs.
|
||||||
|
(testing "upsert conficts with existing id"
|
||||||
|
(is (thrown-with-msg? Throwable #"unique constraint"
|
||||||
|
(<? (<with-base-and [{:db/id 2 :name "Ivan" :age 36}])))))
|
||||||
|
|
||||||
|
;; TODO: improve error message to refer to upsert inputs.
|
||||||
|
(testing "upsert conficts with non-existing id"
|
||||||
|
(is (thrown-with-msg? Throwable #"unique constraint"
|
||||||
|
(<? (<with-base-and [{:db/id 3 :name "Ivan" :age 36}])))))
|
||||||
|
|
||||||
|
(testing "upsert by non-existing value resolves as update"
|
||||||
|
(let [tx (<? (<with-base-and [{:db/id (dm/id-literal :db.part/user -1) :name "Ivan" :email "@3" :age 35}]))]
|
||||||
|
(is (= (<? (<shallow-entity (dm/db conn) 1))
|
||||||
|
{:name "Ivan" :email "@3" :age 35}))
|
||||||
|
(is (= (tempids tx)
|
||||||
|
{-1 1}))))
|
||||||
|
|
||||||
|
;; TODO: improve error message to refer to upsert inputs.
|
||||||
|
(testing "upsert by 2 conflicting fields"
|
||||||
|
(is (thrown-with-msg? Throwable #"Conflicting upsert: #datomish.db.TempId\{:part :db.part/user, :idx -\d+\} resolves both to \d+ and \d+"
|
||||||
|
(<? (<with-base-and [{:db/id (dm/id-literal :db.part/user -1) :name "Ivan" :email "@2" :age 35}]))))))
|
||||||
|
|
||||||
|
(finally
|
||||||
|
(<? (dm/close-db db)))))))
|
||||||
|
|
Loading…
Reference in a new issue