mirror of
https://github.com/penpot/penpot.git
synced 2026-10-29 22:10:34 +00:00
🔥 Retire the Cypher session sync and its gates
app.graph.sync existed to keep a live Ladybug session in step with the editor's change vectors; with sessions on the overlay it has no caller. Its parity suite and the binder gate move with it: the overlay sync parity test replays the same change vocabulary against app.graph.overlay.sync, and the console gate test guards the Datalog surface where validate-on-connection! guarded Cypher. The validator itself stays in app.graph.ladybug with the batch tier. AI-assisted-by: claude-fable-5
This commit is contained in:
Álvaro Tejero Cantero
parent
d5324e9e02
commit
1fe5215d12
@ -1,900 +0,0 @@
|
||||
;; 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/.
|
||||
;;
|
||||
;; Copyright (c) KALEIDOS SUBSIDIARY SL
|
||||
|
||||
(ns app.graph.sync
|
||||
"Incremental Ladybug graph updates from Penpot file-change events."
|
||||
(:require
|
||||
[app.common.logging :as l]
|
||||
[app.common.uuid :as uuid]
|
||||
[app.graph.ladybug :as ladybug]
|
||||
[app.graph.projection.document :as projection.document]
|
||||
[app.graph.schema.nodes :as nodes]
|
||||
[clojure.string :as str])
|
||||
(:import
|
||||
com.ladybugdb.Connection))
|
||||
|
||||
(set! *warn-on-reflection* true)
|
||||
|
||||
(def ^:private supported-change-types
|
||||
#{:add-obj :mod-obj :del-obj
|
||||
:add-page :del-page :mod-page :mov-objects
|
||||
:add-component :mod-component :del-component
|
||||
:restore-component :purge-component})
|
||||
|
||||
(defn- shape-table
|
||||
[shape]
|
||||
(nodes/table-for-type (:type shape)))
|
||||
|
||||
(defn- build-parent-map
|
||||
[edges]
|
||||
(into {}
|
||||
(map (fn [{:keys [from-id to-id to-table]}]
|
||||
[from-id {:parent-id to-id :parent-table to-table}]))
|
||||
edges))
|
||||
|
||||
(defn- build-children-map
|
||||
[edges]
|
||||
(reduce (fn [acc {:keys [from-id to-id]}]
|
||||
(update acc to-id (fnil conj #{}) from-id))
|
||||
{}
|
||||
edges))
|
||||
|
||||
(defn- resolve-page-id
|
||||
[shape-id parents pages]
|
||||
(loop [id shape-id]
|
||||
(cond
|
||||
(contains? pages id) id
|
||||
(get parents id) (recur (:parent-id (parents id)))
|
||||
:else nil)))
|
||||
|
||||
(defn- node-attrs-id
|
||||
[attrs]
|
||||
(cond
|
||||
(map? attrs) (or (:id attrs) (get attrs "id"))
|
||||
(and (vector? attrs) (= 2 (count attrs)))
|
||||
(let [[k v] attrs]
|
||||
(when (or (= k :id) (= k "id")) v))))
|
||||
|
||||
(defn- table-rows
|
||||
"Normalize a projection table value to a vector of attribute maps."
|
||||
[nodes table]
|
||||
(let [rows (or (get nodes table) (get nodes (keyword table)))]
|
||||
(cond
|
||||
(nil? rows) []
|
||||
(map? rows) [rows]
|
||||
(sequential? rows) (vec rows)
|
||||
:else [])))
|
||||
|
||||
(defn- document-id-from-nodes
|
||||
[nodes file-id]
|
||||
(or (some node-attrs-id (table-rows nodes "Document"))
|
||||
file-id))
|
||||
|
||||
(defn- page-index-entry
|
||||
[attrs]
|
||||
(let [id (node-attrs-id attrs)]
|
||||
[id {:id id
|
||||
:name (:name attrs)
|
||||
:index (long (:index attrs 0))}]))
|
||||
|
||||
(defn- index-pages
|
||||
[nodes]
|
||||
(into {} (map page-index-entry (table-rows nodes "Page"))))
|
||||
|
||||
(defn- component-index-entry
|
||||
[attrs]
|
||||
(let [id (node-attrs-id attrs)]
|
||||
[id {:id id
|
||||
:name (:name attrs)
|
||||
:deleted (boolean (:deleted attrs))}]))
|
||||
|
||||
(defn- index-components
|
||||
[nodes]
|
||||
(into {} (map component-index-entry (table-rows nodes "Component"))))
|
||||
|
||||
(defn- shape-index-table?
|
||||
[table]
|
||||
(not (contains? #{"Document" "Page" "Component"
|
||||
:Document :Page :Component}
|
||||
table)))
|
||||
|
||||
(defn- shape-index-entry
|
||||
[table attrs parents pages edges]
|
||||
(let [shape-id (node-attrs-id attrs)
|
||||
{:keys [parent-id parent-table]} (parents shape-id)
|
||||
edge (first (filter #(= shape-id (:from-id %)) edges))]
|
||||
[shape-id {:id shape-id
|
||||
:name (:name attrs)
|
||||
:table table
|
||||
:parent-id parent-id
|
||||
:parent-table parent-table
|
||||
:position (long (:position edge 0))
|
||||
:frame-id (:frame-id attrs)
|
||||
;; The projection already denormalized these; re-deriving
|
||||
;; page-id from the parent chain would only be a second way to
|
||||
;; get the same answer. `:component-ctx` is what later
|
||||
;; `:add-obj` children inherit — it is the shape's effective
|
||||
;; component-id, which loses the barrier case of a *non-Frame*
|
||||
;; carrying its own `component-id` (indistinguishable once
|
||||
;; denormalized). Cold projection keeps the distinction. Only a
|
||||
;; graph synced across such a shape can drift, and a Reload
|
||||
;; rebuilds it.
|
||||
:component-ctx (:component-id attrs)
|
||||
:page-id (or (:page-id attrs)
|
||||
(resolve-page-id shape-id parents pages))}]))
|
||||
|
||||
(defn- index-shapes
|
||||
[nodes edges parents pages]
|
||||
(reduce
|
||||
(fn [acc [table _]]
|
||||
(into acc (map #(shape-index-entry table % parents pages edges)
|
||||
(table-rows nodes table))))
|
||||
{}
|
||||
(filter (fn [[table _]] (shape-index-table? table)) nodes)))
|
||||
|
||||
(defn build-index
|
||||
"Build a sync index from a full graph projection."
|
||||
[file-id revn {:keys [nodes edges]}]
|
||||
(let [doc-id (document-id-from-nodes nodes file-id)
|
||||
pages (index-pages nodes)
|
||||
components (index-components nodes)
|
||||
parents (build-parent-map edges)
|
||||
children-index (build-children-map edges)
|
||||
shapes (index-shapes nodes edges parents pages)]
|
||||
{:file-id file-id
|
||||
:doc-id doc-id
|
||||
:revn (long revn)
|
||||
:pages pages
|
||||
:components components
|
||||
:shapes shapes
|
||||
:children children-index}))
|
||||
|
||||
|
||||
(defn- format-node-value
|
||||
[table k v]
|
||||
(nodes/format-column-value table k v))
|
||||
|
||||
(defn- create-node-statement
|
||||
[table attrs]
|
||||
(let [label (nodes/match-label table)
|
||||
pairs (for [k (nodes/column-keys table)
|
||||
:let [v (get attrs k)]
|
||||
:when (some? v)]
|
||||
(str (nodes/cypher-property-key table k) ": "
|
||||
(format-node-value table k v)))]
|
||||
(str "CREATE (:" label " {" (str/join ", " pairs) "});")))
|
||||
|
||||
(defn- delete-node-statement
|
||||
[table shape-id]
|
||||
(str "MATCH (n:" (nodes/match-label table) " {id: " (ladybug/format-uuid shape-id) "}) "
|
||||
"DETACH DELETE n;"))
|
||||
|
||||
(defn- create-edge-statement
|
||||
[{:keys [from-table from-id to-table to-id position]}]
|
||||
(str "MATCH (s:" (nodes/match-label from-table) " {id: " (ladybug/format-uuid from-id) "}), "
|
||||
"(p:" (nodes/match-label to-table) " {id: " (ladybug/format-uuid to-id) "}) "
|
||||
"CREATE (s)-[:IsChildOf {position: " (ladybug/format-int position) "}]->(p);"))
|
||||
|
||||
(defn- create-instance-of-statement
|
||||
"Link a Frame instance head to its Component.
|
||||
|
||||
No-op when the Component is absent (e.g. library component not ingested)."
|
||||
[frame-id component-id]
|
||||
(str "MATCH (f:Frame {id: " (ladybug/format-uuid frame-id) "}), "
|
||||
"(c:Component {id: " (ladybug/format-uuid component-id) "}) "
|
||||
"WHERE NOT COALESCE(c.deleted, false) "
|
||||
"MERGE (f)-[:IsInstanceOf]->(c);"))
|
||||
|
||||
(defn- delete-instance-of-statement
|
||||
[frame-id]
|
||||
(str "MATCH (f:Frame {id: " (ladybug/format-uuid frame-id) "})"
|
||||
"-[r:IsInstanceOf]->(:Component) "
|
||||
"DELETE r;"))
|
||||
|
||||
(defn- instance-of-statements
|
||||
"Cypher to (re)link `IsInstanceOf` after add/mod of a Frame's component-id."
|
||||
[table shape-id component-id]
|
||||
(when (= table "Frame")
|
||||
(cond-> [(delete-instance-of-statement shape-id)]
|
||||
(some? component-id)
|
||||
(conj (create-instance-of-statement shape-id component-id)))))
|
||||
|
||||
(defn- delete-edge-statement
|
||||
[{:keys [from-table from-id to-table to-id]}]
|
||||
(str "MATCH (s:" (nodes/match-label from-table) " {id: " (ladybug/format-uuid from-id) "})"
|
||||
"-[r:IsChildOf]->"
|
||||
"(p:" (nodes/match-label to-table) " {id: " (ladybug/format-uuid to-id) "}) "
|
||||
"DELETE r;"))
|
||||
|
||||
(defn- set-edge-position-statement
|
||||
[{:keys [from-table from-id to-table to-id position]}]
|
||||
(str "MATCH (s:" (nodes/match-label from-table) " {id: " (ladybug/format-uuid from-id) "})"
|
||||
"-[r:IsChildOf]->"
|
||||
"(p:" (nodes/match-label to-table) " {id: " (ladybug/format-uuid to-id) "}) "
|
||||
"SET r.position = " (ladybug/format-int position) ";"))
|
||||
|
||||
(defn- set-node-attr-statement
|
||||
[table shape-id attr value]
|
||||
(str "MATCH (s:" (nodes/match-label table) " {id: " (ladybug/format-uuid shape-id) "}) "
|
||||
"SET s." (nodes/cypher-property-key table attr) " = "
|
||||
(format-node-value table attr value) ";"))
|
||||
|
||||
(defn- set-page-name-statement
|
||||
[page-id name]
|
||||
(str "MATCH (p:Page {id: " (ladybug/format-uuid page-id) "}) "
|
||||
"SET p.name = " (ladybug/format-string name) ";"))
|
||||
|
||||
(defn- remove-node-attr-statement
|
||||
"Clear a property. Ladybug has no Neo4j-style REMOVE; SET to NULL."
|
||||
[table shape-id attr]
|
||||
(str "MATCH (s:" (nodes/match-label table) " {id: " (ladybug/format-uuid shape-id) "}) "
|
||||
"SET s." (nodes/cypher-property-key table attr) " = NULL;"))
|
||||
|
||||
(defn- index-add-component!
|
||||
[index {:keys [id name doc-id]}]
|
||||
(-> index
|
||||
(assoc-in [:components id] {:id id :name name :deleted false})
|
||||
(update :children update doc-id (fnil conj #{}) id)))
|
||||
|
||||
(defn- index-remove-component!
|
||||
[index component-id]
|
||||
(let [doc-id (:doc-id index)]
|
||||
(-> index
|
||||
(update :components dissoc component-id)
|
||||
(update :children update doc-id #(disj (or % #{}) component-id)))))
|
||||
|
||||
|
||||
(defn- set-document-revision-statement
|
||||
"Set the Document's revision number.
|
||||
|
||||
`app.graph.schema.contract` names the column `revision`, not `revn`. The name
|
||||
is produced by `nodes/cypher-property-key`, so this statement and the DDL
|
||||
cannot disagree."
|
||||
[doc-id revn]
|
||||
(str "MATCH (d:Document {id: " (ladybug/format-uuid doc-id) "}) "
|
||||
"SET d." (nodes/cypher-property-key "Document" :revn) " = "
|
||||
(ladybug/format-int revn) ";"))
|
||||
|
||||
(defn- resolve-parent-for-add
|
||||
[index {:keys [parent-id frame-id page-id]}]
|
||||
(let [pid (or parent-id frame-id)]
|
||||
(if (or (nil? pid) (uuid/zero? pid))
|
||||
(when page-id
|
||||
{:parent-id page-id :parent-table "Page"})
|
||||
(if-let [shape (get-in index [:shapes pid])]
|
||||
{:parent-id pid :parent-table (:table shape)}
|
||||
(when (get-in index [:pages pid])
|
||||
{:parent-id pid :parent-table "Page"})))))
|
||||
|
||||
(defn- index-add-shape!
|
||||
[index {:keys [id name table parent-id parent-table position page-id
|
||||
frame-id component-ctx]}]
|
||||
(-> index
|
||||
(assoc-in [:shapes id]
|
||||
{:id id
|
||||
:name name
|
||||
:table table
|
||||
:parent-id parent-id
|
||||
:parent-table parent-table
|
||||
:position position
|
||||
:frame-id frame-id
|
||||
:component-ctx component-ctx
|
||||
:page-id page-id})
|
||||
(update :children update parent-id (fnil conj #{}) id)))
|
||||
|
||||
(defn- index-remove-shape!
|
||||
[index shape-id]
|
||||
(if-let [shape (get-in index [:shapes shape-id])]
|
||||
(-> index
|
||||
(update :shapes dissoc shape-id)
|
||||
(update :children update (:parent-id shape)
|
||||
#(disj (or % #{}) shape-id))
|
||||
(update :children dissoc shape-id))
|
||||
index))
|
||||
|
||||
(defn- index-add-page!
|
||||
[index {:keys [id name doc-id] page-index :index}]
|
||||
(-> index
|
||||
(assoc-in [:pages id] {:id id :name name :index page-index})
|
||||
(update :children update doc-id (fnil conj #{}) id)))
|
||||
|
||||
(defn- index-move-shape!
|
||||
[index shape-id {:keys [parent-id parent-table position page-id frame-id]}]
|
||||
(let [old-parent (get-in index [:shapes shape-id :parent-id])]
|
||||
(-> index
|
||||
(assoc-in [:shapes shape-id :parent-id] parent-id)
|
||||
(assoc-in [:shapes shape-id :parent-table] parent-table)
|
||||
(assoc-in [:shapes shape-id :position] position)
|
||||
(assoc-in [:shapes shape-id :frame-id] frame-id)
|
||||
(cond-> page-id (assoc-in [:shapes shape-id :page-id] page-id))
|
||||
(update :children update old-parent #(disj (or % #{}) shape-id))
|
||||
(update :children update parent-id (fnil conj #{}) shape-id))))
|
||||
|
||||
;; --- the columns that restate parenthood
|
||||
;;
|
||||
;; A shape carries `parent_id` and `frame_id`, and a container carries the
|
||||
;; ordered `shapes` list. All three restate what `IsChildOf` already says, and
|
||||
;; the cold projection writes them from the file, so this path has to keep
|
||||
;; them in step or a synced graph stops matching a rebuilt one.
|
||||
|
||||
(defn- shape-parent-id
|
||||
"The `parent_id` a shape's own column holds.
|
||||
|
||||
A top-level shape's parent in the file is the page's root frame, which the
|
||||
graph does not materialize, so `IsChildOf` points at the Page while the
|
||||
column holds `uuid/zero`."
|
||||
[parent-id parent-table]
|
||||
(if (= "Page" parent-table) uuid/zero parent-id))
|
||||
|
||||
(defn- frame-id-under
|
||||
"The `frame_id` a shape gets when its parent is `parent-id`.
|
||||
|
||||
Penpot's rule, from `app.common.files.changes` `:mov-objects`: the parent
|
||||
itself when the parent is a Frame, the parent's own frame otherwise."
|
||||
[index parent-id parent-table]
|
||||
(cond
|
||||
(= "Page" parent-table) uuid/zero
|
||||
(= "Frame" parent-table) parent-id
|
||||
:else (get-in index [:shapes parent-id :frame-id] uuid/zero)))
|
||||
|
||||
(defn- frame-id-updates
|
||||
"`[shape-id frame-id]` for a moved shape and everything that follows it.
|
||||
|
||||
A Frame keeps its descendants pointing at itself, so the walk stops there.
|
||||
Any other shape carries its subtree onto the new frame."
|
||||
[index shape-id frame-id]
|
||||
(into [[shape-id frame-id]]
|
||||
(when (not= "Frame" (get-in index [:shapes shape-id :table]))
|
||||
(mapcat #(frame-id-updates index % frame-id)
|
||||
(get-in index [:children shape-id] #{})))))
|
||||
|
||||
(defn- child-shapes-value
|
||||
"A container's stored `shapes` list, rebuilt from the index.
|
||||
|
||||
`IsChildOf.position` counts from the last entry of that list
|
||||
(`app.graph.projection.document/child-shape-ids` reverses it), so reversing the
|
||||
children ordered by position gives the list back."
|
||||
[index parent-id]
|
||||
(->> (get-in index [:children parent-id] #{})
|
||||
(sort-by #(get-in index [:shapes % :position] 0))
|
||||
reverse
|
||||
vec))
|
||||
|
||||
(defn- insert-position
|
||||
"The graph position the lowest of `k` shapes takes when they are inserted
|
||||
into a parent that already holds `n-before` children.
|
||||
|
||||
A container's stored `:shapes` list runs bottom to top, and the graph
|
||||
numbers children in Penpot z-order, so the two run opposite ways. An append
|
||||
to the stored list, which is what `:add-obj` does without an `:index`, is
|
||||
therefore position 0 and pushes every sibling up by one. The block occupies
|
||||
the result and the `k - 1` positions above it, the first shape highest."
|
||||
[n-before {:keys [index]} after-position]
|
||||
(cond
|
||||
(some? after-position) (long after-position)
|
||||
(some? index) (max 0 (- n-before (long index)))
|
||||
:else 0))
|
||||
|
||||
(defn- renumber-siblings
|
||||
"Shift `parent-id`'s children at or above `from` by `delta`.
|
||||
|
||||
Returns `[index statements]`. `except` names children the caller is placing
|
||||
itself."
|
||||
[index parent-id parent-table from delta except]
|
||||
(reduce
|
||||
(fn [[idx stmts] child-id]
|
||||
(let [pos (get-in idx [:shapes child-id :position])]
|
||||
(if (and (some? pos) (not (contains? except child-id)) (>= (long pos) (long from)))
|
||||
(let [pos' (+ (long pos) (long delta))]
|
||||
[(assoc-in idx [:shapes child-id :position] pos')
|
||||
(conj stmts (set-edge-position-statement
|
||||
{:from-table (get-in idx [:shapes child-id :table])
|
||||
:from-id child-id
|
||||
:to-table parent-table
|
||||
:to-id parent-id
|
||||
:position pos'}))])
|
||||
[idx stmts])))
|
||||
[index []]
|
||||
(vec (get-in index [:children parent-id] #{}))))
|
||||
|
||||
(defn- set-children-statements
|
||||
"Refresh the `shapes` column of every container in `parent-ids`.
|
||||
|
||||
A Page has no such column: its top-level shapes hang off a root frame the
|
||||
graph never materializes."
|
||||
[index parent-ids]
|
||||
(into []
|
||||
(comp (distinct)
|
||||
(keep (fn [parent-id]
|
||||
(let [table (get-in index [:shapes parent-id :table])]
|
||||
(when (contains? nodes/container-tables table)
|
||||
(set-node-attr-statement
|
||||
table parent-id :shapes
|
||||
(child-shapes-value index parent-id)))))))
|
||||
parent-ids))
|
||||
|
||||
(defn- mov-object-ids
|
||||
[shapes]
|
||||
(let [coll (cond
|
||||
(nil? shapes) []
|
||||
(sequential? shapes) shapes
|
||||
(uuid? shapes) [shapes]
|
||||
(map? shapes) (if-let [id (or (:id shapes) (get shapes "id"))]
|
||||
[id]
|
||||
[])
|
||||
:else [])]
|
||||
(into []
|
||||
(keep (fn [shape]
|
||||
(when shape
|
||||
(if (uuid? shape) shape (:id shape)))))
|
||||
coll)))
|
||||
|
||||
(defn- detach-shape
|
||||
"Take `shape-id` out of its current parent and close the gap it leaves.
|
||||
|
||||
Returns `[index statements]`. The edge itself is left alone: the caller
|
||||
either replaces it or deletes it."
|
||||
[index shape-id]
|
||||
(let [{:keys [parent-id parent-table position]} (get-in index [:shapes shape-id])
|
||||
index (update-in index [:children parent-id] #(disj (or % #{}) shape-id))
|
||||
[index stmts] (renumber-siblings index parent-id parent-table
|
||||
(inc (long (or position 0))) -1 #{})]
|
||||
[(assoc-in index [:shapes shape-id :position] nil) stmts]))
|
||||
|
||||
(defn- apply-mov-objects
|
||||
[index {:keys [shapes page-id] :as change}]
|
||||
(let [shape-ids (mov-object-ids shapes)
|
||||
parent (resolve-parent-for-add index
|
||||
(assoc change
|
||||
:frame-id (:parent-id change)
|
||||
:page-id page-id))]
|
||||
(cond
|
||||
(empty? shape-ids)
|
||||
{:index index :statements [] :applied? true}
|
||||
|
||||
(not parent)
|
||||
{:index index :statements [] :applied? false :reason :missing-parent}
|
||||
|
||||
:else
|
||||
(let [parent-id (:parent-id parent)
|
||||
parent-table (:parent-table parent)
|
||||
page-id' (or page-id
|
||||
(when (= parent-table "Page") parent-id)
|
||||
(get-in index [:shapes (first shape-ids) :page-id]))
|
||||
known (filterv #(get-in index [:shapes %]) shape-ids)
|
||||
old-parents (mapv #(get-in index [:shapes % :parent-id]) known)
|
||||
;; Penpot removes the shapes from wherever they were, then inserts
|
||||
;; the block into the target, so the target's width is measured
|
||||
;; after the removals.
|
||||
[index detach-stmts]
|
||||
(reduce (fn [[idx stmts] shape-id]
|
||||
(let [[idx' s] (detach-shape idx shape-id)]
|
||||
[idx' (into stmts s)]))
|
||||
[index []]
|
||||
known)
|
||||
n-before (count (get-in index [:children parent-id] #{}))
|
||||
after-pos (get-in index [:shapes (:after-shape change) :position])
|
||||
lowest (insert-position n-before change after-pos)
|
||||
k (count known)
|
||||
[index shift-stmts]
|
||||
(renumber-siblings index parent-id parent-table lowest k #{})]
|
||||
(loop [index index
|
||||
statements (into detach-stmts shift-stmts)
|
||||
entries (map-indexed vector known)]
|
||||
(if-let [[offset shape-id] (first entries)]
|
||||
(let [shape (get-in index [:shapes shape-id])
|
||||
position (+ lowest (- k 1 (long offset)))
|
||||
frame-id (frame-id-under index parent-id parent-table)
|
||||
frame-writes (frame-id-updates index shape-id frame-id)
|
||||
edge {:from-table (:table shape)
|
||||
:from-id shape-id
|
||||
:to-table parent-table
|
||||
:to-id parent-id
|
||||
:position position}
|
||||
moved? (not= parent-id (:parent-id shape))
|
||||
statements (-> statements
|
||||
(cond-> moved?
|
||||
(conj (delete-edge-statement
|
||||
{:from-table (:table shape)
|
||||
:from-id shape-id
|
||||
:to-table (:parent-table shape)
|
||||
:to-id (:parent-id shape)})))
|
||||
(conj (if moved?
|
||||
(create-edge-statement edge)
|
||||
(set-edge-position-statement edge))))
|
||||
;; The shape's own columns restate the edge, and the frame
|
||||
;; follows the whole subtree the shape carries with it.
|
||||
statements (if-not moved?
|
||||
statements
|
||||
(into (conj statements
|
||||
(set-node-attr-statement
|
||||
(:table shape) shape-id :parent-id
|
||||
(shape-parent-id parent-id parent-table)))
|
||||
(map (fn [[sid fid]]
|
||||
(set-node-attr-statement
|
||||
(get-in index [:shapes sid :table])
|
||||
sid :frame-id fid)))
|
||||
frame-writes))
|
||||
index (index-move-shape! index shape-id
|
||||
{:parent-id parent-id
|
||||
:parent-table parent-table
|
||||
:position position
|
||||
:frame-id frame-id
|
||||
:page-id page-id'})
|
||||
index (reduce (fn [idx [sid fid]]
|
||||
(assoc-in idx [:shapes sid :frame-id] fid))
|
||||
index
|
||||
frame-writes)]
|
||||
(recur index statements (rest entries)))
|
||||
{:index index
|
||||
:statements (into statements
|
||||
(set-children-statements index (conj old-parents parent-id)))
|
||||
:applied? true}))))))
|
||||
|
||||
(defn- index-remove-page!
|
||||
[index page-id]
|
||||
(let [doc-id (:doc-id index)]
|
||||
(-> index
|
||||
(update :pages dissoc page-id)
|
||||
(update :children update doc-id #(disj (or % #{}) page-id))
|
||||
(update :children dissoc page-id))))
|
||||
|
||||
(defn- mod-attrs-for-table
|
||||
[table]
|
||||
(disj (set (nodes/column-keys table)) :id))
|
||||
|
||||
(defn- apply-add-obj
|
||||
[index change]
|
||||
(let [{:keys [id obj page-id]} change
|
||||
table (shape-table obj)]
|
||||
(if-not table
|
||||
{:index index :statements [] :applied? false :reason :unsupported-shape-type}
|
||||
(let [parent (resolve-parent-for-add index change)]
|
||||
(if-not parent
|
||||
{:index index :statements [] :applied? false :reason :missing-parent}
|
||||
(let [parent-id (:parent-id parent)
|
||||
parent-table (:parent-table parent)
|
||||
n-before (count (get-in index [:children parent-id] #{}))
|
||||
position (insert-position n-before change nil)
|
||||
[index shift-stmts]
|
||||
(renumber-siblings index parent-id parent-table position 1 #{})
|
||||
;; The same denormalizations the cold projection performs, so
|
||||
;; a live-synced graph and a rebuilt one carry equal columns.
|
||||
resolved-page-id
|
||||
(or page-id
|
||||
(when (= parent-table "Page") parent-id)
|
||||
(get-in index [:shapes parent-id :page-id]))
|
||||
parent-ctx (get-in index [:shapes parent-id :component-ctx])
|
||||
shape (projection.document/denormalized-shape
|
||||
(assoc obj :id id) resolved-page-id parent-ctx)
|
||||
attrs (nodes/project-attrs table shape)
|
||||
edge {:from-table table
|
||||
:from-id id
|
||||
:to-table parent-table
|
||||
:to-id parent-id
|
||||
:position position}
|
||||
stmts (-> shift-stmts
|
||||
(conj (create-node-statement table attrs))
|
||||
(conj (create-edge-statement edge))
|
||||
(into (instance-of-statements table id (:component-id attrs))))
|
||||
index' (index-add-shape! index
|
||||
{:id id
|
||||
:name (:name attrs)
|
||||
:table table
|
||||
:parent-id parent-id
|
||||
:parent-table parent-table
|
||||
:position position
|
||||
:frame-id (:frame-id attrs)
|
||||
:component-ctx (projection.document/descend-component-ctx
|
||||
table shape parent-ctx)
|
||||
:page-id resolved-page-id})]
|
||||
{:index index'
|
||||
:statements (into stmts (set-children-statements index' [parent-id]))
|
||||
:applied? true}))))))
|
||||
|
||||
(defn- apply-mod-obj
|
||||
[index {:keys [id operations]}]
|
||||
(if-let [shape (get-in index [:shapes id])]
|
||||
(let [table (:table shape)
|
||||
syncable (mod-attrs-for-table table)
|
||||
set-ops (filter #(and (= :set (:type %))
|
||||
(contains? syncable (:attr %)))
|
||||
operations)]
|
||||
(if (empty? set-ops)
|
||||
{:index index :statements [] :applied? false :reason :unsupported-operations}
|
||||
(let [updates (into {} (map (juxt :attr :val) set-ops))
|
||||
statements
|
||||
(into (vec (for [[attr value] updates]
|
||||
(set-node-attr-statement table id attr value)))
|
||||
;; Relink when component-id is among the synced attrs.
|
||||
(when (contains? updates :component-id)
|
||||
(instance-of-statements table id (:component-id updates))))
|
||||
index' (reduce (fn [idx [attr value]]
|
||||
(assoc-in idx [:shapes id attr] value))
|
||||
index
|
||||
updates)]
|
||||
{:index index'
|
||||
:statements statements
|
||||
:applied? true})))
|
||||
{:index index :statements [] :applied? false :reason :missing-shape}))
|
||||
|
||||
(defn- delete-order-deepest-first
|
||||
[children root-id]
|
||||
(letfn [(post-order [id]
|
||||
(into (mapcat post-order (get children id #{}))
|
||||
[id]))]
|
||||
(post-order root-id)))
|
||||
|
||||
(defn- apply-del-obj
|
||||
[index {:keys [id]}]
|
||||
(if-let [root (get-in index [:shapes id])]
|
||||
(let [to-delete (delete-order-deepest-first (:children index) id)
|
||||
statements
|
||||
(vec (mapcat (fn [shape-id]
|
||||
(let [{:keys [table parent-id parent-table]}
|
||||
(get-in index [:shapes shape-id])]
|
||||
[(delete-edge-statement
|
||||
{:from-table table
|
||||
:from-id shape-id
|
||||
:to-table parent-table
|
||||
:to-id parent-id})
|
||||
(delete-node-statement table shape-id)]))
|
||||
to-delete))
|
||||
index' (reduce index-remove-shape! index to-delete)
|
||||
;; Only the deleted subtree's own parent survives to be renumbered:
|
||||
;; every other parent in `to-delete` goes with it.
|
||||
[index' shift-stmts]
|
||||
(renumber-siblings index' (:parent-id root) (:parent-table root)
|
||||
(inc (long (or (:position root) 0))) -1 #{})]
|
||||
{:index index'
|
||||
:statements (-> statements
|
||||
(into shift-stmts)
|
||||
(into (set-children-statements index' [(:parent-id root)])))
|
||||
:applied? true})
|
||||
;; Penpot emits one :del-obj per selected shape; an earlier change in the
|
||||
;; same batch may have already removed this node (e.g. parent + child).
|
||||
{:index index :statements [] :applied? true}))
|
||||
|
||||
(defn- apply-add-page
|
||||
[index {:keys [id name page]}]
|
||||
(let [page-id (or id (:id page))
|
||||
page (or page {:id page-id :name name})
|
||||
page (nodes/project-attrs "Page" {:id page-id
|
||||
:name (or (:name page) "Page")
|
||||
:index (count (:pages index))})
|
||||
doc-id (:doc-id index)
|
||||
position (count (:pages index))
|
||||
edge {:from-table "Page"
|
||||
:from-id page-id
|
||||
:to-table "Document"
|
||||
:to-id doc-id
|
||||
:position position}]
|
||||
{:index (index-add-page! index
|
||||
{:id page-id
|
||||
:name (:name page)
|
||||
:index (:index page)
|
||||
:doc-id doc-id})
|
||||
:statements [(create-node-statement "Page" page)
|
||||
(create-edge-statement edge)]
|
||||
:applied? true}))
|
||||
|
||||
(defn- apply-del-page
|
||||
[index {:keys [id]}]
|
||||
(if (get-in index [:pages id])
|
||||
(let [shape-ids (into #{}
|
||||
(comp (filter #(= id (get-in index [:shapes % :page-id])))
|
||||
(filter #(= "Page" (get-in index [:shapes % :parent-table]))))
|
||||
(keys (:shapes index)))
|
||||
del-shapes
|
||||
(reduce (fn [acc shape-id]
|
||||
(let [result (apply-del-obj acc {:type :del-obj :id shape-id})]
|
||||
(if (:applied? result)
|
||||
(-> acc
|
||||
(assoc :index (:index result))
|
||||
(update :statements into (:statements result)))
|
||||
acc)))
|
||||
{:index index :statements []}
|
||||
shape-ids)
|
||||
statements
|
||||
(conj (:statements del-shapes)
|
||||
(delete-edge-statement {:from-table "Page"
|
||||
:from-id id
|
||||
:to-table "Document"
|
||||
:to-id (:doc-id index)})
|
||||
(delete-node-statement "Page" id))]
|
||||
{:index (-> (:index del-shapes) (index-remove-page! id))
|
||||
:statements statements
|
||||
:applied? true})
|
||||
{:index index :statements [] :applied? false :reason :missing-page}))
|
||||
|
||||
(defn- apply-mod-page
|
||||
[index {:keys [id name]}]
|
||||
(if (and (string? name) (get-in index [:pages id]))
|
||||
{:index (assoc-in index [:pages id :name] name)
|
||||
:statements [(set-page-name-statement id name)]
|
||||
:applied? true}
|
||||
{:index index :statements [] :applied? false :reason :unsupported-page-change}))
|
||||
|
||||
(defn- component-syncable-attrs
|
||||
"Projected Component columns that sync may SET (everything but :id)."
|
||||
[]
|
||||
(disj (set (nodes/column-keys "Component")) :id))
|
||||
|
||||
(defn- component-attrs-from-change
|
||||
"Build CREATE attrs for `:add-component` (objects are not projected)."
|
||||
[{:keys [id name path main-instance-id main-instance-page
|
||||
annotation variant-id variant-properties]}]
|
||||
(cond-> {:id id
|
||||
:name (or name "Component")
|
||||
:path (or path "")
|
||||
:main-instance-id main-instance-id
|
||||
:main-instance-page main-instance-page}
|
||||
(some? annotation) (assoc :annotation annotation)
|
||||
(some? variant-id) (assoc :variant-id variant-id)
|
||||
(seq variant-properties) (assoc :variant-properties variant-properties)))
|
||||
|
||||
(defn- apply-add-component
|
||||
[index {:keys [id] :as change}]
|
||||
(if (get-in index [:components id])
|
||||
{:index index :statements [] :applied? true}
|
||||
(let [doc-id (:doc-id index)
|
||||
position (count (:components index))
|
||||
attrs (nodes/project-attrs "Component" (component-attrs-from-change change))
|
||||
edge {:from-table "Component"
|
||||
:from-id id
|
||||
:to-table "Document"
|
||||
:to-id doc-id
|
||||
:position position}]
|
||||
{:index (index-add-component! index
|
||||
{:id id
|
||||
:name (:name attrs)
|
||||
:doc-id doc-id})
|
||||
:statements [(create-node-statement "Component" attrs)
|
||||
(create-edge-statement edge)]
|
||||
:applied? true})))
|
||||
|
||||
(defn- apply-mod-component
|
||||
"Update projected Component attrs from a `:mod-component` change.
|
||||
|
||||
Nil optional values clear the property (Penpot dissocs them). `:objects`
|
||||
is never projected — shape trees live on pages."
|
||||
[index {:keys [id] :as change}]
|
||||
(let [syncable (component-syncable-attrs)
|
||||
sets (into {}
|
||||
(keep (fn [[k v]]
|
||||
(when (and (contains? syncable k) (some? v))
|
||||
[k v])))
|
||||
(dissoc change :type :id :objects))
|
||||
removes (into []
|
||||
(keep (fn [[k v]]
|
||||
(when (and (contains? syncable k) (nil? v))
|
||||
k)))
|
||||
(dissoc change :type :id :objects))
|
||||
stmts (into (mapv (fn [[k v]]
|
||||
(set-node-attr-statement "Component" id k v))
|
||||
sets)
|
||||
(map #(remove-node-attr-statement "Component" id %) removes))
|
||||
index' (if (get-in index [:components id])
|
||||
(cond-> index
|
||||
(contains? sets :name)
|
||||
(assoc-in [:components id :name] (:name sets)))
|
||||
(assoc-in index [:components id]
|
||||
{:id id
|
||||
:name (:name sets)
|
||||
:deleted false}))]
|
||||
(if (empty? stmts)
|
||||
{:index index :statements [] :applied? true}
|
||||
{:index index' :statements stmts :applied? true})))
|
||||
|
||||
(defn- apply-del-component
|
||||
[index {:keys [id skip-undelete?]}]
|
||||
(cond
|
||||
(not (get-in index [:components id]))
|
||||
{:index index :statements [] :applied? true}
|
||||
|
||||
skip-undelete?
|
||||
{:index (index-remove-component! index id)
|
||||
:statements [(delete-edge-statement {:from-table "Component"
|
||||
:from-id id
|
||||
:to-table "Document"
|
||||
:to-id (:doc-id index)})
|
||||
(delete-node-statement "Component" id)]
|
||||
:applied? true}
|
||||
|
||||
:else
|
||||
{:index (assoc-in index [:components id :deleted] true)
|
||||
:statements [(set-node-attr-statement "Component" id :deleted true)]
|
||||
:applied? true}))
|
||||
|
||||
(defn- apply-restore-component
|
||||
[index {:keys [id page-id]}]
|
||||
(let [stmts (cond-> [(set-node-attr-statement "Component" id :deleted false)]
|
||||
page-id
|
||||
(conj (set-node-attr-statement "Component" id :main-instance-page page-id)))
|
||||
index (if (get-in index [:components id])
|
||||
(-> index
|
||||
(assoc-in [:components id :deleted] false)
|
||||
(cond-> page-id
|
||||
(assoc-in [:components id :main-instance-page] page-id)))
|
||||
(assoc-in index [:components id]
|
||||
{:id id :name nil :deleted false}))]
|
||||
{:index index :statements stmts :applied? true}))
|
||||
|
||||
(defn- apply-purge-component
|
||||
[index {:keys [id]}]
|
||||
(if-not (get-in index [:components id])
|
||||
;; Still attempt delete in case the node exists but was not indexed.
|
||||
{:index index
|
||||
:statements [(delete-edge-statement {:from-table "Component"
|
||||
:from-id id
|
||||
:to-table "Document"
|
||||
:to-id (:doc-id index)})
|
||||
(delete-node-statement "Component" id)]
|
||||
:applied? true}
|
||||
{:index (index-remove-component! index id)
|
||||
:statements [(delete-edge-statement {:from-table "Component"
|
||||
:from-id id
|
||||
:to-table "Document"
|
||||
:to-id (:doc-id index)})
|
||||
(delete-node-statement "Component" id)]
|
||||
:applied? true}))
|
||||
|
||||
(defn- apply-change
|
||||
[index change]
|
||||
(case (:type change)
|
||||
:add-obj (apply-add-obj index change)
|
||||
:mod-obj (apply-mod-obj index change)
|
||||
:del-obj (apply-del-obj index change)
|
||||
:add-page (apply-add-page index change)
|
||||
:del-page (apply-del-page index change)
|
||||
:mod-page (apply-mod-page index change)
|
||||
:mov-objects (apply-mov-objects index change)
|
||||
:add-component (apply-add-component index change)
|
||||
:mod-component (apply-mod-component index change)
|
||||
:del-component (apply-del-component index change)
|
||||
:restore-component (apply-restore-component index change)
|
||||
:purge-component (apply-purge-component index change)
|
||||
{:index index :statements [] :applied? false :reason :unsupported-type}))
|
||||
|
||||
(defn apply-changes!
|
||||
"Apply Penpot `changes` to an open Ladybug `conn` and return the updated index.
|
||||
|
||||
Returns `{:index ... :revn ... :applied [...] :skipped [...]}`."
|
||||
[^Connection conn index changes revn]
|
||||
(when (> (long revn) (:revn index))
|
||||
(l/wrn :hint "graph sync revn gap"
|
||||
:file-id (str (:file-id index))
|
||||
:index-revn (:revn index)
|
||||
:change-revn revn))
|
||||
(loop [index index
|
||||
applied []
|
||||
skipped []
|
||||
stmts []
|
||||
changes (seq changes)]
|
||||
(if-let [change (first changes)]
|
||||
(let [{:keys [index statements applied? reason]}
|
||||
(apply-change index change)]
|
||||
(recur index
|
||||
(cond-> applied applied? (conj (:type change)))
|
||||
(cond-> skipped (not applied?) (conj {:type (:type change) :reason reason}))
|
||||
(cond-> stmts applied? (into statements))
|
||||
(rest changes)))
|
||||
(let [final-stmts (cond-> stmts
|
||||
(and (seq applied) (:doc-id index))
|
||||
(conj (set-document-revision-statement (:doc-id index) revn)))
|
||||
index' (if (seq applied)
|
||||
(assoc index :revn (long revn))
|
||||
index)]
|
||||
(when (seq final-stmts)
|
||||
(ladybug/exec-on-connection! conn final-stmts))
|
||||
{:index index'
|
||||
:revn (if (seq applied) (long revn) (:revn index'))
|
||||
:applied applied
|
||||
:skipped skipped}))))
|
||||
|
||||
(defn supported-change?
|
||||
[change]
|
||||
(contains? supported-change-types (:type change)))
|
||||
@ -1,165 +0,0 @@
|
||||
;; 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/.
|
||||
;;
|
||||
;; Copyright (c) KALEIDOS SUBSIDIARY SL
|
||||
|
||||
(ns backend-tests.graph-binder-gate-test
|
||||
"Binder gate for the incremental-sync statement templates.
|
||||
|
||||
Every template `app.graph.sync` emits is *prepared* — parsed and bound by
|
||||
the engine against the live DDL — and never executed. A parse or bind
|
||||
failure (a renamed column, a reserved-word label emitted unquoted, a dropped
|
||||
table) turns the gate red here, before the statement can reach a live
|
||||
session.
|
||||
|
||||
One instance per template is the gate; per-column type coverage belongs to
|
||||
beadpot's schema diff, not here. The templates are `defn-`, so they are
|
||||
reached through their vars."
|
||||
(:require
|
||||
[app.graph.ladybug :as ladybug]
|
||||
[app.graph.schema.nodes :as nodes]
|
||||
[app.graph.sync]
|
||||
[clojure.test :as t]))
|
||||
|
||||
(def ^:private create-node-statement #'app.graph.sync/create-node-statement)
|
||||
(def ^:private delete-node-statement #'app.graph.sync/delete-node-statement)
|
||||
(def ^:private create-edge-statement #'app.graph.sync/create-edge-statement)
|
||||
(def ^:private delete-edge-statement #'app.graph.sync/delete-edge-statement)
|
||||
(def ^:private set-edge-position-statement #'app.graph.sync/set-edge-position-statement)
|
||||
(def ^:private create-instance-of-statement #'app.graph.sync/create-instance-of-statement)
|
||||
(def ^:private delete-instance-of-statement #'app.graph.sync/delete-instance-of-statement)
|
||||
(def ^:private set-node-attr-statement #'app.graph.sync/set-node-attr-statement)
|
||||
(def ^:private set-page-name-statement #'app.graph.sync/set-page-name-statement)
|
||||
(def ^:private remove-node-attr-statement #'app.graph.sync/remove-node-attr-statement)
|
||||
(def ^:private set-document-revision-statement #'app.graph.sync/set-document-revision-statement)
|
||||
|
||||
;; Dummy identities. Fixed rather than generated: a gate failure should read
|
||||
;; the same on every run.
|
||||
(def ^:private doc-id #uuid "00000000-0000-0000-0000-0000000000d0")
|
||||
(def ^:private page-id #uuid "00000000-0000-0000-0000-0000000000a0")
|
||||
(def ^:private shape-id #uuid "00000000-0000-0000-0000-0000000000b0")
|
||||
(def ^:private frame-id #uuid "00000000-0000-0000-0000-0000000000c0")
|
||||
(def ^:private component-id #uuid "00000000-0000-0000-0000-0000000000e0")
|
||||
|
||||
(def ^:private child-edge
|
||||
{:from-table "Rectangle" :from-id shape-id
|
||||
:to-table "Page" :to-id page-id
|
||||
:position 3})
|
||||
|
||||
(def ^:private ^:dynamic *conn* nil)
|
||||
|
||||
(defn- with-graph-connection
|
||||
"Open a `:memory:` database, create the live schema, run the tests on it.
|
||||
|
||||
Nothing is executed against it — the gate only prepares — but the DDL has to
|
||||
be there for the binder to resolve tables and columns against."
|
||||
[next]
|
||||
(ladybug/with-connection! ":memory:"
|
||||
(fn [conn]
|
||||
(ladybug/exec-on-connection! conn (nodes/ddl-statements))
|
||||
(binding [*conn* conn]
|
||||
(next)))))
|
||||
|
||||
(t/use-fixtures :once with-graph-connection)
|
||||
|
||||
(defn- gate
|
||||
"Assert `statement` binds, and that the engine agrees on read/write."
|
||||
[label statement read-only?]
|
||||
(let [result (ladybug/validate-on-connection! *conn* statement)]
|
||||
(t/is (:ok? result)
|
||||
(str label " does not bind: " (:error result) "\n " statement))
|
||||
(when (:ok? result)
|
||||
(t/is (= read-only? (:read-only? result))
|
||||
(str label " read-only? " (:read-only? result) ", expected " read-only?)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; the eleven sync templates
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(t/deftest create-node-binds
|
||||
(gate "create-node-statement"
|
||||
(create-node-statement "Rectangle" {:id shape-id
|
||||
:name "a shape"
|
||||
:opacity 1.0
|
||||
:hidden false})
|
||||
false))
|
||||
|
||||
(t/deftest delete-node-binds
|
||||
(gate "delete-node-statement"
|
||||
(delete-node-statement "Rectangle" shape-id)
|
||||
false))
|
||||
|
||||
(t/deftest create-edge-binds
|
||||
(gate "create-edge-statement"
|
||||
(create-edge-statement child-edge)
|
||||
false))
|
||||
|
||||
(t/deftest delete-edge-binds
|
||||
(gate "delete-edge-statement"
|
||||
(delete-edge-statement (dissoc child-edge :position))
|
||||
false))
|
||||
|
||||
(t/deftest set-edge-position-binds
|
||||
(gate "set-edge-position-statement"
|
||||
(set-edge-position-statement child-edge)
|
||||
false))
|
||||
|
||||
(t/deftest create-instance-of-binds
|
||||
(gate "create-instance-of-statement"
|
||||
(create-instance-of-statement frame-id component-id)
|
||||
false))
|
||||
|
||||
(t/deftest delete-instance-of-binds
|
||||
(gate "delete-instance-of-statement"
|
||||
(delete-instance-of-statement frame-id)
|
||||
false))
|
||||
|
||||
(t/deftest set-node-attr-binds
|
||||
(gate "set-node-attr-statement"
|
||||
(set-node-attr-statement "Rectangle" shape-id :name "a shape")
|
||||
false))
|
||||
|
||||
(t/deftest set-page-name-binds
|
||||
(gate "set-page-name-statement"
|
||||
(set-page-name-statement page-id "a page")
|
||||
false))
|
||||
|
||||
(t/deftest remove-node-attr-binds
|
||||
(gate "remove-node-attr-statement"
|
||||
(remove-node-attr-statement "Rectangle" shape-id :name)
|
||||
false))
|
||||
|
||||
(t/deftest set-document-revision-binds
|
||||
(gate "set-document-revision-statement"
|
||||
(set-document-revision-statement doc-id 42)
|
||||
false))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; label quoting across the registry
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(t/deftest every-node-label-binds
|
||||
;; `Group` and `Boolean` are reserved words: unquoted they do not parse.
|
||||
;; One MATCH per registered table is the cheapest way to keep `match-label`
|
||||
;; honest as tables come and go.
|
||||
(doseq [table (map :table nodes/node-types)]
|
||||
(gate (str "delete-node-statement on " table)
|
||||
(delete-node-statement table shape-id)
|
||||
false)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; the gate itself
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(t/deftest read-only-discriminates
|
||||
;; Without this the `read-only? false` assertions above would hold for a
|
||||
;; `validate-on-connection!` that always answered false.
|
||||
(gate "a read query" "MATCH (n:Rectangle) RETURN count(n);" true))
|
||||
|
||||
(t/deftest bad-statement-is-reported-not-thrown
|
||||
(let [result (ladybug/validate-on-connection!
|
||||
*conn* "MATCH (n:Rectangle) SET n.no_such_column = 1;")]
|
||||
(t/is (false? (:ok? result)))
|
||||
(t/is (string? (:error result)))
|
||||
(t/is (nil? (:read-only? result)))))
|
||||
@ -1,298 +0,0 @@
|
||||
;; 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/.
|
||||
;;
|
||||
;; Copyright (c) KALEIDOS SUBSIDIARY SL
|
||||
|
||||
(ns backend-tests.graph-sync-parity-test
|
||||
"Cold projection and incremental sync are two implementations of one mapping,
|
||||
and this namespace holds them to it.
|
||||
|
||||
`app.graph.projection.document/projection-data` reads a whole file and produces
|
||||
the whole graph. `app.graph.sync/apply-changes!` takes the change vocabulary
|
||||
the editor emits and mutates an already open graph. A graph the second one
|
||||
maintained must equal a graph the first one would build from the same file,
|
||||
or the console shows a graph no rebuild reproduces.
|
||||
|
||||
The round trip: project a file cold into A, apply a change list to A and the
|
||||
same list to the file data, project the resulting data cold into B, and diff
|
||||
A against B. Two `:memory:` databases, no Postgres, no session."
|
||||
(:require
|
||||
[app.common.features :as ffeat]
|
||||
[app.common.files.changes :as cfc]
|
||||
[app.common.time :as ct]
|
||||
[app.common.types.file :as ctf]
|
||||
[app.common.types.shape :as cts]
|
||||
[app.common.uuid :as uuid]
|
||||
[app.graph.arrow :as arrow]
|
||||
[app.graph.ingest :as ingest]
|
||||
[app.graph.ladybug :as ladybug]
|
||||
[app.graph.projection.document :as projection.document]
|
||||
[app.graph.projection.transforms :as projection.transforms]
|
||||
[app.graph.schema.nodes :as nodes]
|
||||
[app.graph.sync :as sync]
|
||||
[clojure.test :as t]))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; the fixture file
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; Fixed ids: a failure should read the same on every run.
|
||||
(def ^:private file-id #uuid "00000000-0000-0000-0000-00000000f11e")
|
||||
(def ^:private page-id #uuid "00000000-0000-0000-0000-0000000000a1")
|
||||
(def ^:private page2-id #uuid "00000000-0000-0000-0000-0000000000a2")
|
||||
(def ^:private frame-id #uuid "00000000-0000-0000-0000-0000000000f1")
|
||||
(def ^:private rect-id #uuid "00000000-0000-0000-0000-0000000000b1")
|
||||
(def ^:private circ-id #uuid "00000000-0000-0000-0000-0000000000b2")
|
||||
(def ^:private text-id #uuid "00000000-0000-0000-0000-0000000000b3")
|
||||
(def ^:private rect2-id #uuid "00000000-0000-0000-0000-0000000000b4")
|
||||
|
||||
(def ^:private base-revn 1)
|
||||
|
||||
(defn- file-row
|
||||
"The `file` map the projection reads, as `bfc/get-file` returns it minus the
|
||||
data blob."
|
||||
[revn]
|
||||
{:id file-id
|
||||
:name "graph sync parity fixture"
|
||||
:revn revn
|
||||
:version 70
|
||||
:features #{"components/v2"}
|
||||
:created-at (ct/inst "2026-01-01T00:00:00Z")
|
||||
:modified-at (ct/inst "2026-01-02T00:00:00Z")})
|
||||
|
||||
(defn- base-data
|
||||
[]
|
||||
(binding [ffeat/*current* #{"components/v2"}]
|
||||
(ctf/make-file-data file-id page-id)))
|
||||
|
||||
(defn- shape
|
||||
[id type attrs]
|
||||
(cts/setup-shape (merge {:id id
|
||||
:type type
|
||||
:frame-id uuid/zero
|
||||
:parent-id uuid/zero}
|
||||
attrs)))
|
||||
|
||||
(def ^:private changes
|
||||
"One change of every kind the sync path claims to support that this fixture
|
||||
can exercise, in the order an editing session would emit them.
|
||||
|
||||
Four siblings in one container, then a reorder, a reparent, and a delete:
|
||||
sibling order is where the two paths are easiest to get wrong, because the
|
||||
stored `:shapes` list and `IsChildOf.position` run opposite ways."
|
||||
[{:type :add-obj :page-id page-id :id frame-id
|
||||
:parent-id uuid/zero :frame-id uuid/zero
|
||||
:obj (shape frame-id :frame {:name "Board" :width 400 :height 300})}
|
||||
|
||||
{:type :add-obj :page-id page-id :id rect-id
|
||||
:parent-id frame-id :frame-id frame-id
|
||||
:obj (shape rect-id :rect {:name "Rect" :parent-id frame-id :frame-id frame-id
|
||||
:width 100 :height 50})}
|
||||
|
||||
{:type :add-obj :page-id page-id :id circ-id
|
||||
:parent-id frame-id :frame-id frame-id
|
||||
:obj (shape circ-id :circle {:name "Circle" :parent-id frame-id :frame-id frame-id
|
||||
:width 40 :height 40})}
|
||||
|
||||
{:type :add-obj :page-id page-id :id text-id
|
||||
:parent-id frame-id :frame-id frame-id
|
||||
:obj (shape text-id :text {:name "Label" :parent-id frame-id :frame-id frame-id})}
|
||||
|
||||
{:type :add-obj :page-id page-id :id rect2-id
|
||||
:parent-id frame-id :frame-id frame-id
|
||||
:obj (shape rect2-id :rect {:name "Rect two" :parent-id frame-id :frame-id frame-id
|
||||
:width 20 :height 20})}
|
||||
|
||||
;; A rename, and two attributes whose values are falsy: `blocked false` and
|
||||
;; `opacity 0` are values, not absences, on both paths.
|
||||
{:type :mod-obj :page-id page-id :id rect-id
|
||||
:operations [{:type :set :attr :name :val "Renamed rect"}
|
||||
{:type :set :attr :blocked :val false}
|
||||
{:type :set :attr :opacity :val 0}]}
|
||||
|
||||
;; Reorder inside the same container: the edge keeps its endpoints and
|
||||
;; every sibling it passes has to move.
|
||||
{:type :mov-objects :page-id page-id :parent-id frame-id :index 0 :shapes [circ-id]}
|
||||
|
||||
;; Reparent to the page's root frame: the edge moves, and so do the
|
||||
;; shape's own `parent_id` and `frame_id`.
|
||||
{:type :mov-objects :page-id page-id :parent-id uuid/zero :index 0 :shapes [text-id]}
|
||||
|
||||
;; Delete with survivors: the gap in the sibling numbering has to close.
|
||||
{:type :del-obj :page-id page-id :id rect-id}
|
||||
|
||||
{:type :add-page :id page2-id :name "Page two"}
|
||||
{:type :mod-page :id page-id :name "Page one, renamed"}])
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; projecting and reading back
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defn- load-graph!
|
||||
"Create the schema on `conn`, project `data` into it, run the transforms.
|
||||
|
||||
`allocator` must outlive `conn` — see `app.graph.arrow/with-allocator!` —
|
||||
so the caller nests the allocator outside its connections and passes it in.
|
||||
Returns the projection, which is also what the sync index is built from."
|
||||
[conn allocator data file]
|
||||
(let [projection (projection.document/projection-data data file)]
|
||||
(ladybug/exec-on-connection! conn (nodes/ddl-statements))
|
||||
(arrow/load-projection! conn projection allocator)
|
||||
(projection.transforms/apply-transforms! nil conn data file)
|
||||
projection))
|
||||
|
||||
(defn- rel-tables
|
||||
[conn]
|
||||
(mapv first (:rows (ladybug/query-on-connection!
|
||||
conn "CALL show_tables() WHERE type = 'REL' RETURN name;"
|
||||
:max-rows 1000))))
|
||||
|
||||
(defn- rel-properties
|
||||
"Property names on rel table `rel`, in catalog order."
|
||||
[conn rel]
|
||||
(mapv (comp str second)
|
||||
(:rows (ladybug/query-on-connection!
|
||||
conn (str "CALL table_info('" rel "') RETURN *;")
|
||||
:max-rows 1000))))
|
||||
|
||||
(defn- node-rows
|
||||
[conn table]
|
||||
(:rows (ladybug/query-on-connection!
|
||||
conn (str "MATCH (n:" (nodes/match-label table) ") RETURN n.* ORDER BY n.id;")
|
||||
:max-rows 100000)))
|
||||
|
||||
(defn- edge-rows
|
||||
[conn rel props]
|
||||
(let [returns (into ["a.id" "b.id"] (map #(str "r.`" % "`")) props)]
|
||||
(:rows (ladybug/query-on-connection!
|
||||
conn (str "MATCH (a)-[r:`" rel "`]->(b) "
|
||||
"RETURN " (clojure.string/join ", " returns) " "
|
||||
"ORDER BY a.id, b.id;")
|
||||
:max-rows 100000))))
|
||||
|
||||
(defn- keyed-rows
|
||||
"Rows as `{key {column value}}`, so a difference names a row and a column.
|
||||
|
||||
Values are stringified: both connections hand a value back through the same
|
||||
reader, so any difference in the strings is a difference in the graph."
|
||||
[columns key-columns rows]
|
||||
(into {}
|
||||
(map (fn [row]
|
||||
(let [cells (zipmap columns (map str row))]
|
||||
[(mapv cells key-columns) cells])))
|
||||
rows))
|
||||
|
||||
(defn- snapshot
|
||||
"Every node row and every edge row in the database, keyed by table."
|
||||
[conn]
|
||||
{:nodes (into {}
|
||||
(map (fn [{:keys [table]}]
|
||||
(let [columns (nodes/columns table)]
|
||||
[table (keyed-rows columns ["id"] (node-rows conn table))])))
|
||||
nodes/node-types)
|
||||
:edges (into {}
|
||||
(map (fn [rel]
|
||||
(let [columns (into ["from" "to"] (rel-properties conn rel))]
|
||||
[rel (keyed-rows columns ["from" "to"]
|
||||
(edge-rows conn rel (rel-properties conn rel)))])))
|
||||
(rel-tables conn))})
|
||||
|
||||
(defn- row-diff
|
||||
[rows-a rows-b]
|
||||
(into {}
|
||||
(for [k (sort (into #{} (concat (keys rows-a) (keys rows-b))))
|
||||
:let [a (get rows-a k)
|
||||
b (get rows-b k)]
|
||||
:when (not= a b)]
|
||||
[k (cond
|
||||
(nil? a) {:only-in :rebuilt}
|
||||
(nil? b) {:only-in :synced}
|
||||
:else (into {}
|
||||
(for [c (sort (into #{} (concat (keys a) (keys b))))
|
||||
:when (not= (get a c) (get b c))]
|
||||
[c {:synced (get a c) :rebuilt (get b c)}])))])))
|
||||
|
||||
(defn- diff
|
||||
"Where the two snapshots disagree, down to the row and the column."
|
||||
[a b]
|
||||
(into {}
|
||||
(for [kind [:nodes :edges]
|
||||
table (sort (into #{} (concat (keys (get a kind)) (keys (get b kind)))))
|
||||
:let [d (row-diff (get-in a [kind table]) (get-in b [kind table]))]
|
||||
:when (seq d)]
|
||||
[[kind table] d])))
|
||||
|
||||
(defn- with-two-connections
|
||||
"Open two `:memory:` databases under one Arrow allocator.
|
||||
|
||||
The allocator stays outer to both connections: Ladybug keeps the staged
|
||||
buffers until connection close, so an allocator closed first leaks —
|
||||
see `app.graph.arrow/with-allocator!`."
|
||||
[f]
|
||||
(arrow/with-allocator!
|
||||
(fn [allocator]
|
||||
(ladybug/with-connection! ":memory:"
|
||||
(fn [conn-a]
|
||||
(ladybug/with-connection! ":memory:"
|
||||
(fn [conn-b]
|
||||
(f conn-a conn-b allocator))))))))
|
||||
|
||||
(defn- round-trip
|
||||
"Sync `change-list` into A, rebuild the same file into B, return the diff."
|
||||
[change-list]
|
||||
(let [data0 (base-data)
|
||||
data1 (cfc/process-changes data0 change-list)
|
||||
revn1 (inc base-revn)]
|
||||
(with-two-connections
|
||||
(fn [conn-a conn-b allocator]
|
||||
(let [projection (load-graph! conn-a allocator data0 (file-row base-revn))
|
||||
index (sync/build-index file-id base-revn projection)
|
||||
result (sync/apply-changes! conn-a index change-list revn1)]
|
||||
(load-graph! conn-b allocator data1 (file-row revn1))
|
||||
{:diff (diff (snapshot conn-a) (snapshot conn-b))
|
||||
:applied (:applied result)
|
||||
:skipped (:skipped result)})))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; the tests
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(t/deftest every-change-in-the-list-is-supported
|
||||
(let [{:keys [applied skipped]} (round-trip changes)]
|
||||
(t/is (empty? skipped)
|
||||
(str "the fixture must exercise the sync path, not the skip path: " (pr-str skipped)))
|
||||
(t/is (= (count changes) (count applied)))))
|
||||
|
||||
(t/deftest synced-graph-equals-rebuilt-graph
|
||||
(let [{:keys [diff]} (round-trip changes)]
|
||||
(t/is (empty? diff)
|
||||
(str "cold projection and sync replay disagree on "
|
||||
(pr-str (keys diff)) "\n" (pr-str diff)))))
|
||||
|
||||
(t/deftest ingest-on-connection-requires-allocator
|
||||
;; The allocator must outlive the connection, so ingest cannot make its own
|
||||
;; inside the call — see `app.graph.arrow/with-allocator!`.
|
||||
(try
|
||||
(ingest/ingest-on-connection! nil nil file-id)
|
||||
(t/is false "expected :missing-arrow-allocator")
|
||||
(catch clojure.lang.ExceptionInfo e
|
||||
(t/is (= :missing-arrow-allocator (:code (ex-data e)))))))
|
||||
|
||||
(t/deftest the-diff-catches-an-injected-sync-bug
|
||||
;; The round trip is only worth running if it fails when sync is wrong.
|
||||
;; `apply-mov-objects` maintains `IsChildOf`; drop the change from the list
|
||||
;; sync sees, keep it in the list the file sees, and the edge must differ.
|
||||
(let [data0 (base-data)
|
||||
data1 (cfc/process-changes data0 changes)
|
||||
crippled (remove #(= :mov-objects (:type %)) changes)
|
||||
revn1 (inc base-revn)
|
||||
result (with-two-connections
|
||||
(fn [conn-a conn-b allocator]
|
||||
(let [projection (load-graph! conn-a allocator data0 (file-row base-revn))
|
||||
index (sync/build-index file-id base-revn projection)]
|
||||
(sync/apply-changes! conn-a index crippled revn1)
|
||||
(load-graph! conn-b allocator data1 (file-row revn1))
|
||||
(diff (snapshot conn-a) (snapshot conn-b)))))]
|
||||
(t/is (contains? result [:edges "IsChildOf"])
|
||||
"a sync that skips a reparent must show up as an IsChildOf difference")))
|
||||
Loading…
x
Reference in New Issue
Block a user