Accept new schema fragments via :db.part/db :db.install/attribute.
This commit is contained in:
Nick Alexander
parent
9497d69b44
commit
6a8739bd2f
|
|
@ -16,6 +16,7 @@
|
|||
[datomish.datom :as dd :refer [datom datom? #?@(:cljs [Datom])]]
|
||||
[datomish.util :as util #?(:cljs :refer-macros :clj :refer) [raise raise-str cond-let]]
|
||||
[datomish.schema :as ds]
|
||||
[datomish.schema-changes]
|
||||
[datomish.sqlite :as s]
|
||||
[datomish.sqlite-schema :as sqlite-schema]
|
||||
#?@(:clj [[datomish.pair-chan :refer [go-pair <?]]
|
||||
|
|
@ -234,8 +235,36 @@
|
|||
(def tx0 0x2000000)
|
||||
|
||||
(def default-schema
|
||||
{:db/txInstant {:db/valueType :db.type/integer}
|
||||
:db/ident {:db/valueType :db.type/keyword}
|
||||
{
|
||||
:db.install/partition {:db/valueType :db.type/ref
|
||||
:db/cardinality :db.cardinality/many}
|
||||
:db.install/valueType {:db/valueType :db.type/ref
|
||||
:db/cardinality :db.cardinality/many}
|
||||
:db.install/attribute {:db/valueType :db.type/ref
|
||||
:db/cardinality :db.cardinality/many}
|
||||
;; TODO: support user-specified functions in the future.
|
||||
;; :db.install/function {:db/valueType :db.type/ref
|
||||
;; :db/cardinality :db.cardinality/many}
|
||||
:db/txInstant {:db/valueType :db.type/integer
|
||||
:db/cardinality :db.cardinality/one
|
||||
:db/index true}
|
||||
:db/ident {:db/valueType :db.type/keyword
|
||||
:db/cardinality :db.cardinality/one
|
||||
:db/unique :db.unique/identity}
|
||||
:db/valueType {:db/valueType :db.type/ref
|
||||
:db/cardinality :db.cardinality/one}
|
||||
:db/cardinality {:db/valueType :db.type/ref
|
||||
:db/cardinality :db.cardinality/one}
|
||||
:db/unique {:db/valueType :db.type/ref
|
||||
:db/cardinality :db.cardinality/one}
|
||||
:db/isComponent {:db/valueType :db.type/boolean
|
||||
:db/cardinality :db.cardinality/one}
|
||||
:db/index {:db/valueType :db.type/boolean
|
||||
:db/cardinality :db.cardinality/one}
|
||||
:db/fulltext {:db/valueType :db.type/boolean
|
||||
:db/cardinality :db.cardinality/one}
|
||||
:db/noHistory {:db/valueType :db.type/boolean
|
||||
:db/cardinality :db.cardinality/one}
|
||||
})
|
||||
|
||||
(defn <idents [sqlite-connection]
|
||||
|
|
@ -254,11 +283,15 @@
|
|||
(go-pair
|
||||
(when-not (= sqlite-schema/current-version (<? (sqlite-schema/<ensure-current-version sqlite-connection)))
|
||||
(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 :age 107 :email 108 :spouse 109})] ;; TODO: pre-populate idents and SQLite tables?
|
||||
(let [idents (clojure.set/union [:db/txInstant :db/ident :db.part/db :db.install/attribute :db.type/string :db.type/integer :db.type/ref :db/id :db.cardinality/one :db.cardinality/many :db/cardinality :db/valueType :x :y :name :aka :test/kw :age :email :spouse] (keys default-schema))
|
||||
idents (into {} (map-indexed #(vector %2 %1) idents))
|
||||
idents (into (<? (<idents sqlite-connection)) idents) ;; TODO: pre-populate idents and SQLite tables?
|
||||
symbolic-schema (merge schema default-schema)]
|
||||
(map->DB
|
||||
{:sqlite-connection sqlite-connection
|
||||
:idents idents
|
||||
:schema (ds/schema (into {} (map (fn [[k v]] [(k idents) v]) (merge schema default-schema))))
|
||||
:symbolic-schema symbolic-schema
|
||||
:schema (ds/schema (into {} (map (fn [[k v]] [(k idents) v]) symbolic-schema)))
|
||||
:current-tx tx0})))))
|
||||
|
||||
(defn connection-with-db [db]
|
||||
|
|
@ -628,14 +661,15 @@
|
|||
(defn- is-ident? [db [_ a & _]]
|
||||
(= a (get-in db [:idents :db/ident])))
|
||||
|
||||
(defn process-db-idents
|
||||
(defn process-db-ident-assertions
|
||||
"Transactions may add idents, install new partitions, and install new schema attributes.
|
||||
Handle :db/ident assertions here."
|
||||
[db tx-data]
|
||||
{:pre [(db? db)]}
|
||||
[db report]
|
||||
{:pre [(db? db) (report? report)]}
|
||||
|
||||
;; TODO: use q to filter the report!
|
||||
(let [original-db db
|
||||
tx-data (:tx-data report)
|
||||
original-ident-assertions (filter (partial is-ident? db) tx-data)]
|
||||
(loop [db original-db
|
||||
ident-assertions original-ident-assertions]
|
||||
|
|
@ -663,6 +697,37 @@
|
|||
{:error :schema/idents
|
||||
:op ia }))))))))
|
||||
|
||||
(defn- symbolicate-datom [db [e a v tx added]]
|
||||
(let [entids (zipmap (vals (idents db)) (keys (idents db)))
|
||||
symbolicate (fn [x]
|
||||
(get entids x x))]
|
||||
(datom
|
||||
(symbolicate e)
|
||||
(symbolicate a)
|
||||
(symbolicate v)
|
||||
(symbolicate tx)
|
||||
added)))
|
||||
|
||||
(defn process-db-install-assertions
|
||||
"Transactions may add idents, install new partitions, and install new schema attributes.
|
||||
Handle [:db.part/db :db.install/attribute] assertions here."
|
||||
[db report]
|
||||
{:pre [(db? db) (report? report)]}
|
||||
|
||||
;; TODO: be more efficient; symbolicating each datom is expensive!
|
||||
(let [datoms (map (partial symbolicate-datom db) (:tx-data report))
|
||||
schema-fragment (datomish.schema-changes/datoms->schema-fragment datoms)
|
||||
fail (fn [old new] (raise "Altering schema elements is not yet supported, got " new " altering existing schema element " old
|
||||
{:error :schema/alter-schema :old old :new new}))]
|
||||
|
||||
(if (empty? schema-fragment)
|
||||
db
|
||||
(let [symbolic-schema (merge-with fail (:symbolic-schema db) schema-fragment)
|
||||
schema (ds/schema (into {} (map (fn [[k v]] [(k (idents db)) v]) symbolic-schema)))]
|
||||
(assoc db
|
||||
:symbolic-schema symbolic-schema
|
||||
:schema schema)))))
|
||||
|
||||
(defn <with [db tx-data]
|
||||
(go-pair
|
||||
(let [report (<? (<transact-tx-data db 0xdeadbeef ;; TODO
|
||||
|
|
@ -682,7 +747,9 @@
|
|||
(<advance-tx)
|
||||
(<?)
|
||||
|
||||
(process-db-idents (:tx-data report)))]
|
||||
(process-db-ident-assertions report)
|
||||
|
||||
(process-db-install-assertions report))]
|
||||
(-> report
|
||||
(assoc-in [:db-after] db-after)))))
|
||||
|
||||
|
|
|
|||
60
src/datomish/schema_changes.cljc
Normal file
60
src/datomish/schema_changes.cljc
Normal file
|
|
@ -0,0 +1,60 @@
|
|||
;; 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-changes
|
||||
(:require
|
||||
[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
|
||||
"Turn [[:db.part/db :db.install/attribute e] [e :db/ident :attr]] into {:attr {:db/* v}}.
|
||||
|
||||
From http://docs.datomic.com/schema.html, :db/ident, :db/valueType,
|
||||
and :db/cardinality are required. For us, enforce that valueType and
|
||||
cardinality are present at schema validation time.
|
||||
|
||||
This code is not pretty, so here's what it does:
|
||||
|
||||
Input: a sequence of datoms, like [e :keyword-attr v _ added].
|
||||
1. Select [:db.part/db :db.install/attribute ... ].
|
||||
2. Fail if any are not (= added true)
|
||||
3. For each [ :db.part/db :db.install/attribute e ], collect {e {:db/* v}}.
|
||||
4. Map e -> ident; fail if not possible.
|
||||
5. Return the map, with ident keys.
|
||||
|
||||
This would be more pleasant with `q` and pull expressions."
|
||||
|
||||
[datoms]
|
||||
{:pre [(sequential? datoms)]}
|
||||
|
||||
(let [db-install? (fn [datom]
|
||||
(= [:db.part/db :db.install/attribute] ((juxt :e :a) datom)))
|
||||
db-installs (filter db-install? datoms)]
|
||||
(if (empty? db-installs)
|
||||
{}
|
||||
(if-let [retracted (first (filter (comp not :added) db-installs))]
|
||||
(raise "Retracting a :db.install/attribute is not yet supported, got " retracted
|
||||
{:error :schema/db-install :op retracted})
|
||||
(let [by-e (group-by :e datoms)
|
||||
|
||||
;; TODO: pull entity from database, rather than expecting entire attribute to be in single transaction.
|
||||
installed-es (select-keys by-e (map :v db-installs))
|
||||
;; select-keys ignores missing keys. We don't want that.
|
||||
installed-es (merge (into {} (map (juxt :v (constantly {})) db-installs)) installed-es)
|
||||
|
||||
db-*? (fn [datom]
|
||||
(= "db" (namespace (:a datom))))]
|
||||
|
||||
;; Just the :db/* attribute-value pairs.
|
||||
(into {} (for [[e datoms] installed-es]
|
||||
(let [->av (juxt :a :v)
|
||||
;; TODO: transduce!
|
||||
db-avs (into {} (map ->av (filter db-*? datoms)))]
|
||||
;; TODO: get ident from existing datom, to allow [:db.part/db :db.install/attribute existing-id].
|
||||
(if-let [ident (:db/ident db-avs)]
|
||||
[ident db-avs]
|
||||
(raise ":db.install/attribute requires :db/ident, got " db-avs " for " e
|
||||
{:error :schema/db-install :op db-avs}))))))))))
|
||||
|
|
@ -196,35 +196,6 @@
|
|||
(finally
|
||||
(<? (dm/close-db db)))))))
|
||||
|
||||
(deftest-async test-add-ident
|
||||
(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
|
||||
(let [report (<? (dm/<transact! conn [[:db/add (dm/id-literal :db.part/db -1) :db/ident :test/ident]] now))
|
||||
db-after (:db-after report)
|
||||
tx (:current-tx db-after)]
|
||||
(is (= (:test/ident (dm/idents db-after)) (get-in report [:tempids (dm/id-literal :db.part/db -1)]))))
|
||||
|
||||
;; TODO: This should fail, but doesn't, due to stringification of :test/ident.
|
||||
;; (is (thrown-with-msg?
|
||||
;; ExceptionInfo #"Retracting a :db/ident is not yet supported, got "
|
||||
;; (<? (dm/<transact! conn [[:db/retract 44 :db/ident :test/ident]] now))))
|
||||
|
||||
;; ;; Renaming looks like retraction and then assertion.
|
||||
;; (is (thrown-with-msg?
|
||||
;; ExceptionInfo #"Retracting a :db/ident is not yet supported, got"
|
||||
;; (<? (dm/<transact! conn [[:db/add 44 :db/ident :other-name]] now))))
|
||||
|
||||
;; (is (thrown-with-msg?
|
||||
;; ExceptionInfo #"Re-asserting a :db/ident is not yet supported, got"
|
||||
;; (<? (dm/<transact! conn [[:db/add 55 :db/ident :test/ident]] now))))
|
||||
|
||||
(finally
|
||||
(<? (dm/close-db db)))))))
|
||||
|
||||
(deftest-async test-valueType-keyword
|
||||
(with-tempfile [t (tempfile)]
|
||||
(let [c (<? (s/<sqlite-connection t))
|
||||
|
|
@ -401,3 +372,66 @@
|
|||
|
||||
(finally
|
||||
(<? (dm/close-db db)))))))
|
||||
|
||||
(deftest-async test-add-ident
|
||||
(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
|
||||
(let [report (<? (dm/<transact! conn [[:db/add (dm/id-literal :db.part/db -1) :db/ident :test/ident]] now))
|
||||
db-after (:db-after report)
|
||||
tx (:current-tx db-after)]
|
||||
(is (= (:test/ident (dm/idents db-after)) (get-in report [:tempids (dm/id-literal :db.part/db -1)]))))
|
||||
|
||||
;; TODO: This should fail, but doesn't, due to stringification of :test/ident.
|
||||
;; (is (thrown-with-msg?
|
||||
;; ExceptionInfo #"Retracting a :db/ident is not yet supported, got "
|
||||
;; (<? (dm/<transact! conn [[:db/retract 44 :db/ident :test/ident]] now))))
|
||||
|
||||
;; ;; Renaming looks like retraction and then assertion.
|
||||
;; (is (thrown-with-msg?
|
||||
;; ExceptionInfo #"Retracting a :db/ident is not yet supported, got"
|
||||
;; (<? (dm/<transact! conn [[:db/add 44 :db/ident :other-name]] now))))
|
||||
|
||||
;; (is (thrown-with-msg?
|
||||
;; ExceptionInfo #"Re-asserting a :db/ident is not yet supported, got"
|
||||
;; (<? (dm/<transact! conn [[:db/add 55 :db/ident :test/ident]] now))))
|
||||
|
||||
(finally
|
||||
(<? (dm/close-db db)))))))
|
||||
|
||||
(deftest-async test-add-schema
|
||||
(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
|
||||
(let [es [[:db/add :db.part/db :db.install/attribute (dm/id-literal :db.part/db -1)]
|
||||
{:db/id (dm/id-literal :db.part/db -1)
|
||||
:db/ident :test/attr
|
||||
:db/valueType :db.type/string
|
||||
:db/cardinality :db.cardinality/one}]
|
||||
report (<? (dm/<transact! conn es now))
|
||||
db-after (:db-after report)
|
||||
tx (:current-tx db-after)]
|
||||
|
||||
(testing "New ident is allocated"
|
||||
(is (some? (get-in db-after [:idents :test/attr]))))
|
||||
|
||||
(testing "Schema is modified"
|
||||
(is (= (get-in db-after [:symbolic-schema :test/attr])
|
||||
{:db/ident :test/attr,
|
||||
:db/valueType :db.type/string,
|
||||
:db/cardinality :db.cardinality/one})))
|
||||
|
||||
(testing "Schema is used in subsequent transaction"
|
||||
(<? (dm/<transact! conn [{:db/id 1 :test/attr "value 1"}]))
|
||||
(<? (dm/<transact! conn [{:db/id 1 :test/attr "value 2"}]))
|
||||
(is (= (<? (<shallow-entity (dm/db conn) 1))
|
||||
{:test/attr "value 2"}))))
|
||||
|
||||
(finally
|
||||
(<? (dm/close-db db)))))))
|
||||
|
|
|
|||
90
test/datomish/schema_changes_test.cljc
Normal file
90
test/datomish/schema_changes_test.cljc
Normal file
|
|
@ -0,0 +1,90 @@
|
|||
;; 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-changes-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.util :as util #?(:cljs :refer-macros :clj :refer) [raise cond-let]]
|
||||
[datomish.sqlite :as s]
|
||||
|
||||
[datomish.datom :refer [datom]]
|
||||
|
||||
[datomish.schema-changes :refer [datoms->schema-fragment]]
|
||||
|
||||
[datomish.db :as dm]
|
||||
#?@(:clj [[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.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))
|
||||
|
||||
(deftest test-datoms->schema-fragment
|
||||
(let [tx 10101
|
||||
->datom (fn [xs]
|
||||
(apply datom (conj xs tx)))]
|
||||
(are [i o]
|
||||
(= (datoms->schema-fragment (map ->datom i))
|
||||
o)
|
||||
;; Base case.
|
||||
[]
|
||||
{}
|
||||
|
||||
;; No matches.
|
||||
[[0 :not-db/add :not-db/install]]
|
||||
{}
|
||||
|
||||
;; Interesting case.
|
||||
[[:db.part/db :db.install/attribute 1]
|
||||
[:db.part/db :db.install/attribute 2]
|
||||
[1 :db/ident :test/attr1]
|
||||
[1 :db/valueType :db.value/string]
|
||||
[1 :db/cardinalty :db.cardinality/one]
|
||||
[1 :db/unique :db.unique/identity]
|
||||
[2 :db/ident :test/attr2]
|
||||
[2 :db/valueType :db.value/integer]
|
||||
[2 :db/cardinalty :db.cardinality/many]]
|
||||
{:test/attr1
|
||||
{:db/ident :test/attr1
|
||||
:db/valueType :db.value/string
|
||||
:db/cardinalty :db.cardinality/one
|
||||
:db/unique :db.unique/identity}
|
||||
:test/attr2
|
||||
{:db/ident :test/attr2
|
||||
:db/valueType :db.value/integer
|
||||
:db/cardinalty :db.cardinality/many}})
|
||||
|
||||
;; :db/ident, :db/valueType, and :db/cardinality are required. valueType and cardinality are
|
||||
;; enforced at the schema level.
|
||||
(testing "Fails without entity"
|
||||
(is (thrown-with-msg?
|
||||
ExceptionInfo #":db.install/attribute requires :db/ident, got \{\} for 1"
|
||||
(->>
|
||||
[[:db.part/db :db.install/attribute 1]]
|
||||
(map ->datom)
|
||||
(datoms->schema-fragment)))))
|
||||
|
||||
(testing "Fails without :db/ident"
|
||||
(is (thrown-with-msg?
|
||||
ExceptionInfo #":db.install/attribute requires :db/ident, got \{:db/valueType :db.value/string\} for 1"
|
||||
(->>
|
||||
[[:db.part/db :db.install/attribute 1]
|
||||
[1 :db/valueType :db.value/string]]
|
||||
(map ->datom)
|
||||
(datoms->schema-fragment)))))))
|
||||
Loading…
Reference in a new issue