diff --git a/src/common/datomish/schema_management.cljc b/src/common/datomish/schema_management.cljc new file mode 100644 index 00000000..d065bc4f --- /dev/null +++ b/src/common/datomish/schema_management.cljc @@ -0,0 +1,348 @@ +;; 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 + #?(:cljs + (:require-macros + [datomish.pair-chan :refer [go-pair 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 !]]]) + #?@(: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. + (