Accept new schema fragments via :db.part/db :db.install/attribute.

src/datomish/db.cljc

@@ -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]
+  [db report]
-  {:pre [(db? db)]}
+  {: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)))))
 

src/datomish/schema_changes.cljc

@@ -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}))))))))))

test/datomish/db_test.cljc

@@ -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)))))))

test/datomish/schema_changes_test.cljc

@@ -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)))))))