Skip to content
Permalink
ee652be2cc
Switch branches/tags

Name already in use

A tag already exists with the provided branch name. Many Git commands accept both tag and branch names, so creating this branch may cause unexpected behavior. Are you sure you want to create this branch?
Go to file
 
 
Cannot retrieve contributors at this time
131 lines (122 sloc) 6.78 KB
(ns de.mpg.shh.util-datomic-peer.impl.push
(:require [clojure.tools.logging :refer [info error]]
[clojure.string :as str]
[clojure.set :as set]
[datascript.core :as ds]
[datomic.api :as dt]))
(defn push->path
[accumulator path push-pattern]
(cond
(keyword? push-pattern)
(conj accumulator (conj path push-pattern))
(map? push-pattern)
(reduce (fn [acc i]
(push->path acc (conj path (ffirst push-pattern)) i)) accumulator (second (first push-pattern)))
(vector? push-pattern)
(reduce (fn [acc i]
(push->path acc path i)) accumulator push-pattern)
:else (throw (ex-info "Cannot find path for push" {:cause (str "no handler for: '" (type push-pattern) "'")}))))
(defn push->attr-set
[accumulator push-pattern]
(cond
(keyword? push-pattern)
(conj accumulator push-pattern)
(map? push-pattern)
(reduce (fn [acc i]
(push->attr-set acc i)) (conj accumulator (ffirst push-pattern)) (second (first push-pattern)))
(vector? push-pattern)
(reduce (fn [acc i]
(push->attr-set acc i)) accumulator push-pattern)
:else (throw (ex-info "Cannot add to attr set for push" {:cause (str "no handler for: '" (type push-pattern) "'")}))))
(defn component-attr?
[schema-map attr]
(= true (get-in schema-map [attr :db/isComponent])))
(defn component-attr->id-attr
[attr]
(let [attr-name (name attr)
_ (when-not (str/ends-with? attr-name "+") (throw (ex-info "Can't convert component-attr to id-attr" {:cause (str "component-attr name '" (name attr) "' doesn't end with '+'")})))
component-name (subs attr-name 0 (- (count attr-name) 1))]
(keyword (str (namespace attr) "." component-name "/" component-name "-id"))))
(defn where-clause-builder
[component-attr-id-attr-map row accumulator item]
(let [next-sym (gensym "?e")
component-id-attr (get component-attr-id-attr-map item)
component-id-attr-val (get row component-id-attr)]
(conj accumulator [(first (last accumulator)) item next-sym]
[next-sym component-id-attr component-id-attr-val])))
(defn namespace-attrs
[attr-paths-lookup id-attr]
(for [[k v] attr-paths-lookup :when (and (= (namespace k) (namespace id-attr))
(not= k id-attr))] k))
(defn generate-attr-tx-data
[dt-value-type-lookup attr]
(when-let [value-type (get dt-value-type-lookup attr)]
(cond
(= value-type :db.type/uuid) [:db/add -1 attr (dt/squuid)])))
;; query for the id of the parent entity
(defn cache-row
[ds-conn dt-value-type-lookup attr-paths-lookup component-attr-id-attr-map row]
(let [;;_ (info "attr-paths-lookup: " attr-paths-lookup)
insertion-order (sort-by namespace (filter #(contains? attr-paths-lookup %) (keys row)))
;;_ (info "insertion-order: " insertion-order)
root-result (-> (ds/q '[:find [?e ...]
:in $ ?lookup-attr ?lookup-val
:where [?e ?lookup-attr ?lookup-val]]
(ds/db ds-conn)
(first insertion-order)
(get row (first insertion-order)))
first)
;;_ (info "root-result: " root-result)
_ (when (nil? root-result)
(let [other-root-attrs (namespace-attrs attr-paths-lookup (first insertion-order))
generated-tx-data (vec (remove nil? (map (partial generate-attr-tx-data dt-value-type-lookup) (remove #(contains? row %) other-root-attrs))))]
(ds/transact ds-conn (concat [[:db/add -1 (first insertion-order) (get row (first insertion-order))]]
generated-tx-data))))]
(doseq [field (rest insertion-order)]
;;(dorun (map (partial cache-field conn attr-paths-lookup component-attr-id-attr-map row) insertion-order))
(let [field-attr-paths (get attr-paths-lookup field)
;;_ (info "field-attr-paths: " field-attr-paths)
where-clauses (vec (reduce (partial where-clause-builder component-attr-id-attr-map row) [[(symbol "?e") (first insertion-order) (get row (first insertion-order))]] field-attr-paths))
component-id-attr (get component-attr-id-attr-map (last field-attr-paths))
component-id-attr-val (get row component-id-attr)
;;_ (info "field: " field)
;;_ (info "cid: " component-id-attr " cv: " component-id-attr-val)
;;_ (info "where clauses: " where-clauses)
]
(loop [wc where-clauses]
(when-not (empty? (into #{} (map first wc)))
(let [;;_ (info "search wc: " wc)
result (-> (ds/q `[:find [(~'pull ~(first (last wc)) [~'*]) ~'...]
:where ~@wc]
(ds/db ds-conn))
first)
;;_ (info "result: " result)
]
(cond
(nil? result)
(recur (vec (butlast (apply concat (butlast (partition-by first wc))))))
(not= (get result component-id-attr) component-id-attr-val)
(let [;;_ (info "found parent: " result)
tx-data (vec (distinct [[:db/add (:db/id result) (last field-attr-paths) -1]
[:db/add -1 component-id-attr component-id-attr-val]
[:db/add -1 field (get row field)]]))
;;_ (info "tx-data: " tx-data)
other-attrs (namespace-attrs attr-paths-lookup component-id-attr)
generated-tx-data (vec (remove nil? (map (partial generate-attr-tx-data dt-value-type-lookup) (remove #(contains? row %) other-attrs))))]
(ds/transact ds-conn (concat tx-data generated-tx-data)))
(not= (get result field) (get row field))
(ds/transact ds-conn [[:db/add (:db/id result) field (get row field)]])))))
))
))
(defn datascript->datomic-tx-data
[ds-conn dt-partition dt-value-type-lookup]
(let [schema (:schema (ds/db ds-conn))]
(for [datom (ds/datoms (ds/db ds-conn) :eavt)]
(let [;;_ (info "e: " (:e datom) " a: " (:a datom) " v: " (:v datom) " :db/valueType " (get-in schema [(:a datom) :db/valueType]) " dt type " (get dt-value-type-lookup (:a datom)))
datom-val (cond
(= (get-in schema [(:a datom) :db/valueType]) :db.type/ref)
(dt/tempid dt-partition (* (:v datom) -1))
(= (get dt-value-type-lookup (:a datom)) :db.type/long)
(Long/valueOf (:v datom))
:else (:v datom))]
[:db/add (dt/tempid dt-partition (* (:e datom) -1)) (:a datom) datom-val]))))