From 885099326a26744694c64ed3a9745c619915960c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=C3=81lvaro=20Tejero=20Cantero?= Date: Wed, 28 Oct 2026 11:20:26 +0100 Subject: [PATCH] :sparkles: Store branch bases as pointers into the source file MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit A branch base was a fully realized copy of main. With fdata/pointer-map, creation now stores main's fragment pointers: the base costs one pointer per page and shares main's fragment rows. Fragment rows are keyed by (file_id, id), so the base readers (the branch derive and get-base-data) realize the base with the source file id through realize-branch-base. The branch file's own loader finds none of main's fragments. Every writer of a snapshot that names main's fragments reads main's row FOR SHARE, so it serializes with file-gc, which takes the row FOR UPDATE and marks every fragment no committed snapshot names. Creation, the pre-merge snapshot, and the base repositioned by an update from main follow that rule. The merge and the update put main's stored pointer back on every page they left unchanged, so the merge rewrites only the pages it changed and a repositioned base shares main's fragments. The hand-written pmap bindings move to fdata/with-tracked-pointers. AI-assisted-by: claude-opus-5-5 Signed-off-by: Álvaro Tejero Cantero --- backend/src/app/binfile/common.clj | 17 +- backend/src/app/rpc/commands/files_branch.clj | 482 ++++++++++-------- .../branch_pointer_base_test.clj | 225 ++++++++ 3 files changed, 498 insertions(+), 226 deletions(-) create mode 100644 backend/test/backend_tests/branch_pointer_base_test.clj diff --git a/backend/src/app/binfile/common.clj b/backend/src/app/binfile/common.clj index 591ca2e10c..37bf2004a1 100644 --- a/backend/src/app/binfile/common.clj +++ b/backend/src/app/binfile/common.clj @@ -354,10 +354,20 @@ itself, the replayed branch and its merge base, and neither has a row to write back to." [cfg {:keys [id] :as file} migrate-fn] - (binding [pmap/*load-fn* (partial fdata/load-pointer cfg id) - pmap/*tracked* (pmap/create-tracked)] + (fdata/with-tracked-pointers cfg id (migrate-fn file (delay (get-resolved-file-libraries cfg file))))) +(defn realize-branch-base + "Realize the `:data` of a branch's merge-base snapshot to plain maps. + The base is a snapshot of the source file and shares the source + file's fragments, and a fragment row is keyed by `(file_id, id)`, so + the pointers load with the snapshot's `:file-id`, the source file: + the loader of the branch file finds none of them. + + `snapshot` is a snapshot row with its data decoded." + [cfg {:keys [file-id] :as snapshot}] + (update snapshot :data #(:data (fdata/realize cfg {:id file-id :data %})))) + (defn migrate-branch-base "The `:data` of a branch's merge-base snapshot at the current data version. The snapshot keeps the version main had when the base was @@ -449,6 +459,9 @@ base (fdata/resolve-file-data cfg base) base (fdata/decode-file-data cfg base) + ;; the base shares the source file's fragments; past this point + ;; the replay, the migrations and every caller see plain data + base (realize-branch-base cfg base) rows (db/exec! conn [sql:get-branch-changes id]) diff --git a/backend/src/app/rpc/commands/files_branch.clj b/backend/src/app/rpc/commands/files_branch.clj index 5adcfa7e4b..3524c18aaa 100644 --- a/backend/src/app/rpc/commands/files_branch.clj +++ b/backend/src/app/rpc/commands/files_branch.clj @@ -48,7 +48,6 @@ [app.rpc.quotes :as quotes] [app.util.blob :as blob] [app.util.cache :as ucache] - [app.util.pointer-map :as pmap] [app.util.services :as sv] [clojure.set :as set] [clojure.string :as str])) @@ -85,7 +84,8 @@ (defn- check-file-size-limits! "Refuse an operation on a file whose realized state is beyond what the - feature was measured to survive. `file` must already be realized." + feature was measured to survive. A `file` that still holds fragment + pointers needs the loader of its own id bound (`fdata/with-pointers`)." [{:keys [data] :as file} operation] (let [max-shapes (branching-limit :branching-max-shapes 50000) max-pages (branching-limit :branching-max-pages 500) @@ -273,6 +273,32 @@ ;; --- Helpers: merge base snapshot +(defn- read-main-for-write + "Read main for a command that writes a snapshot naming main's fragments + or persists main itself. Returns `[stored file]`: `stored` keeps main's + fragment pointers, and `file` is the same document realized and + checked against the size limits. + + The row is read FOR SHARE. File-gc takes it FOR UPDATE and marks every + fragment that neither main nor a committed snapshot names, so a + snapshot that copies main's pointers must commit before the next pass + can read the row." + [cfg main-id operation] + (let [stored (bfc/get-file cfg main-id :lock-for-share? true) + file (-> (fdata/realize cfg stored) + (check-file-size-limits! operation))] + [stored file])) + +(defn- reattach-main-pointers + "`file` with main's stored fragment pointers put back on every page + whose value still equals main's, so a base or a merged main shares + those fragments instead of writing copies, and an unchanged page keeps + its fragment id. `stored` is the first value `read-main-for-write` + returns." + [cfg main-id stored file] + (fdata/with-pointers cfg main-id + (fdata/reattach-unchanged (fdata/original-pointers (:data stored)) file))) + (defn- get-base-data "The merge-base `:data` from the branch's base snapshot, migrated to the current data version (`bfc/migrate-branch-base`): `bfc/get-file` @@ -298,6 +324,7 @@ :hint "the branch has no merge-base snapshot" :branch-id (:id branch))) (when-some [data (some->> (fsnap/get-snapshot cfg source-file-id base-snapshot-id) + (bfc/realize-branch-base cfg) (bfc/migrate-branch-base cfg))] (bm/remap-refs data (branch-media-pairs cfg branch-file-id source-file-id)))) @@ -470,13 +497,17 @@ (quotes/check! {::quotes/id ::quotes/branches-per-file} {::quotes/id ::quotes/branches-per-team})) - ;; 1. Materialize the merge base: a system snapshot of - ;; main, kept long-lived so it is not pruned by the - ;; snapshot GC while the branch is open (it is - ;; released when the branch is deleted or its base - ;; moves). - (let [file (-> (bfc/get-file cfg file-id :realize? true) - (check-file-size-limits! :create-branch)) + ;; 1. Pin the merge base: a system snapshot of main, + ;; kept long-lived so it is not pruned by the snapshot + ;; GC while the branch is open (it is released when the + ;; branch is deleted or its base moves). The snapshot + ;; stores main's fragment pointers, not its pages, so + ;; main's row is read FOR SHARE: file-gc takes it FOR + ;; UPDATE, and a pass that ran between this read and + ;; the commit could mark a fragment the base names. + (let [file (bfc/get-file cfg file-id :lock-for-share? true) + _ (fdata/with-pointers cfg file-id + (check-file-size-limits! file :create-branch)) base (fsnap/create! cfg file {:label (str "branch-base/" name) :profile-id profile-id @@ -1026,8 +1057,7 @@ (ex/raise :type :validation :code :branch-not-open :branch-id branch-id)) - main-file (-> (bfc/get-file cfg main-id :realize? true) - (check-file-size-limits! :merge)) + [main-stored main-file] (read-main-for-write cfg main-id :merge) _ (check-oplog-depth-limit! (bfc/get-branch-oplog-depth cfg branch-file-id) branch-file-id :merge) @@ -1136,77 +1166,81 @@ (let [team (teams/get-team conn :profile-id profile-id :file-id main-id) delay (ldel/get-deletion-delay team) ts (ct/now)] - (binding [pmap/*tracked* (pmap/create-tracked) - pmap/*load-fn* (partial fdata/load-pointer cfg main-id) - cfeat/*current* (:features main-file) - cfeat/*previous* (:features main-file)] + (fdata/with-tracked-pointers cfg main-id + (binding [cfeat/*current* (:features main-file) + cfeat/*previous* (:features main-file)] - ;; Safety snapshot of pre-merge main (rollback via versions). - (fsnap/create! cfg main-file - {:label (str "pre-merge/" (:name branch)) - :created-by "system" - :deleted-at (ct/in-future delay) - :profile-id profile-id}) + ;; Safety snapshot of pre-merge main (rollback via + ;; versions). It names main's fragments rather than + ;; copying its pages. + (fsnap/create! cfg main-stored + {:label (str "pre-merge/" (:name branch)) + :created-by "system" + :deleted-at (ct/in-future delay) + :profile-id profile-id}) - ;; media added on the branch: copy its rows into main - ;; under the pre-allocated ids the changes reference - (copy-media-rows! conn main-id fresh-map new-media) + ;; media added on the branch: copy its rows into main + ;; under the pre-allocated ids the changes reference + (copy-media-rows! conn main-id fresh-map new-media) - (let [merged (-> main-file - (update :revn inc) - (update :data #(cpc/process-changes % changes))) - libs (bfc/get-resolved-file-libraries cfg merged) - errors (not-empty (cfv/validate-file merged libs)) - repair (if errors - (cfr/repair-file merged libs errors) - []) - merged (cond-> merged - (seq repair) - (update :data cpc/process-changes repair)) + (let [merged (-> main-file + (update :revn inc) + (update :data #(cpc/process-changes % changes))) + libs (bfc/get-resolved-file-libraries cfg merged) + errors (not-empty (cfv/validate-file merged libs)) + repair (if errors + (cfr/repair-file merged libs errors) + []) + merged (cond-> merged + (seq repair) + (update :data cpc/process-changes repair)) - ;; the validator, not the merge, decides - ;; validity: the repaired result goes back - ;; to it, and whatever stays broken refuses - ;; the merge and rolls the transaction back - errors (when errors - (not-empty (cfv/validate-file merged libs)))] - (when errors - (ex/raise :type :validation - :code :merge-result-invalid - :hint "the merge result still has validation errors after the repair" - :codes (into [] (comp (map :code) (distinct)) errors))) + ;; the validator, not the merge, decides + ;; validity: the repaired result goes back + ;; to it, and whatever stays broken refuses + ;; the merge and rolls the transaction back + errors (when errors + (not-empty (cfv/validate-file merged libs)))] + (when errors + (ex/raise :type :validation + :code :merge-result-invalid + :hint "the merge result still has validation errors after the repair" + :codes (into [] (comp (map :code) (distinct)) errors))) - ;; Change log (xlog), GC-eligible after the delay. - (db/insert! conn :file-change - {:id (uuid/next) - :session-id session-id - :profile-id profile-id - :created-at ts - :updated-at ts - :deleted-at (ct/in-future {:hours 1}) - :file-id main-id - :revn (:revn merged) - :version (:version merged) - :features (into-array (:features merged)) - :changes (blob/encode (into (vec changes) repair))} - {::db/return-keys false}) + ;; Change log (xlog), GC-eligible after the delay. + (db/insert! conn :file-change + {:id (uuid/next) + :session-id session-id + :profile-id profile-id + :created-at ts + :updated-at ts + :deleted-at (ct/in-future {:hours 1}) + :file-id main-id + :revn (:revn merged) + :version (:version merged) + :features (into-array (:features merged)) + :changes (blob/encode (into (vec changes) repair))} + {::db/return-keys false}) - (fupd/persist-file! (assoc cfg ::fupd/timestamp ts) merged) + ;; a page the merge left as it was keeps its + ;; fragment instead of being written again + (fupd/persist-file! (assoc cfg ::fupd/timestamp ts) + (reattach-main-pointers cfg main-id main-stored merged)) - (when (contains? cf/flags :redis-cache) - (fupd/invalidate-caches! cfg merged)) + (when (contains? cf/flags :redis-cache) + (fupd/invalidate-caches! cfg merged)) - (finish-branch! ts) + (finish-branch! ts) - (vswap! messages conj - {:topic main-id - :message {:type :file-merged - :file-id main-id - :session-id session-id - :revn (:revn merged)}}) + (vswap! messages conj + {:topic main-id + :message {:type :file-merged + :file-id main-id + :session-id session-id + :revn (:revn merged)}}) - (audited {:status :merged :revn (:revn merged) :source-file-id main-id} - tpoint :merge))))))))))))))) + (audited {:status :merged :revn (:revn merged) :source-file-id main-id} + tpoint :merge)))))))))))))))) ;; --- COMMAND: update-branch-from-main @@ -1316,8 +1350,7 @@ (ex/raise :type :validation :code :branch-not-open :branch-id branch-id)) - main-file (-> (bfc/get-file cfg main-id :realize? true) - (check-file-size-limits! :update-from-main)) + [main-stored main-file] (read-main-for-write cfg main-id :update-from-main) _ (when (and (some? expected-main-revn) (not= expected-main-revn (:revn main-file))) (ex/raise :type :conflict @@ -1387,8 +1420,11 @@ ;; id space, so a base naming main's rows would make every ;; paired media read as deleted+added on the next squash. The ;; comparisons normalize it back to main's id space on read - ;; (`get-base-data`/`branch-base-data`). - (let [new-base (fsnap/create! cfg (assoc main-file :data base-data) + ;; (`get-base-data`/`branch-base-data`). A page the remap + ;; left equal to main's names main's fragment. + (let [new-base (fsnap/create! cfg (reattach-main-pointers + cfg main-id main-stored + (assoc main-file :data base-data)) {:label (str "branch-base/" (:name branch)) :created-by "system" :deleted-at (ct/in-future {:days 3650}) @@ -1492,106 +1528,105 @@ :else (let [ts (ct/now)] - (binding [pmap/*tracked* (pmap/create-tracked) - pmap/*load-fn* (partial fdata/load-pointer cfg branch-file-id) - cfeat/*current* (:features branch-file) - cfeat/*previous* (:features branch-file)] + (fdata/with-tracked-pointers cfg branch-file-id + (binding [cfeat/*current* (:features branch-file) + cfeat/*previous* (:features branch-file)] - (fsnap/create! cfg branch-file - {:label (str "pre-update/" (:name branch)) - :created-by "system" - :deleted-at (ct/in-future delay) - :profile-id profile-id}) + (fsnap/create! cfg branch-file + {:label (str "pre-update/" (:name branch)) + :created-by "system" + :deleted-at (ct/in-future delay) + :profile-id profile-id}) - ;; media added on main: copy its rows into the branch - ;; under the pre-allocated ids the changes reference - (copy-media-rows! conn branch-file-id fresh-map new-media) + ;; media added on main: copy its rows into the branch + ;; under the pre-allocated ids the changes reference + (copy-media-rows! conn branch-file-id fresh-map new-media) - (let [applied (bm/remap-changes changes apply-map) - ;; the write lands in the branch's id space, so - ;; the document is moved there first — its paired - ;; media refs re-pointed at the branch's own - ;; rows — or the remapped changes would name ids - ;; it does not hold and apply to nothing (a - ;; `:del-media` of a paired copy would keep it) - updated (-> branch-file - (update :revn inc) - (update :data #(cpc/process-changes - (bm/remap-refs % media-map) - applied))) - libs (bfc/get-resolved-file-libraries cfg updated) - errors (not-empty (cfv/validate-file updated libs)) - repair (if errors - (cfr/repair-file updated libs errors) - []) - updated (cond-> updated - (seq repair) - (update :data cpc/process-changes repair)) + (let [applied (bm/remap-changes changes apply-map) + ;; the write lands in the branch's id space, so + ;; the document is moved there first — its paired + ;; media refs re-pointed at the branch's own + ;; rows — or the remapped changes would name ids + ;; it does not hold and apply to nothing (a + ;; `:del-media` of a paired copy would keep it) + updated (-> branch-file + (update :revn inc) + (update :data #(cpc/process-changes + (bm/remap-refs % media-map) + applied))) + libs (bfc/get-resolved-file-libraries cfg updated) + errors (not-empty (cfv/validate-file updated libs)) + repair (if errors + (cfr/repair-file updated libs errors) + []) + updated (cond-> updated + (seq repair) + (update :data cpc/process-changes repair)) - ;; the validator, not the update, decides - ;; validity: the repaired result goes back to - ;; it, and whatever stays broken refuses the - ;; update and rolls the transaction back - errors (when errors - (not-empty (cfv/validate-file updated libs)))] - (when errors - (ex/raise :type :validation - :code :update-result-invalid - :hint "the update result still has validation errors after the repair" - :codes (into [] (comp (map :code) (distinct)) errors))) - - (db/insert! conn :file-change - {:id (uuid/next) - :session-id session-id - :profile-id profile-id - :created-at ts - :updated-at ts - :deleted-at (ct/in-future {:hours 1}) - :file-id branch-file-id - :revn (:revn updated) - :version (:version updated) - :features (into-array (:features updated)) - :changes (blob/encode (into (vec applied) repair))} - {::db/return-keys false}) - - ;; SQUASH: the new base (main's current state) - ;; already carries everything main contributed, - ;; so the op log is replaced with the net - ;; branch-only changes computed against the new - ;; base. Refuse if that net cannot be translated - ;; into replayable ops; nothing has been - ;; persisted yet, so the transaction rollback - ;; undoes the snapshot and media copies above. - (let [{net-changes :changes - unsupported :unsupported} - (bm/compute-changes main-data main-data (:data updated) {})] - (when (seq unsupported) + ;; the validator, not the update, decides + ;; validity: the repaired result goes back to + ;; it, and whatever stays broken refuses the + ;; update and rolls the transaction back + errors (when errors + (not-empty (cfv/validate-file updated libs)))] + (when errors (ex/raise :type :validation - :code :unsupported-update-squash - :hint "the update produces branch-only changes that cannot be replayed" - :kinds (vec unsupported))) - ;; the net row carries the media id map the - ;; update applied: the log it replaces was - ;; written against the OLD merge base, and - ;; the squash is what names the branch's - ;; pairing with main from now on - (persist-branch-update! cfg updated ts branch-id - net-changes media-map)) + :code :update-result-invalid + :hint "the update result still has validation errors after the repair" + :codes (into [] (comp (map :code) (distinct)) errors))) - (when (contains? cf/flags :redis-cache) - (fupd/invalidate-caches! cfg updated)) - (reposition-base! ts (:revn updated) - (bm/remap-refs main-raw media-map)) + (db/insert! conn :file-change + {:id (uuid/next) + :session-id session-id + :profile-id profile-id + :created-at ts + :updated-at ts + :deleted-at (ct/in-future {:hours 1}) + :file-id branch-file-id + :revn (:revn updated) + :version (:version updated) + :features (into-array (:features updated)) + :changes (blob/encode (into (vec applied) repair))} + {::db/return-keys false}) - (vswap! messages conj - {:topic branch-file-id - :message {:type :file-merged - :file-id branch-file-id - :session-id session-id - :revn (:revn updated)}}) + ;; SQUASH: the new base (main's current state) + ;; already carries everything main contributed, + ;; so the op log is replaced with the net + ;; branch-only changes computed against the new + ;; base. Refuse if that net cannot be translated + ;; into replayable ops; nothing has been + ;; persisted yet, so the transaction rollback + ;; undoes the snapshot and media copies above. + (let [{net-changes :changes + unsupported :unsupported} + (bm/compute-changes main-data main-data (:data updated) {})] + (when (seq unsupported) + (ex/raise :type :validation + :code :unsupported-update-squash + :hint "the update produces branch-only changes that cannot be replayed" + :kinds (vec unsupported))) + ;; the net row carries the media id map the + ;; update applied: the log it replaces was + ;; written against the OLD merge base, and + ;; the squash is what names the branch's + ;; pairing with main from now on + (persist-branch-update! cfg updated ts branch-id + net-changes media-map)) - (audited {:status :updated :revn (:revn updated)} - tpoint :update-from-main)))))))))))))) + (when (contains? cf/flags :redis-cache) + (fupd/invalidate-caches! cfg updated)) + (reposition-base! ts (:revn updated) + (bm/remap-refs main-raw media-map)) + + (vswap! messages conj + {:topic branch-file-id + :message {:type :file-merged + :file-id branch-file-id + :session-id session-id + :revn (:revn updated)}}) + + (audited {:status :updated :revn (:revn updated)} + tpoint :update-from-main))))))))))))))) ;; --- COMMAND: materialize-file-branch @@ -1644,73 +1679,72 @@ delay (ldel/get-deletion-delay team) ts (ct/now)] - (binding [pmap/*tracked* (pmap/create-tracked) - pmap/*load-fn* (partial fdata/load-pointer cfg branch-file-id) - cfeat/*current* (:features file) - cfeat/*previous* (:features file)] + (fdata/with-tracked-pointers cfg branch-file-id + (binding [cfeat/*current* (:features file) + cfeat/*previous* (:features file)] - (let [libs (bfc/get-resolved-file-libraries cfg file) - errors (not-empty (cfv/validate-file file libs)) - repair (if errors - (cfr/repair-file file libs errors) - []) - file (cond-> file - (seq repair) - (update :data cpc/process-changes repair)) + (let [libs (bfc/get-resolved-file-libraries cfg file) + errors (not-empty (cfv/validate-file file libs)) + repair (if errors + (cfr/repair-file file libs errors) + []) + file (cond-> file + (seq repair) + (update :data cpc/process-changes repair)) - ;; the exit door never strands a user: the repaired - ;; result goes back to the validator, and whatever - ;; stays broken is logged, never refused - errors (when errors - (not-empty (cfv/validate-file file libs)))] + ;; the exit door never strands a user: the repaired + ;; result goes back to the validator, and whatever + ;; stays broken is logged, never refused + errors (when errors + (not-empty (cfv/validate-file file libs)))] - (when errors - (l/wrn :hint "materialised file still has validation errors" - :file-id (str branch-file-id) - :codes (into [] (comp (map :code) (distinct)) errors))) + (when errors + (l/wrn :hint "materialised file still has validation errors" + :file-id (str branch-file-id) + :codes (into [] (comp (map :code) (distinct)) errors))) - ;; the derived state becomes the file's own payload - (fupd/persist-file! (assoc cfg ::fupd/timestamp ts) file) + ;; the derived state becomes the file's own payload + (fupd/persist-file! (assoc cfg ::fupd/timestamp ts) file) - (when (contains? cf/flags :redis-cache) - (fupd/invalidate-caches! cfg file)) + (when (contains? cf/flags :redis-cache) + (fupd/invalidate-caches! cfg file)) - ;; from here the ordinary paths apply - (db/update! conn :file - {:is-branch false} - {:id branch-file-id} - {::db/return-keys false}) + ;; from here the ordinary paths apply + (db/update! conn :file + {:is-branch false} + {:id branch-file-id} + {::db/return-keys false}) - ;; the payload replaced the log - (db/delete! conn :file-branch-change {:branch-id (:id branch)}) + ;; the payload replaced the log + (db/delete! conn :file-branch-change {:branch-id (:id branch)}) - ;; a review sandbox over a file that is no longer a branch - ;; has nothing left to review - (close-branch-pull-requests! cfg (:id branch) - {:profile-id profile-id - :status "closed" - :deleted-at (ct/in-future delay)}) + ;; a review sandbox over a file that is no longer a branch + ;; has nothing left to review + (close-branch-pull-requests! cfg (:id branch) + {:profile-id profile-id + :status "closed" + :deleted-at (ct/in-future delay)}) - ;; nothing derives from the base any more, so the pin goes - (release-base-snapshot! cfg branch (ct/in-future delay)) + ;; nothing derives from the base any more, so the pin goes + (release-base-snapshot! cfg branch (ct/in-future delay)) - ;; The branch row is archived rather than deleted: its pull - ;; requests reference it with ON DELETE CASCADE, so deleting - ;; it would take the review history along, and `archived` is - ;; a status the schema already allows. - (db/update! conn :file-branch - {:status "archived" - :deleted-at (ct/in-future delay) - :updated-at ts} - {:id (:id branch)} - {::db/return-keys false}) + ;; The branch row is archived rather than deleted: its pull + ;; requests reference it with ON DELETE CASCADE, so deleting + ;; it would take the review history along, and `archived` is + ;; a status the schema already allows. + (db/update! conn :file-branch + {:status "archived" + :deleted-at (ct/in-future delay) + :updated-at ts} + {:id (:id branch)} + {::db/return-keys false}) - (audited - {:status :materialized - :file-id branch-file-id - :changed true - :revn (:revn file)} - tpoint :materialize)))))))))) + (audited + {:status :materialized + :file-id branch-file-id + :changed true + :revn (:revn file)} + tpoint :materialize))))))))))) ;; --- COMMAND QUERY: get-file-branch-info diff --git a/backend/test/backend_tests/branch_pointer_base_test.clj b/backend/test/backend_tests/branch_pointer_base_test.clj new file mode 100644 index 0000000000..9220b76398 --- /dev/null +++ b/backend/test/backend_tests/branch_pointer_base_test.clj @@ -0,0 +1,225 @@ +;; 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 INC Sucursal en España SL + +(ns backend-tests.branch-pointer-base-test + "A branch base is a snapshot of the source file that shares the source + file's fragments (fdata/pointer-map). Fragment rows are keyed by + `(file_id, id)`, so the base readers must realize it with the source + file id, and the source file's file-gc must keep every fragment a live + base names." + (:require + [app.binfile.common :as bfc] + [app.common.features :as cfeat] + [app.common.types.shape :as cts] + [app.common.uuid :as uuid] + [app.config :as cf] + [app.db :as db] + [app.features.file-snapshots :as fsnap] + [app.rpc :as-alias rpc] + [app.rpc.commands.files-branch :as fbranch] + [app.util.pointer-map :as pmap] + [backend-tests.helpers :as th] + [clojure.test :as t] + [clojure.walk :as walk])) + +(t/use-fixtures :once th/state-init) +(t/use-fixtures :each th/database-reset) + +(defn- pointer-map-enabled? + [] + (contains? (cfeat/get-enabled-features cf/flags) "fdata/pointer-map")) + +(defn- update-file! + [profile-id file-id changes] + (let [row (th/db-get :file {:id file-id}) + out (th/command! {::th/type :update-file + ::rpc/profile-id profile-id + :id file-id + :session-id (uuid/random) + :revn (:revn row) + :vern (:vern row) + :features cfeat/supported-features + :changes changes})] + (t/is (nil? (:error out))) + (:result out))) + +(defn- add-rect + [page-id] + (let [id (uuid/random)] + {:type :add-obj + :page-id page-id + :id id + :parent-id uuid/zero + :frame-id uuid/zero + :components-v2 true + :obj (cts/setup-shape {:id id + :name "rect" + :frame-id uuid/zero + :parent-id uuid/zero + :type :rect})})) + +(defn- create-branch! + [profile-id file-id name] + (let [out (th/command! {::th/type :create-file-branch + ::rpc/profile-id profile-id + :file-id file-id + :name name})] + (t/is (nil? (:error out))) + (:result out))) + +(defn- live-fragment-ids + [file-id] + (->> (th/db-query :file-data {:file-id file-id :type "fragment"}) + (filter #(nil? (:deleted-at %))) + (into #{} (map :id)))) + +(defn- page-pointer-ids + "{page-id -> fragment id} of decoded file data." + [data] + (into {} + (keep (fn [[id page]] + (when (pmap/pointer-map? page) + [id (pmap/get-id page)]))) + (:pages-index data))) + +(defn- base-snapshot + [branch-id] + (let [row (th/db-get :file-branch {:id branch-id})] + (fsnap/get-snapshot th/*system* (:source-file-id row) (:base-snapshot-id row)))) + +(defn- holds-pointers? + [data] + (let [found (volatile! false)] + (walk/prewalk (fn [x] + (when (pmap/pointer-map? x) (vreset! found true)) + (if (pmap/pointer-map? x) {} x)) + data) + @found)) + +(defn- realized-data + [file-id] + (:data (bfc/get-file th/*system* file-id :realize? true))) + +(defn- setup + [] + (t/is (pointer-map-enabled?) "these tests need fdata/pointer-map") + (let [profile (th/create-profile* 1 {:is-active true}) + file (th/create-file* 1 {:profile-id (:id profile) + :project-id (:default-project-id profile) + :is-shared false})] + {:profile-id (:id profile) :file-id (:id file)})) + +(t/deftest create-stores-the-base-as-source-pointers + (with-redefs [cf/flags (conj cf/flags :branching)] + (let [{:keys [profile-id file-id]} (setup) + before (live-fragment-ids file-id) + branch (create-branch! profile-id file-id "pointers") + base (base-snapshot (:id branch)) + ids (page-pointer-ids (:data base))] + ;; every page of the base is a pointer into the source file's own + ;; fragment rows, and creating the branch wrote no fragment + (t/is (seq ids)) + (t/is (= (count ids) (count (:pages-index (:data base))))) + (t/is (every? before (vals ids))) + (t/is (= before (live-fragment-ids file-id)))))) + +(t/deftest base-readers-realize-with-the-source-file-id + (with-redefs [cf/flags (conj cf/flags :branching)] + (let [{:keys [profile-id file-id]} (setup) + branch (create-branch! profile-id file-id "readers") + ;; whatever creation stores, pin a base that holds the source + ;; file's pointers: the readers are what this test is about + source (bfc/get-file th/*system* file-id) + _ (t/is (seq (page-pointer-ids (:data source)))) + snap (fsnap/create! th/*system* source + {:label "branch-base/readers" + :profile-id profile-id + :created-by "system"}) + _ (th/db-update! :file-branch + {:base-snapshot-id (:id snap)} + {:id (:id branch)}) + main (realized-data file-id)] + + (t/testing "the derive reads the base" + (let [file (bfc/get-file th/*system* (:branch-file-id branch) + :realize? true :include-base-data? true)] + (t/is (not (holds-pointers? (:data file)))) + (t/is (= (:pages-index main) (:pages-index (:data file)))) + (t/is (not (holds-pointers? (::bfc/base-data file)))) + (t/is (= (:pages-index main) (:pages-index (::bfc/base-data file)))))) + + (t/testing "the snapshot reader reads the base" + (let [row (th/db-get :file-branch {:id (:id branch)}) + data (db/run! th/*system* #(#'fbranch/get-base-data % row))] + (t/is (not (holds-pointers? data))) + (t/is (= (:pages-index main) (:pages-index data)))))))) + +(t/deftest file-gc-keeps-the-fragments-a-base-names + (with-redefs [cf/flags (conj cf/flags :branching)] + (let [{:keys [profile-id file-id]} (setup) + branch (create-branch! profile-id file-id "gc") + page-id (first (:pages (realized-data file-id))) + pinned (set (vals (page-pointer-ids (:data (base-snapshot (:id branch))))))] + (t/is (seq pinned)) + + ;; the edit replaces the page's fragment on main, so only the + ;; base still names the old one + (update-file! profile-id file-id [(add-rect page-id)]) + (let [main-ids (set (vals (page-pointer-ids + (:data (bfc/get-file th/*system* file-id)))))] + (t/is (seq (remove main-ids pinned)))) + + (t/is (true? (th/run-task! :file-gc {:file-id file-id}))) + (t/is (every? (live-fragment-ids file-id) pinned)) + + (let [diff (:result (th/command! {::th/type :get-branch-diff + ::rpc/profile-id profile-id + :branch-id (:id branch) + :direction :main->branch}))] + (t/is (= 1 (-> diff :stats :added))))))) + +(t/deftest update-from-main-pins-main-pointers + (with-redefs [cf/flags (conj cf/flags :branching)] + (let [{:keys [profile-id file-id]} (setup) + branch (create-branch! profile-id file-id "update") + page-id (first (:pages (realized-data file-id)))] + (update-file! profile-id file-id [(add-rect page-id)]) + (let [out (th/command! {::th/type :update-branch-from-main + ::rpc/profile-id profile-id + :branch-id (:id branch)})] + (t/is (nil? (:error out))) + (t/is (= :updated (-> out :result :status)))) + + ;; the repositioned base names main's current fragments for every + ;; page the update left equal to main + (let [main-ids (page-pointer-ids (:data (bfc/get-file th/*system* file-id))) + base-ids (page-pointer-ids (:data (base-snapshot (:id branch))))] + (t/is (seq base-ids)) + (t/is (= main-ids base-ids))) + + (t/is (= (:pages-index (realized-data file-id)) + (:pages-index (realized-data (:branch-file-id branch)))))))) + +(t/deftest merge-keeps-the-fragments-of-untouched-pages + (with-redefs [cf/flags (conj cf/flags :branching)] + (let [{:keys [profile-id file-id]} (setup) + page-a (first (:pages (realized-data file-id))) + page-b (uuid/random) + _ (update-file! profile-id file-id + [{:type :add-page :id page-b :name "B"}]) + branch (create-branch! profile-id file-id "merge") + before (page-pointer-ids (:data (bfc/get-file th/*system* file-id)))] + (update-file! profile-id (:branch-file-id branch) [(add-rect page-a)]) + (let [out (th/command! {::th/type :merge-file-branch + ::rpc/profile-id profile-id + :branch-id (:id branch)})] + (t/is (nil? (:error out))) + (t/is (= :merged (-> out :result :status)))) + + (let [after (page-pointer-ids (:data (bfc/get-file th/*system* file-id)))] + ;; the merged page is new, the untouched one keeps its fragment + (t/is (not= (get before page-a) (get after page-a))) + (t/is (= (get before page-b) (get after page-b)))))))