Skip to content

Instantly share code, notes, and snippets.

@claj

claj/datomic_util.cljc

Forked from tomconnors/datomic_util.cljc
Created September 3, 2024 08:34
Show Gist options
  • Save claj/8ca1d484246b9120b00f10c325d3be7b to your computer and use it in GitHub Desktop.
Save claj/8ca1d484246b9120b00f10c325d3be7b to your computer and use it in GitHub Desktop.
Download ZIP
kc datomic util
Raw
datomic_util.cljc
(ns kc.datomic
"Datomic utility functions
Usage Notes:
Some functions in this namespace take sequences of facts and return them modified in some way. Some up-front modifications are useful for those functions, like replacing all map-form facts with vector-form facts. In order to avoid doing these modifications repeatedly to same the same set of facts (which would be harmless but wasteful), two versions of these functions exist: a \"safe\" version that does those up-front modifications, and an \"unsafe\" version that expects those modifications to already have been performed. The unsafe versions are named like the safe ones, but with a single quote appended.
TODO:
- consider implementing all fns that branch based on operation as multimethods
These fns mostly support :db/add, :db/retract :db.fn/retractEntity, :db.fn/cas,
but it would be nice if that set were open."
(:refer-clojure :exclude [clone ancestors descendants exists?])
(:require [clojure.set :as set]
[clojure.string :as string]
[clojure.walk :as walk]
[kc.util :as util]
#?(:clj [datomic.api :as d]
:cljs [datascript.core :as d])))
;; -- Connection-management ----------------------------------------------------
#?(:clj (def mem-db-uri-base "datomic:mem://"))
#?(:clj (defn scratch-conn
"Returns a connection to a new in-memory database."
[]
(let [uri (str mem-db-uri-base (d/squuid))]
(d/delete-database uri)
(d/create-database uri)
(d/connect uri))))
;; -- Schema-inspecting functions ---------------------------------------------
(defn attr-type
"Get the :db/valueType of an attribute.
In datascript, only returns the type for attributes with a specified schema - all other attributes will return nil."
[db attribute]
#?(:clj (:value-type (d/attribute db attribute))
:cljs (some-> db :schema attribute :db/valueType)))
(defn component-attr?
"Is `attribute` (passed as a keyword or id) :db/isComponent ?"
[db attribute]
#?(:clj (:is-component (d/attribute db attribute))
:cljs (some-> db :schema attribute :db/isComponent)))
(defn ref-attr?
"Is `attribute` (passed as a keyword or id) of type :db.type/ref ?"
[db attribute]
(= :db.type/ref (attr-type db attribute)))
(defn cardinality-many-attr?
"Is `attribute` (passed as a keyword or id) cardinality-many?"
[db attribute]
#?(:cljs (= :db.cardinality/many (some-> db :schema attribute :db/cardinality))
:clj (= :db.cardinality/many (:cardinality (d/attribute db attribute)))))
(defn ref-non-component-attr?
"Is `attr` an attribute of type :db.type/ref AND defined as :db/isComponent=true?"
[db attr]
(and (ref-attr? db attr)
(not (component-attr? db attr))))
(defn unique-attr?
"Returns a boolean indicating whether attribute is :db.unique/value or :db.unique/identity."
[db attribute]
#?(:clj (:unique (d/attribute db attribute))
:cljs (some-> db :schema attribute :db/unique)))
;; -- Query Functions ---------------------------------------------------------
(defn entity-pull
"Like d/pull, but returns values consistent with d/entity, i.e.,
entities with :db/ident are represented as keywords and sets are
used instead of vectors.
Source: https://gist.github.com/favila/6366516f2bef6b77b07f7349d4ff009e"
([db eid]
(entity-pull db '[*] eid))
([db pat eid]
(->> (d/pull db pat eid)
(walk/prewalk
(fn [x]
(cond
(and (not (map-entry? x))
(vector? x)) (set x)
(and (map? x) (:db/ident x)) (:db/ident x)
(and (map? x) (:db/id x)) (or
(:db/ident (d/entity db (:db/id x)))
x)
:else x))))))
(defn pull-attr
"Return the value of a single attribute of `e`, using d/pull."
[db e attr]
(attr (d/pull db [attr] e)))
(defn entity-attr
"Return the value of a single attribute of `e`, using d/entity."
[db e attr]
(attr (d/entity db e)))
(defn exists?
"Returns a boolean indicating whether entity w/ id `entity-id` exists in `db`.
An entity exists if there are any facts about it."
[db entity-id]
(some? (seq (d/q '[:find ?e :in $ ?e :where [?e]]
db entity-id))))
;; -- Heirarchy-related Query Functions ---------------------------------------
;; In order to optimize the search for parent entities in datascript,
;; we need to know what attrs are ref+component.
#?(:cljs (defn- -schema->ref-component-attrs [schema]
(into #{}
(comp
(filter (fn [[_ attr-spec]]
(and (:db/isComponent attr-spec)
(= (:db/valueType attr-spec) :db.type/ref))))
(map (fn [[attr _]] attr)))
schema)))
#?(:cljs (def ^:private schema->ref-component-attrs
(memoize -schema->ref-component-attrs)))
#?(:cljs (defn- ref-component-attrs [db]
(schema->ref-component-attrs (:schema db))))
#?(:cljs
(defn parent-datom
"Return the datom asserting `e` as a child of its parent.
You can use this to get the parent id and the attr in one call.
Example: (let [{parent :e attr :a} (parent-datom db e)])"
([db e] (parent-datom db e (ref-component-attrs db)))
([db e possible-attrs]
(let [datoms (mapcat #(d/datoms db :avet % e) possible-attrs)]
(if-let [d (first datoms)]
d))))
:clj
(defn parent-datom
"Return the datom asserting `e` as a child of its parent.
You can use this to get the parent id and the attr in one call.
Example: (let [{parent :e attr :a} (parent-datom db e)])"
[db e]
(if-let [res (d/q '[:find [?parent ?a]
:in $ ?e
:where
[?parent ?attr ?e]
[?attr :db/isComponent true]
[?attr :db/ident ?a]]
db e)]
(let [[e a] res]
{:e e :a a}))))
#?(:clj
(defn parent
"Get the immediate parent of an entity, returning either the parent's eid or nil."
[db e]
(d/q '[:find ?parent .
:in $ ?e
:where
[?parent ?attr ?e]
[?attr :db/isComponent true]]
db e))
;; Datascript doesn't (yet?) support VAET indexes, which means
;; searching for an entity's parent the way we do w/ datomic is slow.
;; This solution makes use of AVET indexes instead, which is faster than
;; any alternatives I'm aware of.
:cljs
(defn parent
"Get the immediate parent of an entity, returning either the parent's eid or nil.
`possible-attrs` indicates the set of attrs that might possibly point to this child from the parent. When it is not provided, the set of all ref+component attributes in the db is used."
([db e] (parent db e (ref-component-attrs db)))
([db e possible-attrs]
(:e (parent-datom db e possible-attrs)))))
(defn closest-matching-ancestor
"Given a datomic database, an id, and a function,
return the first ancestor of the entity with id `id` for which `f` is truthy."
[db id f]
(let [ancestor (parent db id)]
(if ancestor
(if (f ancestor)
ancestor
(closest-matching-ancestor db ancestor f)))))
;; TODO: this fn should be lazy.
#?(:clj
(defn ancestors
"Return a sequence of the ancestors of e, ordered from closest (direct parent) to furthest (primordial ooze)"
[db e]
(loop [ancestors []
e e]
(if-let [parent (parent db e)]
(recur (conj ancestors parent) parent)
ancestors)))
:cljs
(defn ancestors
"Return a sequence of the ancestors of e, ordered from closest (direct parent) to furthest (primordial ooze)"
([db e] (ancestors db e (ref-component-attrs db)))
([db e possible-attrs]
(loop [ancestors []
e e]
(if-let [parent (parent db e possible-attrs)]
(recur (conj ancestors parent) parent)
ancestors)))))
(defn ultimate-ancestor
"Return the ultimate/farthest ancestor of entity w/ :db/id = `id`"
[db id]
(let [parent (parent db id)]
(if parent
(recur db parent)
id)))
(defn descendants
"Find descendants of `id`, optionally limiting to those for which `pred` is truthy."
([db id] (descendants db identity id))
([db pred id]
(let [m (entity-pull db '[*] id)
ids* (atom #{})
_ (util/postwalk-maps
(fn [m]
(when (pred m)
(swap! ids* conj (:db/id m)))
m)
m)]
(swap! ids* disj id))))
(defn ancestor?
"Returns a boolean indicating whether maybe-ancestor is an ancestor of maybe-descendant."
[db maybe-ancestor maybe-descendant]
(boolean
(closest-matching-ancestor db maybe-descendant (fn [e] (= e maybe-ancestor)))))
(defn- references-
"Returns the set of entities referenced (recursively) by entity `id`.
Entities referenced by `id` or some descendant or referent of `id` that are descendants of another entity referenced by `id` may be included in the result set.
`exclusions`: a set of attrs to exclude when searching for references
`found`: a set of already-found references. Avoids needless repeat work + the possibility of infinite recursion."
[db id exclusions found]
(let [already-found? (fn [found id] (contains? found id))
reduce-owned-entity (fn [found {:keys [db/id] :as ent}]
(references- db id exclusions found))
reduce-non-owned-entity (fn [found {:keys [db/id] :as ent}]
;; References to idents don't count.
(if (or #?(:clj (d/ident db id) :cljs false)
(already-found? found id))
found
;; This is a legitimate reference to another entity
(conj (references- db id exclusions found)
id)))
found
(reduce-kv
(fn [found attr val]
(if (and (ref-attr? db attr) (not (contains? exclusions attr)))
(let [reducer (if (component-attr? db attr)
reduce-owned-entity
reduce-non-owned-entity)]
(if (cardinality-many-attr? db attr)
(reduce reducer found val)
(reducer found val)))
found))
;; add the entity for which we are finding references to the set of
;; found references so that we don't search it again if it is
;; referenced by some relation.
(conj found id)
(d/pull db '[*] id))
;; Then pop it out again, since an entity doesn't reference itself.
found (disj found id)]
found))
(defn remove-descendants
"Filter the eids set to only contain those that are not descendants of any others in the set."
[db eids]
(reduce
(fn [new-eids eid]
(if (some (fn [e] (ancestor? db e eid)) eids)
new-eids
(conj new-eids eid)))
#{}
eids))
(defn non-recursive-references [db id exclusions]
(into #{}
(comp
(filter (fn [[attr val]]
(and (ref-non-component-attr? db attr)
(not (contains? exclusions attr)))))
(mapcat (fn [[attr val]]
(if (cardinality-many-attr? db attr)
(filter identity
(map (fn [x]
(if-let [id (:db/id x)]
id))
val))
(if-let [id (:db/id val)]
[id])))))
(d/entity db id)))
(defn references
"Returns the set of entities referenced (optionally, recursively) by entity `id`.
Entities referenced by `id` or some descendant or referent of `id` that are descendants of another entity referenced by `id` are not included in the result set unless `descendants` is true.
Additionally, references to transaction entities are excluded.
`exclusions`: a set of attrs to exclude when searching for references.
`recursive`: set to false to make the search only consider direct references from `id`.
`descendants`: set to true to possibly include descendants in the result set."
([db id]
(references db id #{}))
([db id exclusions]
(references db id exclusions true))
([db id exclusions recursive]
(references db id exclusions recursive false))
([db id exclusions recursive descendants]
(let [refs (if recursive
(references- db id exclusions #{})
(non-recursive-references db id exclusions))
refs (if descendants
refs
(remove-descendants db refs))]
refs)))
;; -- Temp ids -----------------------------------------------------------------
(defn tempid?
"On jvm, checks whether `id` is a datomic.db.DbId. On js, just checks that it's less than 0."
[id]
#?(:cljs (< id 0)
:clj (instance? datomic.db.DbId id)))
(def ^:redef default-tempid-partition
"Default partition to use when creating tempids with `tempid`.
Can rebind with `alter-var-root`; direct linking is disabled for this var."
:db.part/user)
(def ^:dynamic *tempid*
"Rebindable tempid-returning function.
By default, just returns a temp id in the given partition w/ the given index.
Bound by `with-tempid-generator` to allow the creation of sequential ids."
(fn
([] (d/tempid default-tempid-partition))
([n] (d/tempid default-tempid-partition n))
([part n] (d/tempid part n))))
(defn tempid-generator
"Returns a function that can be called repeatedly to generate sequential tempids."
([start-num] (tempid-generator start-num default-tempid-partition))
([start-num part]
(let [id-seq (atom (range start-num -1000000 -1))]
(fn []
(let [n (first @id-seq)]
(swap! id-seq next)
(d/tempid part n))))))
(defmacro with-tempid-generator
"Evaluate `body` with `*tempid* bound to a `tempid-generator` function starting at `n` and with partition `default-tempid-partition`"
[n & body]
`(binding [*tempid* (tempid-generator ~n)]
~@body))
(defmacro with-partitioned-tempid-generator
"Evaluate `body` with `tempid` bound to a `tempid-generator` function starting at `n` and with partition `partition`."
[n partition & body]
`(binding [*tempid* (tempid-generator ~n ~partition)]
~@body))
;; -- Transaction helpers -----------------------------------------------------
(defn map->facts
"Given a map that could be passed to datomic in some transaction data, return a sequence of facts equivalent to the map.
Optionally provide a tempid generator fn."
([m] (map->facts m *tempid*))
([m tempid]
(let [id (or (:db/id m) (tempid))
process-kv (fn [k v]
(cond
;; In clj, need to check for a datomic id up front because
;; (map? tempid) is true.
;; Not necessary in cljs because datascript uses numbers for tempids.
#?@(:clj [(tempid? v)
[[:db/add id k v]]])
(map? v) (let [subid (or (:db/id v) (tempid))]
(into [[:db/add id k subid]]
(map->facts (assoc v :db/id subid) tempid)))
(coll? v) (mapcat
(fn [x]
(cond
;; same as above.
#?@(:clj [(tempid? x) [[:db/add id k x]]])
(map? x) (let [subid (or (:db/id x) (tempid))]
(into [[:db/add id k subid]]
(map->facts (assoc x :db/id subid)
tempid)))
(coll? x) (throw (ex-info "Bad facts" {:bad-facts m}))
:else [[:db/add id k x]]))
v)
:else [[:db/add id k v]]))]
(mapcat (fn [[k v]]
(process-kv k v))
(dissoc m :db/id)))))
(defn flatten-facts-xducer
"Returns a transducer to flatten -- replace maps in -- a sequence of facts."
([] (flatten-facts-xducer *tempid*))
([tempid] (mapcat
(fn [fact]
(if (map? fact)
(map->facts fact tempid)
[fact])))))
;; TODO: wouldn't `normalize-facts` be a better name?
(defn flatten-facts
"Given a sequence of facts that could be passed to datomic, replace any maps with vector-form facts.
Optionally provide a tempid generator fn."
([facts] (flatten-facts facts *tempid*))
([facts tempid]
(into [] (flatten-facts-xducer tempid) facts)))
(def facts->clj-data-types-xducer
"A transducer that coverts fact sequences to use idiomatic clj datatypes.
This is helpful in transactor functions because datomic gives vector-form facts back to us as java.util.Arrays$ArrayLists."
(map (fn [f]
(cond
(map? f) (into {} f)
;; What we give to datomic as vectors, datomic gives us back
;; as java.util.Arrays$ArrayLists.
(seqable? f) (seq f)))))
(defn tx-data->idiomatic-data-types
"Given a sequence of facts from datomic (in a transaction fn),
convert the datatypes of the facts to idiomatic clojure types."
[facts]
(into [] facts->clj-data-types-xducer facts))
(defn clean-facts
"Convert facts to be easier to work with; ArrayLists are replaced with seqs and map-form facts are replaced with vector-form facts."
[facts]
(into []
(comp
;; Convert java types to clojure types (important when run as a transactor fn)
facts->clj-data-types-xducer
;; Convert map-form facts to vector-form
(flatten-facts-xducer))
facts))
(defn- double-attr?
"Returns a boolean indicating whether `attr` is of type :db.type/double.
Private because making this public would imply that we should have public predicates for all attribute types."
[db attr]
(= (attr-type db attr) :db.type/double))
(defn replace-longs-with-doubles'
"Given a sequence of facts, return a sequence of facts w/ all :db.type/double attribute values as doubles.
This is often necessary when accepting input from browsers since datomic doesn't automatically convert longs to doubles and javascript doesn't differentiate the two."
[db facts]
(let [double? (fn [attr] (double-attr? db attr))
maybe-double (fn [a x] (if (double? a) (double x) x))]
(map
(fn [[op :as fact]]
(case op
:db/add (update fact 3 #(maybe-double (nth fact 2) %))
:db.fn/cas (-> fact
(update 3 #(maybe-double (nth fact 2) %))
(update 4 #(maybe-double (nth fact 2) %)))
:db/retract (update fact 3 #(maybe-double (nth fact 2) %))
fact))
facts)))
(defn replace-longs-with-doubles
"Given a sequence of facts, return a sequence of facts w/ all :db.type/double attribute values as doubles.
This is often necessary when accepting input from browsers since datomic doesn't automatically convert longs to doubles and javascript doesn't differentiate the two."
[db facts]
(replace-longs-with-doubles' db (clean-facts facts)))
(defn retractAttribute->retract
"Given a sequence of facts, return a sequence of facts w/ all :db.fn/retractAttribute facts replaced with a :db/retract fact."
[db facts]
(mapcat
(fn [[op :as fact]]
(if (= op :db.fn/retractAttribute)
(let [[_ e a] fact
val (pull-attr db e a)]
(cond
(nil? val) []
(map? val) [[:db/retract e a (:db/id val)]]
(sequential? val) (map (fn [x]
(if (map? x)
[:db/retract e a (:db/id x)]
[:db/retract e a x]))
val)
:else [[:db/retract e a val]]))
[fact]))
facts))
(defn reassigned-parent?
"Returns a boolean indicating whether the entity with id `entity-id` is reassigned
ownership/parent in the fact sequence `tx-data`.
Ownership is assigned by setting the entity as the value of a ref+component attr of an entity that is not its current parent."
([db entity-id tx-data]
(reassigned-parent? db entity-id tx-data nil))
([db entity-id tx-data current-parent]
(let [parent-changing-fact? (fn [e a v]
(and (= v entity-id)
(component-attr? db a)
(ref-attr? db a)
(not= e (if current-parent
current-parent
(parent db entity-id)))))]
(some (fn [tx-datom]
(if (sequential? tx-datom)
(let [[op e a v] tx-datom]
(case op
:db/add (parent-changing-fact? e a v)
(:db/cas :db.fn/cas) (let [[op e a old new] tx-datom]
(parent-changing-fact? e a new))
false))))
(flatten-facts tx-data)))))
(defn retractEntity->retract
"Converts :db.fn/retractEntity and :db/retractEntity datoms into n :db/retract datoms.
Differs from the built-in :db.fn/retractEntity in that entities owned by the target of the retraction that are reassigned a new owner/parent in the same transaction will not be deleted along with the former parent."
[db init-tx-data]
(let [new-parent? (fn [db entity-id current-parent-id]
(reassigned-parent? db entity-id init-tx-data current-parent-id))]
(loop [tx-data init-tx-data
out-tx-data []
;; We only track `ents-to-retract` as a safeguard against infinite recourse.
;; I'm not totally sure it's necessary.
ents-to-retract #{}]
(let [[tx-datom & tx-datoms] tx-data]
(if (empty? tx-data)
out-tx-data
(cond
(map? tx-datom) (recur tx-datoms
(conj out-tx-data tx-datom)
ents-to-retract)
;; tx facts are handed to us as java.util.Arrays$ArrayLists
;; so `sequential?` doesn't work.
(seqable? tx-datom)
(let [[op e a v] (seq tx-datom)]
;; If this fact is an entity retraction AND we haven't already
;; processed the retraction of the entity
(if (and (or (= op :db.fn/retractEntity)
(= op :db/retractEntity))
(not (contains? ents-to-retract e)))
(let [e-datoms (d/datoms db :eavt e)
v-datoms (d/datoms db :vaet e)]
(recur
;; add :db/retractEntity to the tx-data for references
;; to entities that are not changing parent.
(into tx-datoms
(comp
(filter (fn [{:keys [a] :as datom}]
(and (ref-attr? db a)
(component-attr? db a))))
(remove (fn [datom] (new-parent? db (:v datom) (:e datom))))
(map (fn [datom] [:db.fn/retractEntity (:v datom)])))
e-datoms)
;; add to the out tx data the retraction of the facts about this ent
(into out-tx-data
(map (fn [{:keys [e a v]}] [:db/retract e a v]))
(concat e-datoms v-datoms))
(conj ents-to-retract e)))
(recur tx-datoms
(conj out-tx-data tx-datom)
ents-to-retract)))
:else (try (ex-info "Unsupported fact type." {:datom tx-datom}))))))))
(defn entity-retraction-rules
"Returns a seq of vectors like [entity-id, attribute-name, on-retract-behavior],
where each entity-id is an entity that references `id` at ref, non-component attr attribute-name, with retraction behavior on-retract-behavior.
Possible retraction behaviors are :on-retract/allow, :on-retract/restrict, and :on-retract/cascade.
Read the docstring for `entity-retractions-with-fk-safeguards` for more info."
[db id]
(d/q '[:find ?e ?attr-name ?on-retract-kw
:in $ ?retracted-entity
:where
[?e ?a ?retracted-entity]
[?a :db/valueType :db.type/ref]
[?a :db/ident ?attr-name]
[(get-else $ ?a :db/isComponent false) ?component]
[(= ?component false)]
[?restrict :db/ident :on-retract/restrict]
[(get-else $ ?a :ref/on-retract ?restrict) ?on-retract]
[?on-retract :db/ident ?on-retract-kw]]
db id))
(defn entity-retraction-fact? [fact]
(if (sequential? fact)
(let [[op] fact]
(or (= op :db.fn/retractEntity)
(= op :db/retractEntity)))))
(defn entity-retractions
"Given a seq of facts that could be passed to d/transact, return the set of entities that are targets of :retractEntity facts."
[facts]
(into #{}
(comp
(filter entity-retraction-fact?)
(map (fn [[_ e]] e)))
facts))
(defn entity-retractions-with-fk-safeguards
"Given a `db` and a seq of entity ids to maybe retract (`retractions`),
returns a set of entity ids to definitely retract, ensuring that retracted entities cascade appropriately.
Installed attributes may have the attribute :ref/on-retract, which may have one of three values:
:on-retract/allow
:on-retract/restrict (the default if the :ref/on-retract key is not present)
:on-retract/cascade.
Use these attributes to control cascading deletes, allowing deletes, and preventing deletes.
Note that the :ref/on-retract key is only useful on attributes of type :ref with :db/isComponent=false.
An example use case:
Suppose you define a survey, then put that survey in a control group's whitelist.
The default behavior if you try to transact [:db.fn/retractEntity survey-id] without this fn is to retract the survey AND the reference to the survey in the whitelist.
Using this fn you have three options for that situation:
- :on-retract/allow is the same as the default behavior without this fn - it allows the retraction to go through.
- :on-retract/restrict would prevent the survey from being retracted. You might want this in cases where an entity is referenced by another, and is essential for that other entity.
- :on-retract/cascade would cause the retraction to cascade up the heirarchy until another ref, non-component attribute is found.
Required schema for this to work:
[{:db/ident :on-retract/allow}
{:db/ident :on-retract/cascade}
{:db/ident :on-retract/restrict}
{:db/ident :ref/on-retract,
:db/valueType :db.type/ref,
:db/cardinality :db.cardinality/one,
:db/isComponent false,
:db/doc \"Specifies the behavior for when the entity referenced by a non-component :ref type attribute is retracted.\"}]"
[db retractions]
(let [get-entity-references (fn [id] (entity-retraction-rules db id))
get-entities-to-retract
(fn get-entities-to-retract [eid]
(let [references (get-entity-references eid)]
(if (seq references)
(if (some (fn [[referencer attr on-retract]]
(= on-retract :on-retract/restrict))
references)
;; If any retraction rule specifies `restrict`, the retraction for
;; this entity cannot go through.
[:no-retract]
;; otherwise every reference is either :allow
;; or :cascade.
;; for :allows, we just retract the entity.
;; for :cascades, we must also retract the referencing
;; entity (and do this procedure for _that_ entity too)
(let [references-to-retract
(mapcat
(fn [[referencer attr on-retract]]
(if (= on-retract :on-retract/allow)
[]
;; otherwise it's :on-retract/cascade
(get-entities-to-retract referencer)))
references)]
(if (some (fn [item]
(= item :no-retract))
references-to-retract)
[:no-retract]
(conj references-to-retract eid))))
;; The entity has no retraction rules, so it's the only
;; entity to retract.
[eid])))
entities-to-definitely-retract (into #{}
(comp
(mapcat get-entities-to-retract)
(remove #(= % :no-retract)))
retractions)]
entities-to-definitely-retract))
(defn with-fk-on-retract-behavior'
"Given a sequence of vector-form facts, returns the sequence of facts with any disallowed retractions removed and any required retractions added.
Refer to entity-retractions-with-fk-safeguards for details."
[db facts]
(let [fact-groups (group-by entity-retraction-fact? facts)
non-retract-ent-facts (get fact-groups false)
retract-ent-facts (get fact-groups true)
ents-to-maybe-retract (into #{}
(map (fn [[_ e]] e))
retract-ent-facts)
ents-to-retract (kc.datomic/entity-retractions-with-fk-safeguards
db ents-to-maybe-retract)
facts (into non-retract-ent-facts
(map (fn [e] [:db.fn/retractEntity e]))
ents-to-retract)]
;; TODO: shouldn't I also remove from non-retract-ent-facts any assertions
;; about anything in `ents-to-retract`?
facts))
(defn with-fk-on-retract-behavior
"Given a sequence of any kinds of facts, returns the sequence of facts with any disallowed retractions removed and any required retractions added.
Refer to entity-retractions-with-fk-safeguards for details."
[db facts]
(with-fk-on-retract-behavior' db (clean-facts facts)))
(defn- replace-if-tempid [db val tempids]
(if (tempid? val)
(or (d/resolve-tempid db tempids val) val)
val))
(defn- replace-tempids
"Replace the tempid objects in `fact` with realids using d/resolve-tempid."
[db [op e a v v2 :as fact] tempids]
(case op
(:db/add :db/retract)
[op (replace-if-tempid db e tempids) a (replace-if-tempid db v tempids)]
:db.fn/cas
[op (replace-if-tempid db e tempids) a
(replace-if-tempid db v tempids)
(replace-if-tempid db v2 tempids)]
:db.fn/retractEntity
[op (replace-if-tempid db e tempids)]))
(defn -simplify-fact-seqs [db fact-seqs xform]
(let [replace-tempids-global replace-tempids]
(reduce
(fn [{:keys [replace-tempids realid->tempid db tx-datas]} facts]
(let [tempids-in (reduce (fn [ids [op e a v v2]]
(into ids (filter tempid? [e v v2])))
#{}
facts)
facts (map replace-tempids facts)
;; Here's where the actual fact-altering transformation takes place.
facts (xform db facts)
tx-result (d/with db facts)
{:keys [tempids db-after]} tx-result
transaction-id (-> tx-result :tx-data first :tx)
tempid->realid (reduce (fn [m tempid]
(assoc m tempid (d/resolve-tempid db-after tempids tempid)))
{}
tempids-in)
realid->tempid (merge realid->tempid (set/map-invert tempid->realid))]
{:replace-tempids (fn [fact]
(as-> fact f
(replace-tempids-global db-after f tempids)
(replace-tempids f)))
:realid->tempid realid->tempid
:db db-after
:tx-datas (conj tx-datas
(->> (:tx-data tx-result)
(map
(fn [{:keys [e a v added]}]
[(if added :db/add :db/retract)
;; If e came from a tempid, we need that tempid.
(get realid->tempid e e)
a
;; If v came from a tempid, we need that tempid.
;; Need to check if attribute is ref, because if its
;; a long, there's a small chance of a false positive.
(if (ref-attr? db-after a)
(get realid->tempid v v)
v)]))
;; Get rid of any fact that was added about this tx.
(remove (fn [[_ e]] (= e transaction-id)))))}))
{:replace-tempids identity
:realid->tempid {}
:db db
:tx-datas []}
fact-seqs)))
(defn simplify-fact-seqs
"Given any number of sequences of facts, return the same number of sequences of facts, with all higher-order facts (ie any fact other than a :db/add or :db/retract) replaced with some number of :db/add and :db/retract facts.
Each output fact-seq is derived by speculatively transacting (using d/with) each previous fact-seq, optionally transforming the current iteration's fact-seq with `xform`, speculatively transacting the current iteration's fact-seq, and converting the tx-result's :tx-data back to transactable facts.
Tempids are consistent across the fact sequences; tempid -1 in fact seq 1 refers to the same entity as tempid -1 in fact seq 2. The returned fact-seqs include tempids - the real entity ids produced by d/with are replaced with the input tempids.
If `xform` is provided, its signature is [db, facts] -> facts and it is applied to each fact-seq before speculatively transacting it but AFTER the fact-seq's tempids are replaced with realids.
Hint: call merge-facts and remove-tempid-retractions on this fn's return value to produce a single transactable sequence of facts."
([db fact-seqs]
(simplify-fact-seqs db fact-seqs (fn [db facts] facts)))
([db fact-seqs xform]
(:tx-datas (-simplify-fact-seqs db fact-seqs xform))))
(defn- remove-conflicting-cardinality-one-facts [facts [op e a v]]
(remove
(fn [[op2 e2 a2 v2]]
;; Facts conflict for our purposes if:
;; 1) They specify the same op, e, and a.
;; Example: [:db/add 1 :artist/name "Bad Religion"]
;; [:db/add 1 :artist/name "Grumpy Old Men"]
;; These would conflict, so we only keep that last.
;; 2) They specify the same e, a, and v, and different op.
;; Example: [:db/add 3 :artist/name "Bad Religion"]
;; [:db/retract 3 :artist/name "Bad Religion"]
;; The retraction should win here, so we drop the add.
;; Note that redundant facts - equal op,e,a,v -
;; are harmless, so they're ignored here.
;; Another form of redundancy is also ignored:
;; [retract 1 name "old name"] [add 1 name "new name"]
;; The second implies the first, but including both
;; is fine.
(and (= e e2)
(= a a2)
(or
(= op op2)
;; We can assume (not= op op2)
(= v v2))))
facts))
(defn- remove-conflicting-cardinality-many-facts [facts [op e a v]]
(remove
(fn [[op2 e2 a2 v2]]
;; Facts conflict for our purposes if:
;; 1) They specify the same e, a, and v, and different op.
;; Example: [:db/add 3 :artist/albums "Suffer"]
;; [:db/retract 3 :artist/albums "Suffer"]
;; The retraction should win here, so we drop the add.
;; Note that redundant facts - equal op,e,a,v -
;; are harmless, so they're ignored here.
;; Another form of redundancy is also ignored:
;; [retract 1 name "old name"] [add 1 name "new name"]
;; The second implies the first, but including both
;; is fine.
(and (= e e2)
(= a a2)
(= v v2)
(not= op op2)))
facts))
(defn merge-facts
"Given any number of vector-form fact sequences that could individually be transacted, return a single fact seq that is equivalent.
The only allowed fact types are :db/add and :db/retract."
[db fact-seqs]
(reduce
(fn [facts [op e a v :as fact]]
(if (cardinality-many-attr? db a)
(conj (remove-conflicting-cardinality-many-facts facts fact) fact)
(conj (remove-conflicting-cardinality-one-facts facts fact) fact)))
[]
(apply concat fact-seqs)))
(defn remove-tempid-retractions
"Return `facts` less any :db/retract facts with a tempid in entity or value position.
Assumes that all facts are either :db/add or :db/retract."
[facts]
(remove
(fn [[op e a v]]
(and (= op :db/retract)
(or (tempid? e)
(tempid? v))))
facts))
(defn transact-many-validated
"Given any number of fact sequences, reduce them to a single fact sequence without any conflicting datoms.
Handles foreign-key relationships with entity-retractions-with-fk-safeguards.
Handles entity retractions with retractEntity->retract.
Deduplicates/merges with merge-facts"
[db fact-seqs]
(let [fact-seqs (map clean-facts fact-seqs)
fact-seqs (map #(with-fk-on-retract-behavior' db %) fact-seqs)
fact-seqs (simplify-fact-seqs db fact-seqs retractEntity->retract)
facts (merge-facts db fact-seqs)
facts (remove-tempid-retractions facts)]
facts))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment