diff --git a/src/common/datomish/api.cljc b/src/common/datomish/api.cljc index 2e012f84..ae9ffb7c 100644 --- a/src/common/datomish/api.cljc +++ b/src/common/datomish/api.cljc @@ -35,6 +35,7 @@ (def datoms [schema-fragment-id [attribute-name attribute-pairs]] + (let [attribute-id (d/id-literal :db.part/user)] + [(assoc + attribute-pairs + :db.install/_attribute :db.part/db + ;; Point back to the fragment. + :db.schema/_attribute schema-fragment-id + :db/id attribute-id + :db/ident attribute-name)])) + +(defn managed-schema-fragment->datoms [{:keys [name version attributes]}] + (let [fragment-id (d/id-literal :db.part/db)] + (conj + (mapcat (partial attribute->datoms fragment-id) attributes) + {:db/id fragment-id + :db/ident name + :db.schema/version version}))) + +(defn symbolic-schema [db] + (:symbolic-schema db)) + +(defn changed-attribute->datoms [schema-fragment-id attribute-name existing new-values] + (let [differences (first (diff new-values existing))] + (when-not (empty? differences) + [(merge + {:db/id (d/id-literal :db.part/user) + :db/ident attribute-name + ;; Point back to the fragment. + :db.schema/_attribute schema-fragment-id + :db.alter/_attribute :db.part/db} + differences)]))) + +(defn changed-schema-fragment->datoms [schema-fragment-id existing-schema name attributes version] + (conj + (mapcat (fn [[attribute-name new-values]] + (let [existing (get existing-schema attribute-name)] + (if existing + (changed-attribute->datoms + schema-fragment-id + attribute-name + existing + new-values) + (attribute->datoms + schema-fragment-id [attribute-name new-values])))) + attributes) + {:db.schema/version version + :db/ident name + :db/id (d/id-literal :db.part/db)})) + +(defn- prepare-schema-application-for-fragments + "Given a non-empty collection of fragments known to be new or outdated, + yield a migration sequence containing the necessary pre/post ops and + transact bodies." + [db + symbolic-schema + schema-fragment-versions + schema-fragment-attributes + {:keys [fragments pre post fragment-pre fragment-post] :as args}] + + (when-let + [body + (mapcat + (fn [{:keys [name version attributes] :as fragment}] + (if-let [existing-version (get schema-fragment-versions name)] + ;; It's a change. + ;; Spit out any pre/post for this fragment, with a + ;; transact of the datoms to effect the change and + ;; bump the schema fragment version in the middle. + (concat + (when-let [fragment-pre-for-this + (get-in fragment-pre [name existing-version])] + [[:call fragment-pre-for-this]]) + [[:transact + (changed-schema-fragment->datoms (d/entid db name) + symbolic-schema + name + attributes + version)]] + (when-let [fragment-post-for-this + (get-in fragment-post [name existing-version])] + [[:call fragment-post-for-this]])) + + ;; It's new! Just do it. + ;; There can't be any fragment pre/post, 'cos there's no previous + ;; version to come from. + [[:transact (managed-schema-fragment->datoms fragment)]])) + fragments)] + + (concat + (when pre [[:call pre]]) + body + (when post [[:call post]])))) + +(defn- symbolic-schema db) + schema-fragment-versions ( version existing-version) + (when (< version existing-version) + (raise "Existing version of " name " is " existing-version + ", which is later than requested " version "." + {:error :schema/outdated-version + :name name + :version version + :existing existing-version}))))) + fragments)] + + (if (empty? to-apply) + (do + (log "No fragments left to apply.") + nil) + (prepare-schema-application-for-fragments + db + symbolic-schema + schema-fragment-versions + schema-fragment-attributes + (assoc args :fragments to-apply))))))) + +(defn report (assoc-in [:db-after] db-after))))) -(defn- ! token-chan (gensym "transactor-token")) (loop [] (when-let [token ( (! (:listener-source conn) report)) - report)))))] + ;; Default: process the transaction. + (do + (when @(:closed? conn) + ;; Drain enqueued transactions. + (raise "Connection is closed" {:error :transact/connection-closed})) + + (let [db (db conn) + in-transaction-fn + (case sentinel + :sentinel-fn + ;; This is a function that we'd like to run + ;; within a database transaction. See + ;; db/in-transaction! for details. + ;; The function is invoked with two arguments: + ;; the db and a function that takes (db, + ;; tx-data) and transacts it to return a + ;; TxReport. + ;; The function must return a TxReport. + ;; The function must not itself call + ;; `in-transaction!` or `! (:listener-source conn) report)) + report)))))] ;; Even when report is nil (transaction not committed), pair is non-nil. (>! result pair)) (>! token-chan token) diff --git a/src/common/datomish/transact/bootstrap.cljc b/src/common/datomish/transact/bootstrap.cljc index 4bd97765..142e85aa 100644 --- a/src/common/datomish/transact/bootstrap.cljc +++ b/src/common/datomish/transact/bootstrap.cljc @@ -38,6 +38,15 @@ :db/cardinality :db.cardinality/one} :db.alter/attribute {:db/valueType :db.type/ref :db/cardinality :db.cardinality/many} + + :db.schema/version {:db/valueType :db.type/long + :db/cardinality :db.cardinality/one} + + ;; unique-value because an attribute can only belong to a single + ;; schema fragment. + :db.schema/attribute {:db/valueType :db.type/ref + :db/unique :db.unique/value + :db/cardinality :db.cardinality/many} }) (def idents @@ -76,6 +85,8 @@ :db.unique/value 33 :db.unique/identity 34 :db/doc 35 + :db.schema/version 36 ; Fragment -> version. + :db.schema/attribute 37 ; Fragment -> attribute. }) (def parts diff --git a/src/common/datomish/util.cljc b/src/common/datomish/util.cljc index d83e8e4e..c954b150 100644 --- a/src/common/datomish/util.cljc +++ b/src/common/datomish/util.cljc @@ -174,3 +174,22 @@ (let [[k v] (f x)] (assoc! ret k (conj (get ret k []) v)))) (transient {}) coll))) + +(defn repeated-keys + "Takes a seq of maps. + Returns the set of keys that appear in more than one map." + [maps] + (if (not (seq (rest maps))) + #{} + ;; This is a perfect use case for transients, except that + ;; you can't use them for intersection due to CLJ-700. + ;; http://dev.clojure.org/jira/browse/CLJ-700 + (loop [overlapping #{} + seen #{} + key-sets (map (comp set keys) maps)] + (if-let [ks (first key-sets)] + (let [overlap (clojure.set/intersection seen ks)] + (recur (clojure.set/union overlapping overlap) + (clojure.set/union seen ks) + (rest key-sets))) + overlapping)))) diff --git a/test/datomish/schema_management_test.cljc b/test/datomish/schema_management_test.cljc new file mode 100644 index 00000000..cb968571 --- /dev/null +++ b/test/datomish/schema_management_test.cljc @@ -0,0 +1,456 @@ +;; 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-management-test + #?(:cljs + (:require-macros + [datomish.pair-chan :refer [go-pair !]]]) + #?@(:cljs [[datomish.js-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 id-schema (d/id-literal :db.part/db)) +(def id-foobar (d/id-literal :db.part/user)) + +(def trivial-schema-managed-fragment-v1 + {:name :com.example.foo + :version 1 + :attributes + {:foo/bar + {:db/cardinality :db.cardinality/one + :db/valueType :db.type/string}}}) + +(def additional-schema-managed-fragment-v7 + {:name :com.example.bar + :version 7 + :attributes + {:bar/noo + {:db/cardinality :db.cardinality/one + :db/unique :db.unique/value + :db/valueType :db.type/long}}}) + +(def additional-schema-managed-fragment-v8 + {:name :com.example.bar + :version 8 + :attributes + {:bar/choo + {:db/cardinality :db.cardinality/many + :db/fulltext true + :db/valueType :db.type/string} + :bar/noo + {:db/cardinality :db.cardinality/one + :db/unique :db.unique/value + :db/valueType :db.type/long}}}) + +(def trivial-schema-managed-fragment-v2 + {:name :com.example.foo + :version 2 + :attributes + {:foo/bar + {:db/cardinality :db.cardinality/many + :db/valueType :db.type/string}}}) + +(def trivial-schema-v1 + (sm/managed-schema-fragment->datoms trivial-schema-managed-fragment-v1)) + +;; TODO +(deftest test-managed-schema-fragment->datoms) + +(defn datoms fragment))) + + (let [current (symbolic-schema db) + [:foo/bar :db/valueType])))) + + (testing "An empty fragment yields no work." + (is (nil? (datoms + additional-schema-managed-fragment-v7)] + [:call "Y"]] + (datoms + additional-schema-managed-fragment-v7)))) + + next-up + {:pre "XX" + :post "YY" + :fragment-pre {:com.example.foo {1 "AA"}} + :fragment-post {:com.example.foo {1 "BB"} + :com.example.bar {7 "CC"}} + :fragments [trivial-schema-managed-fragment-v2 + additional-schema-managed-fragment-v8 + ]} + + counter (atom 0) + pre (atom nil) + post (atom nil) + fragment-pre-foo (atom nil) + fragment-post-foo (atom nil) + fragment-post-bar (atom nil) + + next-up-but-with-functions + {:pre (fn [db _] + (reset! pre (swap! counter inc)) + nil) + :post (fn [db _] + (reset! post (swap! counter inc)) + nil) + :fragment-pre {:com.example.foo + {1 (fn [db _] + (reset! fragment-pre-foo (swap! counter inc)) + nil)}} + :fragment-post {:com.example.foo + {1 (fn [db _] + (reset! fragment-post-foo (swap! counter inc)) + nil)} + :com.example.bar + {7 (fn [db _] + (reset! fragment-post-bar (swap! counter inc)) + nil)}} + :fragments [trivial-schema-managed-fragment-v2 + additional-schema-managed-fragment-v8]}] + + (testing "Make sure our fragment was added correctly." + (let [bar (d/entid db :com.example.bar)] + (is (integer? bar)) + (is (= :com.example.bar (d/ident db bar)))) + + (is (= {:com.example.foo 1 + :com.example.bar 7} + (symbolic-schema @db) [:bar/thoo :db/cardinality])))) + + (is (= (count "hello, world.") ; 13. + (