diff --git a/backend/src/app/graph/overlay/sync.clj b/backend/src/app/graph/overlay/sync.clj index 9d7c46a586..cfcdb0edb2 100644 --- a/backend/src/app/graph/overlay/sync.clj +++ b/backend/src/app/graph/overlay/sync.clj @@ -98,13 +98,23 @@ (mapv :e (d/datoms db :avet :shape/parent eid))) (defn- subtree-eids - "The shape entity plus every descendant, via the reverse parent index." + "The shape entity plus every descendant, via the reverse parent index. + + `seen` is what makes the walk return on a cyclic index: the children + closure is the same thing `app.common.files.helpers/get-children-ids` + walks with its own `processed` set, and an index that carries a cycle + (a change that escaped `app.common.files.changes/valid-move?`, or a + rebuild of a document that already had one) would otherwise accumulate + every revisit and never reach the end of the loop." [db root-eid] (loop [acc [] + seen #{root-eid} frontier [root-eid]] (if-let [eid (peek frontier)] - (recur (conj acc eid) - (into (pop frontier) (child-eids db eid))) + (let [children (remove seen (child-eids db eid))] + (recur (conj acc eid) + (into seen children) + (into (pop frontier) children))) acc))) (defn- container-shape-eids @@ -510,6 +520,38 @@ (subtree-eids db eid)))] (ok (with-order db' (children-in-order db' peid))))))) +(defn- container-objects + "The destination container's objects map, reconstructed from the index + for `app.common.files.changes/valid-move?`: shape id → `:parent-id`, + `:shapes`, `:component-id` and `:shape-ref`, which are the keys the move + decision reads and the only ones it reads. + + The predicate takes the objects-shaped view rather than an index, so + this is the view: the index is not a second way to answer which moves + are legal (`pp:graph:database-is-the-boundary`). Parent and child ids + are shape ids, as they are in the document, so a shape the index parents + on its container — the page root frame, the root copy of a component + container — arrives with no parent, and the walk up stops where the + document's stops. + + Built for the whole container, the order `renumber-container-tx` beside + it already reads: the decision walks the moved shape's subtree and the + destination's chain, and neither stops where it started. The child lists + are unsorted, because the walk reads membership and never a position." + [db ceid] + (let [eids (container-shape-eids db ceid) + children (group-by (fn [e] (:db/id (:shape/parent (d/entity db e)))) eids)] + (into {} + (map (fn [eid] + (let [ent (d/entity db eid)] + [(:shape/id ent) + {:parent-id (:shape/id (:shape/parent ent)) + :shapes (into [] (map #(:shape/id (d/entity db %))) + (get children eid)) + :component-id (:shape/component-id ent) + :shape-ref (:shape/shape-ref ent)}]))) + eids))) + (defn- apply-mov-objects "Reparenting, and the order that comes with it: `:mov-objects` carries shape ids, a parent id, and either an `:index` or an `:after-shape` @@ -517,36 +559,52 @@ in the destination's child list where `insert-at-index` puts them and the parents they left close their gaps. The index is read against the destination's list as it stands, moved shapes included, because that is - the list the document splits." - [db {:keys [parent-id shapes index after-shape] :as change}] + the list the document splits. + + The move itself is the document's decision and not a second one: + `process-change :mov-objects` asks `valid-move?` for every shape the + change names and moves none of them unless every answer is yes, so one + invalid shape in a batch of ten leaves all ten where they were. The + mirror asks that same predicate, in the same order, of the container as + the index holds it at this point in the change list, and where the + document leaves its objects untouched the index rewrites no datom. That + is an applied change rather than a skip, because the fold still equals a + rebuild of the changed document (`pp:graph:stale-index-gate`)." + [db {:keys [parent-id shapes index after-shape allow-altering-copies syncing] :as change}] (let [ceid (queries/container-eid db (change-container-id change)) peid (when ceid (queries/shape-eid db ceid parent-id))] (if-not peid (skip db :missing-parent) - (let [moved (into [] - (keep (fn [sid] (queries/shape-eid db ceid sid))) - shapes) - siblings (children-in-order db peid) - index (or (some->> after-shape - (queries/shape-eid db ceid) - (ctd/index-of siblings) - inc) - index) - order (if (some? index) - (ctd/insert-at-index siblings index moved) - (cfh/append-at-the-end siblings moved)) - left (into [] - (comp (keep #(:db/id (:shape/parent (d/entity db %)))) - (remove #{peid}) - (distinct)) - moved) - tx (mapv (fn [eid] [:db/add eid :shape/parent peid]) moved) - db' (cond-> db (seq tx) (d/db-with tx)) - db' (with-order db' order) - db' (reduce (fn [db* pe] (with-order db* (children-in-order db* pe))) - db' left) - db' (with-renumber db' ceid)] - (ok (with-reresolved db' (into [] (mapcat #(subtree-eids db' %)) moved))))))) + (let [objects (container-objects db ceid) + flags {:allow-altering-copies allow-altering-copies + :syncing syncing}] + (if-not (and (seq shapes) + (every? #(cp/valid-move? objects % parent-id flags) shapes)) + (ok db) + (let [moved (into [] + (keep (fn [sid] (queries/shape-eid db ceid sid))) + shapes) + siblings (children-in-order db peid) + index (or (some->> after-shape + (queries/shape-eid db ceid) + (ctd/index-of siblings) + inc) + index) + order (if (some? index) + (ctd/insert-at-index siblings index moved) + (cfh/append-at-the-end siblings moved)) + left (into [] + (comp (keep #(:db/id (:shape/parent (d/entity db %)))) + (remove #{peid}) + (distinct)) + moved) + tx (mapv (fn [eid] [:db/add eid :shape/parent peid]) moved) + db' (cond-> db (seq tx) (d/db-with tx)) + db' (with-order db' order) + db' (reduce (fn [db* pe] (with-order db* (children-in-order db* pe))) + db' left) + db' (with-renumber db' ceid)] + (ok (with-reresolved db' (into [] (mapcat #(subtree-eids db' %)) moved))))))))) (defn- apply-reorder-children "Mirror of `process-change :reorder-children` -> diff --git a/backend/test/backend_tests/graph_overlay_sync_test.clj b/backend/test/backend_tests/graph_overlay_sync_test.clj index 05cb891f95..24f1f9b0f6 100644 --- a/backend/test/backend_tests/graph_overlay_sync_test.clj +++ b/backend/test/backend_tests/graph_overlay_sync_test.clj @@ -35,6 +35,7 @@ [app.graph.overlay.queries :as queries] [app.graph.overlay.sync :as sync] [clojure.set :as set] + [clojure.string :as str] [clojure.test :as t] [datascript.core :as d])) @@ -582,7 +583,7 @@ :del-obj {:coverage :covered :why "the shape and its subtree, and Penpot's one change per selected shape is idempotent here"} :mov-objects {:coverage :covered - :why "the parent edge and the child list, the container renumber and the re-resolution of the moved subtrees"} + :why "the parent edge and the child list, the container renumber and the re-resolution of the moved subtrees, for the moves `app.common.files.changes/valid-move?` accepts; a change the gate refuses moves none of its shapes, which is the document's own answer and rewrites no datom here"} :reorder-children {:coverage :covered :why "the sibling ordinals, from the parent's own list sorted as `process-children-reordering` sorts it: a partial order over the children, the unnamed ones first, and a parent inside a component copy left alone unless the change allows altering copies"} :add-page {:coverage :covered @@ -1125,6 +1126,174 @@ (t/is (= expected (select-keys (ordinals (:db result)) [child-1 child-2])) (str label ": the copy's child order moved the wrong way")))))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; the move gate +;; +;; `process-change :mov-objects` refuses the whole change when any shape it +;; names may not move, and a shape may not land in its own subtree, in a +;; component copy, or in its main component. The mirror asks the document's +;; own predicate for that answer, so a move the document leaves alone is a +;; move the fold leaves alone, and a change the document moves nothing for +;; rewrites no datom here. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(def ^:private with-a-copy-on-the-page + "The fixture's changes up to the component record's rename: the main + instance's subtree stands on the page, and `copy-root-id` carries a + `:shape-ref`, so a move into it is a move into a component copy." + (vec (take-while #(not= :mod-component (:type %)) changes))) + +(def ^:private before-circ-leaves + "The fixture's changes up to the `:del-obj` of circ-id: `subchild-id` is + still the frame's grandchild, which is what makes a move of the frame + under it a move under its own descendant." + (vec (take-while #(not= :del-obj (:type %)) changes))) + +(defn- parent-shape-id + "The shape id of the parent the index gives `sid` inside `container-id`: + the answer a consumer reads out of the fold without the document." + [db container-id sid] + (let [ceid (queries/container-eid db container-id)] + (:shape/id (:shape/parent (d/entity db (queries/shape-eid db ceid sid)))))) + +(defn- fold-and-rebuild + "The fixture after `change-list` on both paths: the changed document, the + folded index, the rebuilt index, and the fold's report. `round-trip` + compares the second and third in normal form; a test that names an entity + needs the databases themselves." + [change-list] + (let [data0 (base-data) + data1 (cp/process-changes data0 change-list false) + result (sync/apply-changes (overlay/build data0) change-list)] + {:document data1 + :folded (:db result) + :rebuilt (overlay/build data1) + :applied (:applied result) + :skipped (:skipped result)})) + +(t/deftest a-move-the-gate-refuses-leaves-the-parent-edges-alone + ;; The measurement `pp:graph:the-move-mirror-ignores-the-validity-gate` + ;; records, on this fixture: the destination is a component copy, so the + ;; document refuses to move the main instance's child into it, and the fold + ;; used to follow the move anyway, leaving the fold with a parent edge the + ;; document never had. + (let [change (conj with-a-copy-on-the-page + {:type :mov-objects :page-id page-id + :parent-id copy-root-id :shapes [comp-child-id]}) + {:keys [document folded rebuilt applied skipped]} (fold-and-rebuild change)] + (t/is (empty? skipped) + (str "a refused move is not a skip: " (pr-str skipped))) + (t/is (= :mov-objects (peek applied)) + "the change is applied, because the index still equals a rebuild") + (t/is (= comp-root-id + (get-in document [:pages-index page-id :objects comp-child-id :parent-id])) + "the document kept the main instance's child where it was") + (t/is (= [comp-root-id comp-root-id] + [(parent-shape-id folded page-id comp-child-id) + (parent-shape-id rebuilt page-id comp-child-id)]) + "and both indexes kept the parent the document kept") + (t/is (= (normal-form folded) (normal-form rebuilt)) + "the parent edge was the whole difference this case had"))) + +(t/deftest a-move-into-a-copy-follows-allow-altering-copies + ;; `allow-altering-copies` is the document's own lift of the copy + ;; restriction, which a component swap carries, and the mirror passes it + ;; through rather than deciding for itself: the same move into a copy is + ;; refused without the flag and follows with it, on both paths. + (let [change (fn [flags] + (conj with-a-copy-on-the-page + (merge {:type :mov-objects :page-id page-id + :parent-id copy-root-id :shapes [rect-id]} + flags))) + refused (fold-and-rebuild (change {})) + allowed (fold-and-rebuild (change {:allow-altering-copies true}))] + (t/is (= [frame-id frame-id] + [(parent-shape-id (:folded refused) page-id rect-id) + (parent-shape-id (:rebuilt refused) page-id rect-id)]) + "without the flag the copy still refuses the move") + (t/is (= (normal-form (:folded refused)) (normal-form (:rebuilt refused)))) + (t/is (= [copy-root-id copy-root-id] + [(parent-shape-id (:folded allowed) page-id rect-id) + (parent-shape-id (:rebuilt allowed) page-id rect-id)]) + "and with it both indexes follow the move the document makes") + (t/is (= (normal-form (:folded allowed)) (normal-form (:rebuilt allowed)))))) + +(t/deftest one-invalid-shape-moves-none-of-the-shapes-with-it + ;; The half a per-shape mirror cannot see: the gate is all-or-nothing for + ;; the change, so the frame that may not land under its own descendant + ;; keeps the text beside it where it was. The control is the same change + ;; with the frame left out, which moves the text on both paths — the + ;; invalid shape's presence is the only difference between the two. + (let [change (fn [shape-ids] + (conj before-circ-leaves + {:type :mov-objects :page-id page-id + :parent-id subchild-id :shapes shape-ids})) + refused (fold-and-rebuild (change [frame-id text-id])) + control (fold-and-rebuild (change [text-id]))] + (t/is (empty? (:skipped refused)) + (str "a refused move is not a skip: " (pr-str (:skipped refused)))) + (t/is (= [uuid/zero uuid/zero] + [(parent-shape-id (:folded refused) page-id frame-id) + (parent-shape-id (:rebuilt refused) page-id frame-id)]) + "neither index moved the frame the gate refuses") + (t/is (= [uuid/zero uuid/zero] + [(parent-shape-id (:folded refused) page-id text-id) + (parent-shape-id (:rebuilt refused) page-id text-id)]) + "and the text stayed with it, as the document left it") + (t/is (= (normal-form (:folded refused)) (normal-form (:rebuilt refused)))) + (t/is (empty? (:skipped control)) + (str "the control is a valid move: " (pr-str (:skipped control)))) + (t/is (= [subchild-id subchild-id] + [(parent-shape-id (:folded control) page-id text-id) + (parent-shape-id (:rebuilt control) page-id text-id)]) + "while the same change without the invalid shape moves the text") + (t/is (= (normal-form (:folded control)) (normal-form (:rebuilt control)))))) + +(t/deftest a-move-under-its-own-descendant-returns-and-folds-to-the-rebuild + ;; The second measurement: the mirror followed this move, closed a cycle in + ;; its parent edges, and walked `subtree-eids` for ever — eight seconds in, + ;; the stack still bore it. The gate refuses the move, so there is no cycle + ;; to enter and the change lands as an applied change. + (let [change (conj before-circ-leaves + {:type :mov-objects :page-id page-id + :parent-id subchild-id :shapes [frame-id]}) + {:keys [document folded rebuilt applied skipped]} (fold-and-rebuild change)] + (t/is (empty? skipped) + (str "a refused move is not a skip: " (pr-str skipped))) + (t/is (= :mov-objects (peek applied)) + "the change is applied, because the index still equals a rebuild") + (t/is (= uuid/zero + (get-in document [:pages-index page-id :objects frame-id :parent-id])) + "the document refuses to nest the frame under its own descendant") + (t/is (= [uuid/zero uuid/zero] + [(parent-shape-id folded page-id frame-id) + (parent-shape-id rebuilt page-id frame-id)]) + "and neither index followed it") + (t/is (= (normal-form folded) (normal-form rebuilt))))) + +(t/deftest the-subtree-walk-returns-on-a-cyclic-index + ;; The gate is the first half of the repair and this is the second: an + ;; index that already holds a cycle must not make the walk run for ever, + ;; because `subtree-eids` runs over every moved subtree and every deleted + ;; one. `app.common.files.helpers/get-children-ids`, which walks the same + ;; closure in the document, carries its own `processed` set for the same + ;; reason. The deref is the assertion: a walk that does not return fails + ;; here rather than hanging the run. + (let [db (-> (overlay/build (base-data)) + (sync/apply-changes (subvec changes 0 4)) + :db) + ceid (queries/container-eid db page-id) + circ (queries/shape-eid db ceid circ-id) + sub (queries/shape-eid db ceid subchild-id) + ;; circ under its own child: a cycle of two, which no accepted change + ;; produces and a rebuilt index can still hold + db (d/db-with db [[:db/add circ :shape/parent sub]]) + walked (deref (future (#'sync/subtree-eids db circ)) 5000 ::timeout)] + (t/is (not= ::timeout walked) + "the walk must return on a cyclic index") + (t/is (= [circ sub] walked) + "and name each shape of the cycle once"))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; the staleness gate ;; @@ -1285,6 +1454,18 @@ (t/is (contains? (types-with change-coverage :covered) :reorder-children) "and it is covered here, which is what the ordinal bought")) +(t/deftest the-mov-objects-row-names-the-gate-it-covers + ;; The row is the table's claim about which moves the mirror covers, and + ;; the mirror covers exactly the moves the document's validity gate + ;; accepts. A row that names the decision it rests on and states the + ;; answer for a change the gate refuses is one a reader can hold the + ;; applier to, and the claim goes stale loudly where the row goes stale. + (let [why (:why (change-coverage :mov-objects))] + (t/is (str/includes? why "valid-move?") + "the row names the decision the mirror asks") + (t/is (str/includes? why "refuses") + "and states what a change the gate refuses moves"))) + (t/deftest the-classification-table-names-every-operation (let [dispatched (disj (set (keys (methods cp/process-operation))) :default) rows (set (keys operation-coverage))] diff --git a/common/src/app/common/files/changes.cljc b/common/src/app/common/files/changes.cljc index ce45edd485..d70cb3c845 100644 --- a/common/src/app/common/files/changes.cljc +++ b/common/src/app/common/files/changes.cljc @@ -747,37 +747,50 @@ (d/update-in-when data [:pages-index page-id :objects] reg-objects) (d/update-in-when data [:components component-id :objects] reg-objects)))) +(defn- calculate-invalid-targets + "The shapes `shape-id` may not be moved into: itself and its whole + subtree, read off the objects map's own child lists." + [objects shape-id] + (let [reduce-fn #(into %1 (calculate-invalid-targets objects %2))] + (->> (get-in objects [shape-id :shapes]) + (reduce reduce-fn #{shape-id})))) + +(defn valid-move? + "Whether `shape-id` may be moved under `parent-id`, decided off + `objects`: avoid placing a shape as a direct or indirect child of + itself, or inside its main component if it's in a copy, or inside a + copy, or from a copy. A component swap (`allow-altering-copies`) and the + deprecated `syncing` path allow changing the structure of a copy. + + `objects` is the view the answer takes rather than a container, because + the decision walks the moved shape's subtree down `:shapes` and the + destination's chain up `:parent-id`, reading `:component-id` and + `:shape-ref` off every shape it meets: a caller holding those four facts + per shape can ask this without a document. It is public because + `app.graph.overlay.sync` is that caller, and the incremental overlay + refuses a move the document refuses by asking this predicate rather than + by answering the same question a second time." + [objects shape-id parent-id {:keys [allow-altering-copies syncing]}] + (let [invalid-targets (calculate-invalid-targets objects shape-id) + shape (get objects shape-id)] + (and shape + (not (invalid-targets parent-id)) + (not (cfh/components-nesting-loop? objects shape-id parent-id)) + (or allow-altering-copies + syncing + (and + ;; We don't want to change the structure of component copies + (not (ctk/in-component-copy? (get objects (:parent-id shape)))) + ;; We need to check the origin and target frames + (not (ctk/in-component-copy? (get objects parent-id)))))))) + (defmethod process-change :mov-objects ;; FIXME: ignore-touched is no longer used, so we can consider it deprecated [data {:keys [parent-id shapes index page-id component-id #_ignore-touched after-shape allow-altering-copies syncing]}] - (letfn [(calculate-invalid-targets [objects shape-id] - (let [reduce-fn #(into %1 (calculate-invalid-targets objects %2))] - (->> (get-in objects [shape-id :shapes]) - (reduce reduce-fn #{shape-id})))) - - ;; Avoid placing a shape as a direct or indirect child of itself, or - ;; inside its main component if it's in a copy, or inside a copy, or - ;; from a copy - (is-valid-move? [objects shape-id] - (let [invalid-targets (calculate-invalid-targets objects shape-id) - shape (get objects shape-id)] - (and shape - (not (invalid-targets parent-id)) - (not (cfh/components-nesting-loop? objects shape-id parent-id)) - (or - ;; In some cases (like a component - ;; swap) it's allowed to change the - ;; structure of a copy - allow-altering-copies - - ;; DEPRECATED, remove once v2.12 released - syncing - - (and - ;; We don't want to change the structure of component copies - (not (ctk/in-component-copy? (get objects (:parent-id shape)))) - ;; We need to check the origin and target frames - (not (ctk/in-component-copy? (get objects parent-id)))))))) + (letfn [(is-valid-move? [objects shape-id] + (valid-move? objects shape-id parent-id + {:allow-altering-copies allow-altering-copies + :syncing syncing})) (insert-items [prev-shapes index shapes] (let [prev-shapes (or prev-shapes [])]