From 8e6264474139ba3b3f615c359f480a0c7e1aa399 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=C3=81lvaro=20Tejero=20Cantero?= Date: Thu, 1 Oct 2026 19:46:32 +0200 Subject: [PATCH] :bug: Fix the open defects of the branching tech preview Merge engine: a same-parent reorder, an addition under a parent main deleted, and a branch deleting a container main edited each lost work silently. Each now follows a policy read from backend/resources/app/branch-merge-policies.edn, re-read when the file changes, with the defaults: merge the reorder, and raise a conflict on the deleted parent or container. Added siblings keep the branch's order. A :mov-page index counts the target's full page list, a cleared page background reaches main, a per-attribute resolution can remove an attribute, and a token set reorder survives a rename on the other side. Conflict payloads name :main and :branch by document in both directions. Reorder detection costs nothing measurable on a page of 20,201 objects. Data versions: each op-log row records the data version it was written at, the branch replays its log in segments and migrates the document at each boundary, and the comparison base is migrated like main and the branch, so an upgrade no longer shows as false conflicts. Writers: a binfile import, an admin repair, file GC and a snapshot restore refuse a branch file, whose payload nothing reads, and the branch base pin cannot be renamed into a user snapshot. A branch save runs the ordinary media fix-up and logs the rewritten references. An update from main deletes the branch's copy of media main deleted and squashes no phantom media changes. Commands and UI: the pull-request commands publish their messages after the commit, the listing takes one connection per comparison and shows a warning instead of "in sync" when a comparison fails, materialize takes :branch-file-id, and a dashboard fetch that never answers ends in an error state instead of a spinner, with a refetch on reconnect. backend/dev/branch_merge_cases.clj builds one example file per merge policy case for demonstrating the alternatives. Two models wrote this change, claude-opus-5-5 and mimo-v2.6-pro, and the work switched between them, so the trailer reads mixed models. AI-assisted-by: mixed models --- backend/dev/branch_merge_cases.clj | 305 ++++ .../resources/app/branch-merge-policies.edn | 47 + backend/src/app/binfile/common.clj | 128 +- backend/src/app/binfile/v3.clj | 14 + backend/src/app/config.clj | 8 + backend/src/app/migrations.clj | 5 +- ...58-add-file-branch-change-data-version.sql | 18 + backend/src/app/rpc/commands/files_branch.clj | 1255 +++++++++-------- .../rpc/commands/files_branch_policies.clj | 103 ++ .../app/rpc/commands/files_pull_request.clj | 116 +- .../src/app/rpc/commands/files_snapshot.clj | 18 + backend/src/app/rpc/commands/files_update.clj | 37 +- backend/src/app/srepl/helpers.clj | 10 + backend/src/app/srepl/procs/media_refs.clj | 2 +- backend/src/app/tasks/file_gc.clj | 22 +- backend/src/app/tasks/file_gc_scheduler.clj | 1 + backend/test/backend_tests/binfile_test.clj | 43 + .../branch_payload_writers_test.clj | 117 ++ .../rpc_file_branch_oplog_test.clj | 490 ++++++- .../backend_tests/rpc_file_branch_test.clj | 420 +++++- .../rpc_file_pull_request_test.clj | 122 ++ .../backend_tests/rpc_file_snapshot_test.clj | 112 ++ common/src/app/common/files/branch_merge.cljc | 949 +++++++++++-- common/src/app/common/files/migrations.cljc | 121 +- .../common_tests/files_branch_merge_test.cljc | 474 ++++++- .../common_tests/files_migrations_test.cljc | 46 + frontend/src/app/main/data/dashboard.cljs | 59 +- frontend/src/app/main/data/project.cljs | 10 +- .../src/app/main/data/workspace/branches.cljs | 9 +- frontend/src/app/main/refs.cljs | 5 + frontend/src/app/main/repo.cljs | 7 + frontend/src/app/main/ui/dashboard.cljs | 17 +- .../main/ui/dashboard/branches_popover.cljs | 12 +- .../main/ui/dashboard/branches_popover.scss | 6 + frontend/src/app/main/ui/dashboard/files.cljs | 7 +- .../app/main/ui/dashboard/placeholder.cljs | 18 +- .../src/app/main/ui/dashboard/projects.cljs | 7 +- .../main/ui/workspace/sidebar/branches.cljs | 116 +- .../main/ui/workspace/sidebar/branches.scss | 6 + .../frontend_tests/data/dashboard_test.cljs | 78 + frontend/translations/en.po | 4 + 41 files changed, 4436 insertions(+), 908 deletions(-) create mode 100644 backend/dev/branch_merge_cases.clj create mode 100644 backend/resources/app/branch-merge-policies.edn create mode 100644 backend/src/app/migrations/sql/0158-add-file-branch-change-data-version.sql create mode 100644 backend/src/app/rpc/commands/files_branch_policies.clj create mode 100644 backend/test/backend_tests/branch_payload_writers_test.clj diff --git a/backend/dev/branch_merge_cases.clj b/backend/dev/branch_merge_cases.clj new file mode 100644 index 0000000000..ce82d4724c --- /dev/null +++ b/backend/dev/branch_merge_cases.clj @@ -0,0 +1,305 @@ +;; 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 branch-merge-cases + "Ready-made branch-merge policy scenarios. + + `create!` builds one file per tree-shape case in a new project of the + profile's default team, with main and a branch already diverged: + open the branch in the UI, press Compare to see the case, press Merge + to trigger it. Every file name says its case. + + The cases: + + (a) the branch reorders one parent's children (Compare shows the + child-order change; a `:merge` applies it as a `:mov-objects` + change, `:refuse` refuses naming the parent, `:ignore` drops + it silently) + (b) main and the branch reorder the same parent differently + (`:merge` makes it a conflict on the parent) + (c) main deletes the frame P and the branch adds a shape inside P + (d) the branch deletes the frame F and main recolours F's child C + and adds N inside F + (e) the branch adds three siblings in the order A, B, C (a merge + must keep that order) + + HOW TO RUN IT + + The builder runs in the backend's own REPL inside the devenv, so the + files it creates are ordinary files in the database the UI serves: + + 1. `.devenv/devenv repl` on the host bridges the container's backend + nREPL (port 6064, the default `scripts/nrepl-eval.mjs` connects + to). The bridge and its constraints are described in + `.devenv/USAGE.md` (\"The entry point and the pieces behind it\"). + 2. From the repo root, evaluate (the nREPL session persists between + invocations, so the second call sees the loaded namespace): + + node scripts/nrepl-eval.mjs '(require (quote branch-merge-cases))' + node scripts/nrepl-eval.mjs \\ + '(branch-merge-cases/create! {:email \"you@example.com\" :project-name \"20261001-branch-merge-policies\"})' + + The email is the devenv test account's, readable from + `~/.config/penpot-devenv/test-account.json` (`.email`; never print + its password). The call returns `{:project ... :files [...]}` and + prints the created files with their ids. + + If the backend process predates the branch-merge policy code, load it + first (the compare path then binds the policies file around every + comparison): + + node scripts/nrepl-eval.mjs \\ + '(require (quote app.rpc.commands.files-branch-policies) (quote app.rpc.commands.files-branch))' + + HOW TO FLIP A POLICY + + Edit `backend/resources/app/branch-merge-policies.edn` (or whatever + file `:branch-merge-policies-file` / + `PENPOT_BRANCH_MERGE_POLICIES_FILE` names), save it, and press + Compare again: the backend re-reads the file whenever its mtime + changes — no restart. The alternatives: + + :same-parent-reorder :merge | :refuse | :ignore + :addition-under-deleted-parent :conflict | :refuse | :reparent-to-ancestor | :page-root + :container-delete-over-main-edits :conflict | :expand | :cascade + + An invalid file logs a warning and the engine runs the built-in + defaults until the file is fixed." + (:require + [app.common.features :as cfeat] + [app.common.time :as ct] + [app.common.types.shape :as cts] + [app.common.uuid :as uuid] + [app.db :as db] + [app.loggers.audit :as audit] + [app.rpc :as-alias rpc] + [app.system :as sys] + [clojure.pprint :refer [print-table]] + [clojure.string :as str])) + +;; --- Plumbing: the same RPC command functions the API serves, run on +;; the live system map (`app.system/sys/system`). + +(defn- command! + "Run the registered RPC command `type` with `params` the way the RPC + middleware does: the params carry the profile id and the request + time. Audit is skipped — its middleware wants the HTTP request of a + real call, and the RPC tests drive commands the same way." + [type params] + (let [[_ method-fn] (get-in sys/system [:app.rpc/methods type])] + (when-not method-fn + (throw (ex-info (str "rpc method not found: " (name type)) {:type type}))) + (with-redefs [audit/prepare-rpc-event (fn [& _] nil) + audit/submit (constantly nil)] + (method-fn (assoc params :app.rpc/request-at (ct/now)))))) + +(defn- get-profile + [email] + (or (db/get* sys/system :profile {:email (str/lower-case email)}) + (throw (ex-info "no profile for this email" {:email email})))) + +(defn- file-row + [file-id] + (db/get* sys/system :file {:id file-id})) + +(defn- page-id-of + [profile-id file-id] + (-> (command! :get-file {:app.rpc/profile-id profile-id :id file-id}) + :data :pages first)) + +(defn- update! + "Apply `changes` to `file-id` through the ordinary update-file RPC — + which is what the editor sends and what routes a branch file's saves + into its op log." + [profile-id file-id changes] + (let [{:keys [revn vern]} (file-row file-id)] + (command! :update-file + {:app.rpc/profile-id profile-id + :id file-id + :session-id (uuid/next) + :revn revn + :vern vern + :features cfeat/supported-features + :changes (vec changes)}))) + +;; --- The change vocabulary the editor emits + +(defn- shape + [id name type parent-id frame-id] + (cts/setup-shape {:id id :name name :type type + :parent-id parent-id :frame-id frame-id})) + +(defn- add-obj + [page-id {:keys [id parent-id frame-id] :as obj}] + {:type :add-obj + :page-id page-id + :id id + :parent-id parent-id + :frame-id frame-id + :obj obj}) + +(defn- del-obj + [page-id id] + {:type :del-obj :page-id page-id :id id}) + +(defn- mod-obj + [page-id id operations] + {:type :mod-obj :page-id page-id :id id :operations (vec operations)}) + +(defn- reorder-children + [page-id parent-id shapes] + {:type :reorder-children + :page-id page-id + :parent-id parent-id + :shapes (vec shapes)}) + +;; --- The cases: each returns {:file-name :branch-name :base :branch +;; :main}, where `base` is main's content before the fork and +;; `:branch`/`:main` are the diverging edits after it — each a function +;; of the page id returning a change vector. + +(defn- case-reorder-branch-only + "The branch reorders the children of the parent frame P; main is + untouched." + [] + (let [parent (uuid/next) + c1 (uuid/next) + c2 (uuid/next) + c3 (uuid/next)] + {:file-name "(a) same-parent reorder on the branch only" + :branch-name "reorder" + :base (fn [page-id] + [(add-obj page-id (shape parent "parent" :frame uuid/zero uuid/zero)) + (add-obj page-id (shape c1 "child-1" :rect parent parent)) + (add-obj page-id (shape c2 "child-2" :rect parent parent)) + (add-obj page-id (shape c3 "child-3" :rect parent parent))]) + :branch (fn [page-id] + [(reorder-children page-id parent [c2 c3 c1])]) + :main nil})) + +(defn- case-reorder-both-sides + "Main and the branch reorder the same parent frame's children into + two different orders." + [] + (let [parent (uuid/next) + c1 (uuid/next) + c2 (uuid/next) + c3 (uuid/next)] + {:file-name "(b) both sides reorder one parent differently" + :branch-name "reorder-diverging" + :base (fn [page-id] + [(add-obj page-id (shape parent "parent" :frame uuid/zero uuid/zero)) + (add-obj page-id (shape c1 "child-1" :rect parent parent)) + (add-obj page-id (shape c2 "child-2" :rect parent parent)) + (add-obj page-id (shape c3 "child-3" :rect parent parent))]) + :branch (fn [page-id] + [(reorder-children page-id parent [c3 c1 c2])]) + :main (fn [page-id] + [(reorder-children page-id parent [c2 c3 c1])])})) + +(defn- case-add-under-deleted-parent + "Main deletes the frame P while the branch adds a shape inside it." + [] + (let [parent (uuid/next) + child (uuid/next) + added (uuid/next)] + {:file-name "(c) main deletes frame P, branch adds a shape inside P" + :branch-name "add-under-deleted" + :base (fn [page-id] + [(add-obj page-id (shape parent "P" :frame uuid/zero uuid/zero)) + (add-obj page-id (shape child "child" :rect parent parent))]) + :branch (fn [page-id] + [(add-obj page-id (shape added "added-inside-P" :rect parent parent))]) + :main (fn [page-id] + [(del-obj page-id parent)])})) + +(defn- case-delete-container-over-main-edits + "The branch deletes the frame F while main recolours F's child C and + adds N inside F." + [] + (let [frame (uuid/next) + child (uuid/next) + added (uuid/next)] + {:file-name "(d) branch deletes frame F, main recolours child C and adds N inside F" + :branch-name "delete-container" + :base (fn [page-id] + [(add-obj page-id (shape frame "F" :frame uuid/zero uuid/zero)) + (add-obj page-id (shape child "C" :rect frame frame))]) + :branch (fn [page-id] + [(del-obj page-id frame)]) + :main (fn [page-id] + [(mod-obj page-id child + [{:type :set + :attr :fills + :val [{:fill-color "#ff0000" :fill-opacity 1}]}]) + (add-obj page-id (shape added "N" :rect frame frame))])})) + +(defn- case-addition-order + "The branch adds three siblings under the frame S, in the order A, B, + C — a merge must keep that order." + [] + (let [frame (uuid/next) + a (uuid/next) + b (uuid/next) + c (uuid/next)] + {:file-name "(e) branch adds three siblings in the order A, B, C" + :branch-name "add-three" + :base (fn [page-id] + [(add-obj page-id (shape frame "S" :frame uuid/zero uuid/zero))]) + :branch (fn [page-id] + [(add-obj page-id (shape a "sibling-A" :rect frame frame)) + (add-obj page-id (shape b "sibling-B" :rect frame frame)) + (add-obj page-id (shape c "sibling-C" :rect frame frame))]) + :main nil})) + +(defn- create-case! + "Create the case's file, write its base content on main, fork the + branch, then apply the two diverging edits. Returns the file ids." + [profile-id project-id {:keys [file-name branch-name base branch main]}] + (let [file-id (:id (command! :create-file + {:app.rpc/profile-id profile-id + :project-id project-id + :name file-name})) + page-id (page-id-of profile-id file-id) + _ (when base + (update! profile-id file-id (base page-id))) + create (command! :create-file-branch + {:app.rpc/profile-id profile-id + :file-id file-id + :name branch-name}) + branch-id (:id create)] + (when branch + (update! profile-id (:branch-file-id create) (branch page-id))) + (when main + (update! profile-id file-id (main page-id))) + {:id file-id + :name file-name + :branch-id branch-id + :branch-file-id (:branch-file-id create)})) + +(defn create! + "Create the five policy cases as files in a NEW project of the + profile's default team. Returns `{:project {:id :name} :files [...]}` + and prints the created files with their ids and names." + [{:keys [email project-name]}] + (when-not (and (string? email) (string? project-name)) + (throw (ex-info "expected {:email \"..\" :project-name \"..\"}" + {:email email :project-name project-name}))) + (let [profile (get-profile email) + project (command! :create-project + {:app.rpc/profile-id (:id profile) + :team-id (:default-team-id profile) + :name project-name}) + files (mapv (fn [build] (create-case! (:id profile) (:id project) (build))) + [case-reorder-branch-only + case-reorder-both-sides + case-add-under-deleted-parent + case-delete-container-over-main-edits + case-addition-order])] + (println "project:" (:name project) (str (:id project))) + (print-table [:id :name :branch-id :branch-file-id] files) + {:project {:id (:id project) :name (:name project)} + :files files})) diff --git a/backend/resources/app/branch-merge-policies.edn b/backend/resources/app/branch-merge-policies.edn new file mode 100644 index 0000000000..3f27381b16 --- /dev/null +++ b/backend/resources/app/branch-merge-policies.edn @@ -0,0 +1,47 @@ +;; Branch merge policies: the switch that decides how the merge engine +;; resolves the three tree-shape cases where a silent default drops work. +;; +;; This file is re-read whenever its mtime changes, so a policy flip is: +;; edit the value here, re-run the compare or merge — no restart. An +;; invalid file logs a warning and the engine falls back to the built-in +;; defaults (`app.common.files.branch-merge/default-policies`) until the +;; file is fixed. A key left out of the map keeps its default. +;; +;; Every policy is one key with one value; the comments under each key +;; list the alternatives with a sentence each. + +{;; --- :same-parent-reorder + ;; The branch — or both sides — reorders the children of one parent. + ;; + ;; :merge detect the child-order change, show it in the compare and + ;; apply it as a :mov-objects change; both sides reordering + ;; the same parent differently is a conflict on the parent. + ;; :refuse the merge/update refuses with :unsupported, naming the + ;; parent. + ;; :ignore today's behaviour: the reorder is dropped silently. + :same-parent-reorder :merge + + ;; --- :addition-under-deleted-parent + ;; main deleted the frame P while the branch added a shape inside P. + ;; + ;; :conflict a :modify-delete conflict on P: :branch + ;; restores P as the branch has it, addition + ;; included; :main drops the addition. + ;; :refuse the merge/update refuses with :unsupported. + ;; :reparent-to-ancestor place the addition under the nearest + ;; ancestor main still has. + ;; :page-root today's behaviour: the addition lands at + ;; the page root. + :addition-under-deleted-parent :conflict + + ;; --- :container-delete-over-main-edits + ;; The branch deleted the container F while main modified or added + ;; anything inside F's subtree. + ;; + ;; :conflict a :delete-modify conflict on F: :branch deletes the + ;; whole subtree knowingly; :main keeps F and its subtree + ;; as main has them. + ;; :expand delete only shapes the branch deleted; main's additions + ;; move to F's parent. + ;; :cascade today's behaviour: the whole subtree goes. + :container-delete-over-main-edits :conflict} diff --git a/backend/src/app/binfile/common.clj b/backend/src/app/binfile/common.clj index 30f1369b20..cd2fcde299 100644 --- a/backend/src/app/binfile/common.clj +++ b/backend/src/app/binfile/common.clj @@ -295,7 +295,7 @@ END") (def ^:private sql:get-branch-changes - "SELECT changes + "SELECT changes, data_version FROM file_branch_change WHERE file_id = ? AND deleted_at IS NULL @@ -309,10 +309,50 @@ (->> (db/exec! conn [sql:get-branch-changes branch-file-id]) (mapv (fn [{:keys [changes]}] (blob/decode changes))))) +(defn- migrate-detached + "Migrate `file` in memory with `migrate-fn`, called as + `(migrate-fn file libs)`, under the bindings `migrate-file` sets up. + Persists nothing: the branch derive migrates documents it builds + 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)] + (migrate-fn file (delay (get-resolved-file-libraries cfg file))))) + +(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 + taken, while `get-file` migrates main and the branch on every read, so + a three-way comparison sees one version on all three sides only when + the base migrates the same way, with main's libraries. A base already + at the current version comes back as it is. + + `snapshot` is a snapshot row with its data decoded: `:file-id`, + `:data`, `:version` and the `:migrations` its data holds." + [cfg {:keys [file-id data version migrations]}] + (let [base {:id file-id + :data data + :version version + :migrations (some-> migrations not-empty set)}] + (if (fmg/need-migration? base) + (:data (migrate-detached cfg base fmg/migrate-file)) + data))) + (defn- branch-file-data "Derive the `:data` of a branch file: the merge-base snapshot plus every op appended to the branch's log, replayed in revn order. + Each op-log row records the data version its changes were written at. + The replay starts from the base at the base's version, and before a + row written at a later version it migrates the document to that + version, the point where an ordinary file migrates across an upgrade. + The document never migrates past the version of the next row, because + a migration assumes its input is at the version before it. The file + returned carries the version and migration set the replay ended at, so + `get-file*` migrates the rest of the way in memory, and a log with no + upgrade since the base (the steady state) never migrates at all. + Returns the file with `:data` decoded (plain maps); callers that asked for `:decode? false` get it re-encoded as bytes so the update-file pipeline (which always blob-decodes) is unaffected. @@ -328,10 +368,11 @@ ordinary read neither times nor logs anything. With `include-base-data?` true the returned file also carries the - decoded merge-base document under `::base-data`, which is the value - the replay starts from. A caller that is about to compare the branch - with its base reads the branch file with that flag and takes the - value, and it never decodes the same snapshot a second time." + merge-base document under `::base-data`, migrated to the current data + version (`migrate-branch-base`), the version `get-file` brings main and + the branch to. A caller that is about to compare the branch with its + base reads the branch file with that flag and takes the value, and it + never decodes the same snapshot a second time." [{:keys [::db/conn] :as cfg} {:keys [id] :as file} decode? include-base-data?] (let [tpoint (ct/tpoint) @@ -373,27 +414,48 @@ rows (db/exec! conn [sql:get-branch-changes id]) - ;; the decoded merge-base document. It is what the replay starts - ;; from, and `process-changes` builds its result with persistent - ;; updates and never writes into its input, so this value stays - ;; the pre-replay state while `data` becomes the branch. A caller - ;; that needs the merge base takes this value instead of decoding - ;; the same snapshot a second time. - base-data (:data base) + ;; the document the replay works on: the merge base at the + ;; base's data version, under the branch file's identity, so a + ;; migration on the way resolves the branch's libraries + doc (-> file + (assoc :data (:data base)) + (assoc :version (or (:version base) (:version file))) + (assoc :migrations (:migrations base))) ;; the derive replays the log batch by batch, so each batch is ;; decoded exactly once. `depth` is the flattened op count, the ;; quantity `files_branch.clj::check-oplog-depth-limit!` limits, ;; and the one that predicts the cost of the replay. - [data depth] - (reduce (fn [[data depth] {:keys [changes]}] - (let [changes (blob/decode changes)] - [(cpc/process-changes data changes) + ;; + ;; A row's `data_version` is the version its changes were + ;; written at; the document migrates to it before the row + ;; applies, and in the steady state that check is one set + ;; lookup. A NULL stamp marks a row written before the column + ;; existed: it replays at the version the document holds, which + ;; is the base's version, because such rows precede every + ;; stamped row of their log. That is how the derive replayed + ;; every row before the column existed. + [doc depth] + (reduce (fn [[doc depth] {:keys [changes data-version]}] + (let [changes (blob/decode changes) + doc (if (fmg/need-migration-to? doc data-version) + (migrate-detached cfg doc #(fmg/migrate-file-to %1 %2 data-version)) + doc)] + [(update doc :data cpc/process-changes changes) (+ depth (count changes))])) - [base-data 0] + [doc 0] rows) - data (if decode? data (blob/encode data)) + data (cond-> (:data doc) + (not decode?) (blob/encode)) + + ;; the comparison's `base` is the merge base before the replay, + ;; at the version main and the branch are read at. The replay + ;; returns the branch's own state in `data`, so a comparison + ;; handed `data` as its base would compare the branch with + ;; itself. + base-data (when include-base-data? + (migrate-branch-base cfg base)) ;; measured once so the log line and the audit props carry the same ;; number. The timer covers the re-encode as well when the caller @@ -407,20 +469,16 @@ :duration-ms duration) (-> file - ;; the derived data is the BASE's data plus the op log, so the - ;; file carries the base's version and migration set; this keeps - ;; `need-migration?` quiet while base and main share a version - ;; and migrates in memory (read-only) only when the base is - ;; actually stale + ;; the derived data carries the version and migration set the + ;; replay ended at: the base's own while no row was written past + ;; it, which keeps `need-migration?` quiet in the steady state, + ;; and a later one when the replay crossed an upgrade (assoc :data data) - (assoc :version (or (:version base) (:version file))) - (cond-> (some? (:migrations base)) - (assoc :migrations (:migrations base))) + (assoc :version (:version doc)) + (assoc :features (:features doc)) + (cond-> (some? (:migrations doc)) + (assoc :migrations (:migrations doc))) (cond-> include-base-data? - ;; the comparison's `base` is the value the replay started from, - ;; which is the merge base as decoded. The replay returns the - ;; branch's own state in `data`, so a comparison handed `data` - ;; as its base would compare the branch with itself. (assoc ::base-data base-data)) ;; the numbers travel with the value, because the RPC audit event ;; of the read that paid for this derive reads `::audit/props` off @@ -432,6 +490,7 @@ {:branch-derive-ms duration :branch-oplog-depth depth :branch-oplog-batches (count rows)})))) + (defn- get-file* [{:keys [::db/conn] :as cfg} id {:keys [migrate? @@ -726,7 +785,12 @@ (defn update-media-references! "Given a file and a coll of media-refs, check if all provided - references are correct or fix them in-place" + references are correct or fix them in-place. Returns a tuple of the + fixed file and the id remapping the fix applied ({foreign-id -> + copy-id}): the file data is rewritten in-place, but a caller that + persists a change vector instead of the data (the branch save path) + has to record the same remap in it, or its derive reproduces the + unfixed references." [{:keys [::db/conn] :as cfg} {file-id :id :as file} media-refs] (let [missing-index (reduce (fn [result {:keys [id] :as fmo}] @@ -769,7 +833,7 @@ (db/insert! conn :file-media-object item {::db/return-keys false})) - file)) + [file (update-vals missing-index :id)])) (def sql:get-file-media "SELECT * FROM file_media_object WHERE id = ANY(?)") diff --git a/backend/src/app/binfile/v3.clj b/backend/src/app/binfile/v3.clj index cdb3037714..dab4a719f1 100644 --- a/backend/src/app/binfile/v3.clj +++ b/backend/src/app/binfile/v3.clj @@ -1212,6 +1212,11 @@ (db/exec! cfg [sql-1 file-id]) (db/exec! cfg [sql-2 file-id])))))) +(def ^:private sql:is-branch-file + "SELECT f.is_branch + FROM file AS f + WHERE f.id = ?") + (defn- import-file-and-overwrite* [{:keys [::manifest ::bfc/file-id] :as cfg}] @@ -1221,6 +1226,15 @@ :hint "unable to perform in-place update with binfile containing more than 1 file" :manifest manifest)) + ;; A branch file's data payload is derived from the branch base and + ;; the operation log; overwriting it would persist a `file_data` row + ;; no read path consults. + (when (:is-branch (db/exec-one! cfg [sql:is-branch-file file-id])) + (ex/raise :type :validation + :code :branch-file-cant-be-overwritten + :hint "branch file data is derived from the branch base and the operation log and can't be overwritten by an import" + :file-id file-id)) + (bfc/configure-database-timeouts! cfg) (let [ref-file (bfc/get-minimal-file cfg file-id ::db/for-update true) diff --git a/backend/src/app/config.clj b/backend/src/app/config.clj index 6db77fb269..8f2b6f734e 100644 --- a/backend/src/app/config.clj +++ b/backend/src/app/config.clj @@ -53,6 +53,8 @@ :branching-max-pages 500 :branching-max-oplog-changes 100000 + :branch-merge-policies-file "resources/app/branch-merge-policies.edn" + :public-uri "http://localhost:3449" :host "localhost" @@ -171,6 +173,12 @@ [:branching-max-pages {:optional true} ::sm/int] [:branching-max-oplog-changes {:optional true} ::sm/int] + ;; The branch-merge policy switch file: a commented EDN map that + ;; picks one alternative per policy. Re-read on mtime change, so it + ;; can be edited while the backend runs. See + ;; `app.rpc.commands.files-branch-policies`. + [:branch-merge-policies-file {:optional true} ::fs/path] + [:media-max-file-size {:optional true} ::sm/int] [:font-max-file-size {:optional true} ::sm/int] diff --git a/backend/src/app/migrations.clj b/backend/src/app/migrations.clj index 4dc4cee0c3..ce7be5ca10 100644 --- a/backend/src/app/migrations.clj +++ b/backend/src/app/migrations.clj @@ -526,7 +526,10 @@ :fn (mg/resource "app/migrations/sql/0156-add-file-pull-request-tables.sql")} {:name "0157-add-file-branch-change-table" - :fn (mg/resource "app/migrations/sql/0157-add-file-branch-change-table.sql")}]) + :fn (mg/resource "app/migrations/sql/0157-add-file-branch-change-table.sql")} + + {:name "0158-add-file-branch-change-data-version" + :fn (mg/resource "app/migrations/sql/0158-add-file-branch-change-data-version.sql")}]) (defn apply-migrations! [pool name migrations] diff --git a/backend/src/app/migrations/sql/0158-add-file-branch-change-data-version.sql b/backend/src/app/migrations/sql/0158-add-file-branch-change-data-version.sql new file mode 100644 index 0000000000..7d9f57c6fb --- /dev/null +++ b/backend/src/app/migrations/sql/0158-add-file-branch-change-data-version.sql @@ -0,0 +1,18 @@ +-- The data version each op-log row was written at: the name of the last +-- file data migration (`app.common.files.migrations/available-migrations`) +-- of the backend that applied the row's changes. A data version is a +-- prefix of that list, so its last name identifies it. The branch derive +-- (`app.binfile.common/branch-file-data`) replays the log in segments: it +-- migrates the document to a row's version before it applies the row, the +-- point where an ordinary file migrates across an upgrade. +-- +-- The merge base needs no column of its own: its snapshot row +-- (`file_change.migrations`) records the migrations its data holds. +-- +-- NULL marks a row written before this column existed. The derive replays +-- such a row at the version the document holds, which is the base's +-- version because those rows precede every stamped row of their log. That +-- is how the derive replayed every row before this column existed. + +ALTER TABLE file_branch_change + ADD COLUMN IF NOT EXISTS data_version text NULL; diff --git a/backend/src/app/rpc/commands/files_branch.clj b/backend/src/app/rpc/commands/files_branch.clj index 4fa3e36f81..3a26303a8e 100644 --- a/backend/src/app/rpc/commands/files_branch.clj +++ b/backend/src/app/rpc/commands/files_branch.clj @@ -20,6 +20,7 @@ [app.common.files.branch-merge :as bm] [app.common.files.changes :as cpc] [app.common.files.helpers :as cfh] + [app.common.files.migrations :as fmg] [app.common.files.repair :as cfr] [app.common.files.validate :as cfv] [app.common.logging :as l] @@ -39,6 +40,7 @@ [app.rpc :as-alias rpc] [app.rpc.climit :as-alias climit] [app.rpc.commands.files :as files] + [app.rpc.commands.files-branch-policies :as bp] [app.rpc.commands.files-update :as fupd] [app.rpc.commands.teams :as teams] [app.rpc.doc :as-alias doc] @@ -256,35 +258,53 @@ ;; --- Helpers: merge base snapshot (defn- get-base-data - "The merge-base `:data` from the branch's base snapshot. Raises when the + "The merge-base `:data` from the branch's base snapshot, migrated to + the current data version (`bfc/migrate-branch-base`): `bfc/get-file` + migrates main and the branch on read, and a base left at an older + version reads as a change on every side that migrated. Raises when the snapshot cannot be resolved: silently falling back to main would degrade the three-way merge into \"branch overwrites main\" without conflicts. Prefer `branch-base-data` where the branch file was read with `:include-base-data? true`: the derive decoded the merge base to replay the op log over it, so this function would decode the same snapshot a - second time." - [cfg {:keys [source-file-id base-snapshot-id] :as branch}] + second time. + + The snapshot stores the branch's frame — its media references name the + branch's own paired rows, what the replay reproduces — while a + comparison runs in main's frame, so the media ids are normalized back + here through the pairs, the way `branch-id-map` normalizes the branch's + own data." + [cfg {:keys [source-file-id branch-file-id base-snapshot-id] :as branch}] (when-not base-snapshot-id (ex/raise :type :not-found :code :base-snapshot-missing :hint "the branch has no merge-base snapshot" :branch-id (:id branch))) - (:data (fsnap/get-snapshot cfg source-file-id base-snapshot-id))) + (when-some [data (some->> (fsnap/get-snapshot cfg source-file-id base-snapshot-id) + (bfc/migrate-branch-base cfg))] + (bm/remap-refs data (media-pairs cfg branch-file-id source-file-id)))) (defn- branch-base-data "The comparison's `base`: the merge-base document that a branch file read with `:include-base-data? true` carries under `::bfc/base-data`. That document is the state the branch's op log was replayed over, that - is the merge base before the replay. The file's `:data` holds the - branch's own state, so a comparison against `:data` would compare the - branch with itself. Raises when the key is absent, so a read that - forgot the flag fails loudly instead of comparing against nil." - [branch-file] - (or (::bfc/base-data branch-file) - (ex/raise :type :assertion - :code :branch-base-data-missing - :hint "the branch file was read without `:include-base-data? true`"))) + is the merge base before the replay, migrated to the current data + version like the two sides it is compared with. The file's `:data` + holds the branch's own state, so a comparison against `:data` would + compare the branch with itself. Raises when the key is absent, so a + read that forgot the flag fails loudly instead of comparing against + nil. + + Like `get-base-data`, it comes back with the media ids normalized into + main's frame: the snapshot names the branch's own paired rows, the + comparison runs against main's." + [cfg source-file-id {:keys [id] :as branch-file}] + (-> (or (::bfc/base-data branch-file) + (ex/raise :type :assertion + :code :branch-base-data-missing + :hint "the branch file was read without `:include-base-data? true`")) + (bm/remap-refs (media-pairs cfg id source-file-id)))) (defn- release-base-snapshot! "Reschedule a branch's base snapshot for normal deletion: it is pinned @@ -645,36 +665,38 @@ result is worth caching, and a value computed from an error must never enter the summary cache." [cfg main-data {:keys [source-file-id branch-file-id ahead-revn behind-revn]}] - (if (and (zero? ahead-revn) (zero? behind-revn)) - [0 0 0] - (let [main-data (or main-data (:data (bfc/get-file cfg source-file-id :realize? true))) - ;; the derive hands back the merge base it replayed the log over, - ;; so the comparison's `base` costs one decode of the snapshot - ;; rather than two - branch-file (bfc/get-file cfg branch-file-id :realize? true - :include-base-data? true) - branch-data (bm/remap-refs - (:data branch-file) - (branch-id-map cfg branch-file-id source-file-id)) - base-data (branch-base-data branch-file) - clean-count (fn [m] (let [s (:stats m)] - (+ (:added s) (:modified s) (:deleted s)))) - fwd (when (pos? ahead-revn) - (bm/compute-merge base-data main-data branch-data :branch->main - (when-let [pages (branch-affected-pages cfg branch-file-id)] - {:only-pages pages}))) - bwd (when (pos? behind-revn) - (bm/compute-merge base-data branch-data main-data :branch->main))] - [(if fwd (clean-count fwd) 0) - (if bwd (clean-count bwd) 0) - ;; conflicts are symmetric; only possible when both sides diverged - (if (and (pos? ahead-revn) (pos? behind-revn)) (count (:conflicts fwd)) 0)]))) + (bp/with-policies + (if (and (zero? ahead-revn) (zero? behind-revn)) + [0 0 0] + (let [main-data (or main-data (:data (bfc/get-file cfg source-file-id :realize? true))) + ;; the derive hands back the merge base it replayed the log over, + ;; so the comparison's `base` costs one decode of the snapshot + ;; rather than two + branch-file (bfc/get-file cfg branch-file-id :realize? true + :include-base-data? true) + branch-data (bm/remap-refs + (:data branch-file) + (branch-id-map cfg branch-file-id source-file-id)) + base-data (branch-base-data cfg source-file-id branch-file) + clean-count (fn [m] (let [s (:stats m)] + (+ (:added s) (:modified s) (:deleted s)))) + fwd (when (pos? ahead-revn) + (bm/compute-merge base-data main-data branch-data :branch->main + (when-let [pages (branch-affected-pages cfg branch-file-id)] + {:only-pages pages}))) + bwd (when (pos? behind-revn) + (bm/compute-merge base-data branch-data main-data :branch->main))] + [(if fwd (clean-count fwd) 0) + (if bwd (clean-count bwd) 0) + ;; conflicts are symmetric; only possible when both sides diverged + (if (and (pos? ahead-revn) (pos? behind-revn)) (count (:conflicts fwd)) 0)])))) (def ^:private branch-summary-cache "The per-branch `[ahead behind conflicts]` summary, keyed by - `(base-snapshot-id, source-revn, branch-revn)` — exactly the inputs the - computation reads. A stale key is a cache miss, and a cache miss is the - old behaviour, so the cache needs no invalidation logic; `keepalive` + `(base-snapshot-id, source-revn, branch-revn)` and a hash of the + effective policies — exactly the inputs the computation reads. A + stale key is a cache miss, and a cache miss is the old behaviour, so + the cache needs no invalidation logic; `keepalive` and `max-size` bound memory, they never decide correctness. The window is a working day rather than minutes because the fetch this @@ -688,8 +710,11 @@ (ucache/create :max-size 8192 :keepalive "8h")) (defn- summary-cache-key + "The cache key: the branch's own counters plus a hash of the policies + the cached value is computed under, so flipping a policy can never + answer from a summary computed with the old one." [{:keys [base-snapshot-id source-revn branch-revn]}] - [base-snapshot-id source-revn branch-revn]) + [base-snapshot-id source-revn branch-revn (bp/policies-hash)]) (defn cached-summary "The cached summary of a branch row, or nil when it would have to be @@ -697,34 +722,41 @@ before it pays for it, and a listing whose rows are all cached needs no main at all." [row] - (ucache/get branch-summary-cache (summary-cache-key row))) + (bp/with-policies + (ucache/get branch-summary-cache (summary-cache-key row)))) (defn cached-diff-counts - "`branch-diff-counts!` behind the summary cache, degrading to zeros with - a warning when the base snapshot cannot be resolved: a listing is - read-only, and merge/update DO refuse loudly in that situation (reading - the branch file raises `:base-snapshot-missing`). A value computed from - an error never enters the cache. + "`branch-diff-counts!` behind the summary cache, answering `[ahead + behind conflicts]` or nil when the comparison cannot be made: the base + snapshot cannot be resolved (reading the branch file raises + `:base-snapshot-missing`, and merge/update DO refuse loudly in that + situation), so a listing that stays read-only reports the failure + instead of repairing anything. The answer is nil and never zeros: zeros + read as \"in sync\", and a branch that cannot be compared is not in + sync; callers surface it as an error marker with no counts at all. The + warning line is the trace left in the log. A value computed from an + error never enters the cache. `branch` carries the key tuple and the pair being compared, with `source-file-id` naming main and `branch-file-id` the branch, whichever listing is asking." [cfg main-data branch] - (let [[ahead-revn behind-revn] (revn-deltas branch)] - (try - (ucache/get branch-summary-cache - (summary-cache-key branch) - (fn [_] - (branch-diff-counts! cfg main-data - (assoc branch - :ahead-revn ahead-revn - :behind-revn behind-revn)))) - (catch Throwable cause - (l/wrn :hint "unable to compute branch diff counts" - :branch-file-id (str (:branch-file-id branch)) - :source-file-id (str (:source-file-id branch)) - :cause cause) - [0 0 0])))) + (bp/with-policies + (let [[ahead-revn behind-revn] (revn-deltas branch)] + (try + (ucache/get branch-summary-cache + (summary-cache-key branch) + (fn [_] + (branch-diff-counts! cfg main-data + (assoc branch + :ahead-revn ahead-revn + :behind-revn behind-revn)))) + (catch Throwable cause + (l/wrn :hint "unable to compute branch diff counts" + :branch-file-id (str (:branch-file-id branch)) + :source-file-id (str (:source-file-id branch)) + :cause cause) + nil))))) (sv/defmethod ::get-file-branches "List the branches of a file. `ahead`/`behind` are entity-level change @@ -732,6 +764,16 @@ in-sync branches skip the diff entirely; `main` is realized once and shared across branches. + A row whose comparison cannot be made carries `:diff-error true` and no + counts at all: zeros read as \"in sync\", and a branch that cannot be + compared is not in sync. The listing stays read-only and repairs + nothing; merge/update DO refuse loudly in that situation. + + The listing query takes one pooled connection. Every comparison takes + its own connection and returns it, so no connection is held while the + (expensive) diffs run: a listing of many diverged branches costs one + connection at a time and cannot starve the pool. + A cold listing is one of the slowest things a user meets, so the listing reports its own duration to `audit_log` and to the log, together with the two numbers that explain that duration: how many open diverged @@ -749,36 +791,47 @@ ::climit/id [[:get-file-branches/global]]} [cfg {:keys [::rpc/profile-id file-id include-archived]}] (check-branching-enabled!) - (db/run! cfg - (fn [{:keys [::db/conn] :as cfg}] - (files/check-read-permissions! cfg profile-id file-id) - (let [tpoint (ct/tpoint) - rows (db/exec! conn [sql:get-file-branches file-id (boolean include-archived)]) - ;; only OPEN branches get diff counts: merged/archived ones - ;; are not going to be merged as-is, so the expensive diff - ;; would be wasted work (and their base may be released) - open? (fn [row] (= "open" (:status row))) - ;; an open branch whose cheap revn deltas say it diverged is - ;; the only one the listing looks a comparison up for - diverged? (fn [row] (let [[a b] (revn-deltas row)] (or (pos? a) (pos? b)))) - compared (filterv (fn [row] (and (open? row) (diverged? row))) rows) - ;; the rows the summary cache answers without computing - cached (filterv (comp some? cached-summary) compared) - ;; realize main once, only if some compared branch is not - ;; already cached - need? (< (count cached) (count compared)) - main-data (when need? (:data (bfc/get-file cfg file-id :realize? true))) - branches (mapv (fn [row] - (let [[ahead behind conflicts] (if (open? row) - (cached-diff-counts cfg main-data row) - [0 0 0])] - (-> row - (assoc :ahead ahead :behind behind :conflicts conflicts) - (dissoc :branch-revn :source-revn :base-snapshot-id :base-branch-revn)))) - rows)] - (audited branches tpoint :list-branches - {:branches-compared (count compared) - :branches-cached (count cached)}))))) + (let [tpoint (ct/tpoint) + rows (db/run! cfg + (fn [{:keys [::db/conn] :as cfg}] + (files/check-read-permissions! cfg profile-id file-id) + (db/exec! conn [sql:get-file-branches file-id (boolean include-archived)]))) + ;; only OPEN branches get diff counts: merged/archived ones + ;; are not going to be merged as-is, so the expensive diff + ;; would be wasted work (and their base may be released) + open? (fn [row] (= "open" (:status row))) + ;; an open branch whose cheap revn deltas say it diverged is + ;; the only one the listing looks a comparison up for + diverged? (fn [row] (let [[a b] (revn-deltas row)] (or (pos? a) (pos? b)))) + compared (filterv (fn [row] (and (open? row) (diverged? row))) rows) + ;; the rows the summary cache answers without computing + cached (filterv (comp some? cached-summary) compared) + ;; realize main once, only if some compared branch is not + ;; already cached + need? (< (count cached) (count compared)) + main-data (when need? + (db/run! cfg (fn [cfg] (:data (bfc/get-file cfg file-id :realize? true))))) + branches (mapv (fn [row] + (let [counts (if (open? row) + ;; a cached summary answers without + ;; touching the database; anything + ;; else compares on a connection of + ;; its own, taken and returned around + ;; the comparison + (or (cached-summary row) + (db/run! cfg (fn [cfg] (cached-diff-counts cfg main-data row)))) + [0 0 0]) + [ahead behind conflicts] counts] + (cond-> (-> row + (assoc :ahead ahead :behind behind :conflicts conflicts) + (dissoc :branch-revn :source-revn :base-snapshot-id :base-branch-revn)) + ;; the comparison could not be made: the + ;; marker stands where the counts would be + (nil? counts) (assoc :diff-error true)))) + rows)] + (audited branches tpoint :list-branches + {:branches-compared (count compared) + :branches-cached (count cached)}))) ;; --- COMMAND QUERY: get-branch-diff @@ -796,62 +849,63 @@ (`reposition-base!` in `update-branch-from-main`). Returns the summary produced by `branch-merge/compute-merge` (stats, changes, conflicts). - NOTE (Phase 2): base/main/branch are assumed to share the same file - data version; explicit migration normalization before diffing is a - later refinement." + The base is read at the current data version, the version `bfc/get-file` + reads main and the branch at (`bfc/migrate-branch-base`), so a Penpot + upgrade since the branch was cut does not read as a change on any side." {::doc/added "2.16" ::sm/params schema:get-branch-diff ::climit/id [[:get-branch-diff/global]] ::db/transaction true} [{:keys [::db/conn] :as cfg} {:keys [::rpc/profile-id branch-id direction]}] - (check-branching-enabled!) - (let [branch (db/get* conn :file-branch {:id branch-id})] - (when (nil? branch) - (ex/raise :type :not-found - :code :branch-not-found - :hint "unable to find branch with the provided id" - :branch-id branch-id)) + (bp/with-policies + (check-branching-enabled!) + (let [branch (db/get* conn :file-branch {:id branch-id})] + (when (nil? branch) + (ex/raise :type :not-found + :code :branch-not-found + :hint "unable to find branch with the provided id" + :branch-id branch-id)) - (files/check-read-permissions! cfg profile-id (:source-file-id branch)) + (files/check-read-permissions! cfg profile-id (:source-file-id branch)) - (let [tpoint (ct/tpoint) - dir (or direction :branch->main) - main-file (-> (bfc/get-file cfg (:source-file-id branch) :realize? true) - (check-file-size-limits! :compare)) - branch-file (bfc/get-file cfg (:branch-file-id branch) - :realize? true :include-base-data? true) - log (-> (branch-log cfg (:branch-file-id branch)) - (check-oplog-depth-limit! (:branch-file-id branch) :compare)) - main-data (:data main-file) - branch-data (bm/remap-refs - (:data branch-file) - (branch-id-map cfg (:branch-file-id branch) (:source-file-id branch))) - base-data (branch-base-data branch-file) - ;; when the CURRENT merge-base snapshot row was created: the - ;; base moves whenever `update-branch-from-main` repositions it, - ;; and a pinned base carries a future `deleted-at` - base-at (:created-at (db/get* conn :file-change - {:id (:base-snapshot-id branch)} - {::sql/columns [:created-at] - ::db/remove-deleted false})) - ;; only the branch->main direction may be bounded to the pages - ;; the branch touched: the other direction is main's changes and - ;; nothing here knows which pages those are - opts (when (= dir :branch->main) - (when-let [pages (affected-pages log)] - {:only-pages pages}))] - ;; `:meta` carries the "when" of each side so the resolution UI can show - ;; how recent main/branch are (base is the snapshot its - ;; `base-snapshot-id` currently points at), plus - ;; `:main-revn` so the client can do optimistic concurrency on merge - ;; (`expected-main-revn`). The last editor's identity is intentionally - ;; omitted: files do not store a reliable "modified-by". - (-> (bm/compute-merge base-data main-data branch-data dir opts) - (assoc :meta {:base-at base-at - :main-at (:modified-at main-file) - :branch-at (:modified-at branch-file) - :main-revn (:revn main-file)}) - (audited tpoint :compare))))) + (let [tpoint (ct/tpoint) + dir (or direction :branch->main) + main-file (-> (bfc/get-file cfg (:source-file-id branch) :realize? true) + (check-file-size-limits! :compare)) + branch-file (bfc/get-file cfg (:branch-file-id branch) + :realize? true :include-base-data? true) + log (-> (branch-log cfg (:branch-file-id branch)) + (check-oplog-depth-limit! (:branch-file-id branch) :compare)) + main-data (:data main-file) + branch-data (bm/remap-refs + (:data branch-file) + (branch-id-map cfg (:branch-file-id branch) (:source-file-id branch))) + base-data (branch-base-data cfg (:source-file-id branch) branch-file) + ;; when the CURRENT merge-base snapshot row was created: the + ;; base moves whenever `update-branch-from-main` repositions it, + ;; and a pinned base carries a future `deleted-at` + base-at (:created-at (db/get* conn :file-change + {:id (:base-snapshot-id branch)} + {::sql/columns [:created-at] + ::db/remove-deleted false})) + ;; only the branch->main direction may be bounded to the pages + ;; the branch touched: the other direction is main's changes and + ;; nothing here knows which pages those are + opts (when (= dir :branch->main) + (when-let [pages (affected-pages log)] + {:only-pages pages}))] + ;; `:meta` carries the "when" of each side so the resolution UI can show + ;; how recent main/branch are (base is the snapshot its + ;; `base-snapshot-id` currently points at), plus + ;; `:main-revn` so the client can do optimistic concurrency on merge + ;; (`expected-main-revn`). The last editor's identity is intentionally + ;; omitted: files do not store a reliable "modified-by". + (-> (bm/compute-merge base-data main-data branch-data dir opts) + (assoc :meta {:base-at base-at + :main-at (:modified-at main-file) + :branch-at (:modified-at branch-file) + :main-revn (:revn main-file)}) + (audited tpoint :compare)))))) ;; --- Helpers: post-commit notification ;; @@ -859,9 +913,10 @@ ;; when it returns, so the messages a transaction collects in `messages` ;; leave here, right after the commit: a client that reloads on one of ;; them reads the committed state, and a rolled back transaction -;; publishes nothing. +;; publishes nothing. Shared with the pull-request commands +;; (`app.rpc.commands.files-pull-request`). -(defn- tx-run-notify! +(defn tx-run-notify! "Run `f` in a transaction, then publish the `messages` it collected (a volatile of `{:topic .. :message ..}` maps) and return its result." [cfg msgbus messages f] @@ -905,207 +960,216 @@ [:merge-file-branch/global]]} [{:keys [::mbus/msgbus] :as cfg} {:keys [::rpc/profile-id ::rpc/session-id branch-id resolutions expected-main-revn keep-branch]}] - (check-branching-enabled!) - (let [branch (db/get* cfg :file-branch {:id branch-id})] - (when (nil? branch) - (ex/raise :type :not-found - :code :branch-not-found - :branch-id branch-id)) - (when (not= "open" (:status branch)) - (ex/raise :type :validation - :code :branch-not-open - :branch-id branch-id)) + (bp/with-policies + (check-branching-enabled!) + (let [branch (db/get* cfg :file-branch {:id branch-id})] + (when (nil? branch) + (ex/raise :type :not-found + :code :branch-not-found + :branch-id branch-id)) + (when (not= "open" (:status branch)) + (ex/raise :type :validation + :code :branch-not-open + :branch-id branch-id)) - (let [tpoint (ct/tpoint) - main-id (:source-file-id branch) - branch-file-id (:branch-file-id branch) - messages (volatile! [])] - ;; Only editors of main can integrate (same rule as Figma). - (files/check-edition-permissions! cfg profile-id main-id) + (let [tpoint (ct/tpoint) + main-id (:source-file-id branch) + branch-file-id (:branch-file-id branch) + messages (volatile! [])] + ;; Only editors of main can integrate (same rule as Figma). + (files/check-edition-permissions! cfg profile-id main-id) - (tx-run-notify! - cfg - msgbus - messages - (fn [{:keys [::db/conn] :as cfg}] - ;; Serialize against concurrent edits/merges on BOTH files (same - ;; advisory lock the normal update-file path takes; stable order - ;; to avoid deadlocks): without the branch lock, edits saved to - ;; the branch while the merge runs would be silently lost when - ;; the branch is marked merged (and possibly deleted) below. - (run! (partial db/xact-lock! conn) (sort [main-id branch-file-id])) + (tx-run-notify! + cfg + msgbus + messages + (fn [{:keys [::db/conn] :as cfg}] + ;; Serialize against concurrent edits/merges on BOTH files (same + ;; advisory lock the normal update-file path takes; stable order + ;; to avoid deadlocks): without the branch lock, edits saved to + ;; the branch while the merge runs would be silently lost when + ;; the branch is marked merged (and possibly deleted) below. + (run! (partial db/xact-lock! conn) (sort [main-id branch-file-id])) - ;; the row read before the lock is stale by now: a competing - ;; merge, delete or archive may have committed while these - ;; locks were taken, so everything below works off the row as - ;; it stands under the lock - (let [branch (or (db/get* conn :file-branch {:id branch-id}) - (ex/raise :type :not-found - :code :branch-not-found + ;; the row read before the lock is stale by now: a competing + ;; merge, delete or archive may have committed while these + ;; locks were taken, so everything below works off the row as + ;; it stands under the lock + (let [branch (or (db/get* conn :file-branch {:id branch-id}) + (ex/raise :type :not-found + :code :branch-not-found + :branch-id branch-id)) + _ (when (not= "open" (:status branch)) + (ex/raise :type :validation + :code :branch-not-open :branch-id branch-id)) - _ (when (not= "open" (:status branch)) - (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)) - _ (-> (branch-log cfg branch-file-id) - (check-oplog-depth-limit! branch-file-id :merge)) - branch-file (bfc/get-file cfg branch-file-id - :realize? true :include-base-data? true) - base-data (branch-base-data branch-file) + main-file (-> (bfc/get-file cfg main-id :realize? true) + (check-file-size-limits! :merge)) + _ (-> (branch-log cfg branch-file-id) + (check-oplog-depth-limit! branch-file-id :merge)) + branch-file (bfc/get-file cfg branch-file-id + :realize? true :include-base-data? true) + base-data (branch-base-data cfg main-id branch-file) - ;; canonicalize the branch's local refs to main's ids: the - ;; branch file id (components, library color/typography - ;; refs) and the paired media ids; media ADDED on the - ;; branch gets fresh ids pre-allocated here — the rows are - ;; copied into main only if the merge actually applies. - pairs (media-pairs cfg branch-file-id main-id) - new-media (unpaired-media-rows cfg branch-file-id (:data branch-file) pairs) - fresh-map (into {} (map (fn [row] [(:id row) (uuid/next)])) new-media) - id-map (-> pairs - (merge fresh-map) - (assoc branch-file-id main-id)) - branch-data (bm/remap-refs (:data branch-file) id-map)] + ;; canonicalize the branch's local refs to main's ids: the + ;; branch file id (components, library color/typography + ;; refs) and the paired media ids; media ADDED on the + ;; branch gets fresh ids pre-allocated here — the rows are + ;; copied into main only if the merge actually applies. + pairs (media-pairs cfg branch-file-id main-id) + new-media (unpaired-media-rows cfg branch-file-id (:data branch-file) pairs) + fresh-map (into {} (map (fn [row] [(:id row) (uuid/next)])) new-media) + id-map (-> pairs + (merge fresh-map) + (assoc branch-file-id main-id)) + branch-data (bm/remap-refs (:data branch-file) id-map)] - (when (and (some? expected-main-revn) - (not= expected-main-revn (:revn main-file))) - (ex/raise :type :conflict - :code :file-modified - :hint "main was modified, recompute the diff and retry")) + (when (and (some? expected-main-revn) + (not= expected-main-revn (:revn main-file))) + (ex/raise :type :conflict + :code :file-modified + :hint "main was modified, recompute the diff and retry")) - (let [merge-summary (bm/compute-merge base-data (:data main-file) - branch-data :branch->main) - conflicts (:conflicts merge-summary) - resolved? (fn [c] (bm/conflict-resolved? c (get resolutions (:id c)))) - unresolved (remove resolved? conflicts) - - finish-branch! - (fn [ts] - ;; mark merged. The pinned base snapshot stays for a - ;; KEPT branch (its state is derived from that - ;; snapshot and the op log, so releasing the pin - ;; would leave it unreadable once the snapshot GC - ;; runs); delete-branch! releases it on the delete - ;; path. Unless the user chose to keep it the branch - ;; and its file are deleted in this same transaction - ;; (no client-driven second call, no window where a - ;; crash leaves a stale copy). - (db/update! conn :file-branch - {:status "merged" - :merged-at ts - :merged-by profile-id - :updated-at ts} - {:id branch-id} - {::db/return-keys false}) - (let [team (teams/get-team conn :profile-id profile-id :file-id main-id) - delay (ldel/get-deletion-delay team)] - ;; an open pull request over this branch has served - ;; its purpose: mark it merged and close its sandbox - (close-branch-pull-requests! cfg branch-id - {:profile-id profile-id - :status "merged" - :deleted-at (ct/in-future delay)}) - (when-not keep-branch - (vswap! messages conj - (delete-branch! cfg branch {:profile-id profile-id - :session-id session-id})))))] - (cond - (seq unresolved) - (audited {:status :conflicts :conflicts conflicts} tpoint :merge) - - :else - (let [{:keys [changes unsupported]} - (bm/compute-changes base-data (:data main-file) branch-data - (or resolutions {}) - merge-summary)] - (cond - (seq unsupported) - (audited {:status :unsupported :kinds (vec unsupported)} tpoint :merge) - - (empty? changes) - ;; Nothing to integrate (branch matches main): close the - ;; branch without touching main. - (let [ts (ct/now)] - (finish-branch! ts) - (audited {:status :merged :revn (:revn main-file) :source-file-id main-id} - tpoint :merge)) - - :else - (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)] - - ;; 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}) - - ;; 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)) - - ;; 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}) - - (fupd/persist-file! (assoc cfg ::fupd/timestamp ts) merged) - - (when (contains? cf/flags :redis-cache) - (fupd/invalidate-caches! cfg merged)) - - (finish-branch! ts) + (let [merge-summary (bm/compute-merge base-data (:data main-file) + branch-data :branch->main) + conflicts (:conflicts merge-summary) + resolved? (fn [c] (bm/conflict-resolved? c (get resolutions (:id c)))) + unresolved (remove resolved? conflicts) + finish-branch! + (fn [ts] + ;; mark merged. The pinned base snapshot stays for a + ;; KEPT branch (its state is derived from that + ;; snapshot and the op log, so releasing the pin + ;; would leave it unreadable once the snapshot GC + ;; runs); delete-branch! releases it on the delete + ;; path. Unless the user chose to keep it the branch + ;; and its file are deleted in this same transaction + ;; (no client-driven second call, no window where a + ;; crash leaves a stale copy). + (db/update! conn :file-branch + {:status "merged" + :merged-at ts + :merged-by profile-id + :updated-at ts} + {:id branch-id} + {::db/return-keys false}) + (let [team (teams/get-team conn :profile-id profile-id :file-id main-id) + delay (ldel/get-deletion-delay team)] + ;; an open pull request over this branch has served + ;; its purpose: mark it merged and close its sandbox + (close-branch-pull-requests! cfg branch-id + {:profile-id profile-id + :status "merged" + :deleted-at (ct/in-future delay)}) + (when-not keep-branch (vswap! messages conj - {:topic main-id - :message {:type :file-merged - :file-id main-id - :session-id session-id - :revn (:revn merged)}}) + (delete-branch! cfg branch {:profile-id profile-id + :session-id session-id})))))] + (cond + (seq unresolved) + (audited {:status :conflicts :conflicts conflicts} tpoint :merge) - (audited {:status :merged :revn (:revn merged) :source-file-id main-id} - tpoint :merge)))))))))))))) + :else + (let [{:keys [changes unsupported]} + (bm/compute-changes base-data (:data main-file) branch-data + (or resolutions {}) + merge-summary)] + (cond + (seq unsupported) + (audited {:status :unsupported + :kinds (vec unsupported) + ;; the `:refuse` policies refuse on a named + ;; entity: surface the summary entries so + ;; the response names the parent or + ;; container it refuses on + :entities (vec (filter #(= :unsupported (:status %)) + (:changes merge-summary)))} + tpoint :merge) + + (empty? changes) + ;; Nothing to integrate (branch matches main): close the + ;; branch without touching main. + (let [ts (ct/now)] + (finish-branch! ts) + (audited {:status :merged :revn (:revn main-file) :source-file-id main-id} + tpoint :merge)) + + :else + (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)] + + ;; 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}) + + ;; 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)) + + ;; 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}) + + (fupd/persist-file! (assoc cfg ::fupd/timestamp ts) merged) + + (when (contains? cf/flags :redis-cache) + (fupd/invalidate-caches! cfg merged)) + + (finish-branch! ts) + + (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))))))))))))))) ;; --- COMMAND: update-branch-from-main @@ -1124,7 +1188,10 @@ branch-only changes. The repositioned merge base already carries everything main contributed, so replaying the squash over it reproduces the updated branch exactly, and the log never accumulates - main-side ops (which would otherwise be double-applied on read)." + main-side ops (which would otherwise be double-applied on read). + + The squash is computed between documents `bfc/get-file` read at the + current data version, so its row records that version." [{:keys [::db/conn] :as cfg} file ts branch-id changes] (let [file (-> file (dissoc ::snapshot) @@ -1142,6 +1209,7 @@ :file-id (:id file) :revn (:revn file) :changes (blob/encode (vec changes)) + :data-version (fmg/data-version) :created-at ts :updated-at ts} {::db/return-keys false})) @@ -1164,262 +1232,297 @@ [:update-branch-from-main/global]]} [{:keys [::mbus/msgbus] :as cfg} {:keys [::rpc/profile-id ::rpc/session-id branch-id resolutions expected-main-revn]}] - (check-branching-enabled!) - (let [branch (db/get* cfg :file-branch {:id branch-id})] - (when (nil? branch) - (ex/raise :type :not-found :code :branch-not-found :branch-id branch-id)) - (when (not= "open" (:status branch)) - (ex/raise :type :validation :code :branch-not-open :branch-id branch-id)) + (bp/with-policies + (check-branching-enabled!) + (let [branch (db/get* cfg :file-branch {:id branch-id})] + (when (nil? branch) + (ex/raise :type :not-found :code :branch-not-found :branch-id branch-id)) + (when (not= "open" (:status branch)) + (ex/raise :type :validation :code :branch-not-open :branch-id branch-id)) - (let [tpoint (ct/tpoint) - branch-file-id (:branch-file-id branch) - main-id (:source-file-id branch) - messages (volatile! [])] - ;; Editing the branch -> need edition permissions on the branch file. - (files/check-edition-permissions! cfg profile-id branch-file-id) + (let [tpoint (ct/tpoint) + branch-file-id (:branch-file-id branch) + main-id (:source-file-id branch) + messages (volatile! [])] + ;; Editing the branch -> need edition permissions on the branch file. + (files/check-edition-permissions! cfg profile-id branch-file-id) - (tx-run-notify! - cfg - msgbus - messages - (fn [{:keys [::db/conn] :as cfg}] - (db/xact-lock! conn branch-file-id) + (tx-run-notify! + cfg + msgbus + messages + (fn [{:keys [::db/conn] :as cfg}] + (db/xact-lock! conn branch-file-id) - ;; the row read before the lock is stale by now: a competing - ;; merge, delete or archive may have committed while this lock - ;; was taken, so everything below works off the row as it - ;; stands under the lock - (let [branch (or (db/get* conn :file-branch {:id branch-id}) - (ex/raise :type :not-found - :code :branch-not-found + ;; the row read before the lock is stale by now: a competing + ;; merge, delete or archive may have committed while this lock + ;; was taken, so everything below works off the row as it + ;; stands under the lock + (let [branch (or (db/get* conn :file-branch {:id branch-id}) + (ex/raise :type :not-found + :code :branch-not-found + :branch-id branch-id)) + _ (when (not= "open" (:status branch)) + (ex/raise :type :validation + :code :branch-not-open :branch-id branch-id)) - _ (when (not= "open" (:status branch)) - (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)) - _ (when (and (some? expected-main-revn) - (not= expected-main-revn (:revn main-file))) - (ex/raise :type :conflict - :code :file-modified - :hint "main was modified, recompute the diff and retry")) - _ (-> (branch-log cfg branch-file-id) - (check-oplog-depth-limit! branch-file-id :update-from-main)) - branch-file (bfc/get-file cfg branch-file-id :realize? true) - base-raw (get-base-data cfg branch) + main-file (-> (bfc/get-file cfg main-id :realize? true) + (check-file-size-limits! :update-from-main)) + _ (when (and (some? expected-main-revn) + (not= expected-main-revn (:revn main-file))) + (ex/raise :type :conflict + :code :file-modified + :hint "main was modified, recompute the diff and retry")) + _ (-> (branch-log cfg branch-file-id) + (check-oplog-depth-limit! branch-file-id :update-from-main)) + branch-file (bfc/get-file cfg branch-file-id :realize? true) + base-raw (get-base-data cfg branch) - team (teams/get-team conn :profile-id profile-id :file-id branch-file-id) - delay (ldel/get-deletion-delay team) + team (teams/get-team conn :profile-id profile-id :file-id branch-file-id) + delay (ldel/get-deletion-delay team) - ;; Two id maps, one per direction of the crossing. - ;; - ;; The COMPARISON runs in main's frame, the frame the merge - ;; base was captured in, the frame the compare view uses - ;; (`files_branch.clj::branch-id-map` in - ;; `files_branch.clj::get-branch-diff`), and the only frame - ;; the branch's inherited content agrees with. A branch stores - ;; no data, so `binfile.clj::branch-file-data` replays its op - ;; log over that base and everything it inherited carries the - ;; base's ids. Comparing in the branch's frame instead - ;; rewrites main's and the base's local references to the - ;; branch file id, and a self reference in main is then - ;; unequal to the branch's own copy of it, so every shape - ;; main touched that carries one reads as an edit on both - ;; sides. - base-data base-raw - main-raw (:data main-file) - branch-cmp (bm/remap-refs (:data branch-file) - (branch-id-map cfg branch-file-id main-id)) + ;; Two id maps, one per direction of the crossing. + ;; + ;; The COMPARISON runs in main's frame, the frame the merge + ;; base was captured in, the frame the compare view uses + ;; (`files_branch.clj::branch-id-map` in + ;; `files_branch.clj::get-branch-diff`), and the only frame + ;; the branch's inherited content agrees with. A branch stores + ;; no data, so `binfile.clj::branch-file-data` replays its op + ;; log over that base and everything it inherited carries the + ;; base's ids. Comparing in the branch's frame instead + ;; rewrites main's and the base's local references to the + ;; branch file id, and a self reference in main is then + ;; unequal to the branch's own copy of it, so every shape + ;; main touched that carries one reads as an edit on both + ;; sides. + base-data base-raw + main-raw (:data main-file) + branch-cmp (bm/remap-refs (:data branch-file) + (branch-id-map cfg branch-file-id main-id)) - ;; The WRITE runs in the branch's frame: a reference is only a - ;; reference in the file it names, so main's file id and - ;; main's media rows are re-pointed at the branch's ids before - ;; the change reaches the branch. Media ADDED on main has no - ;; branch row yet, so it gets a fresh id here and its row is - ;; copied below only if the update applies. - pairs (media-pairs cfg main-id branch-file-id) - new-media (unpaired-media-rows cfg main-id main-raw pairs) - fresh-map (into {} (map (fn [row] [(:id row) (uuid/next)])) new-media) - apply-map (-> pairs - (merge fresh-map) - (assoc main-id branch-file-id)) - main-data (bm/remap-refs main-raw apply-map) + ;; The WRITE runs in the branch's frame: a reference is only a + ;; reference in the file it names, so main's file id and + ;; main's media rows are re-pointed at the branch's ids before + ;; the change reaches the branch. Media ADDED on main has no + ;; branch row yet, so it gets a fresh id here and its row is + ;; copied below only if the update applies. + pairs (media-pairs cfg main-id branch-file-id) + new-media (unpaired-media-rows cfg main-id main-raw pairs) + fresh-map (into {} (map (fn [row] [(:id row) (uuid/next)])) new-media) + ;; the branch's OWN frame: every media row the branch + ;; references is one of its own — a paired copy or one of + ;; the fresh copies made below. The write and the pinned + ;; base name those; `apply-map` adds the file id on top for + ;; the change payloads, which re-point their file refs too. + media-map (merge pairs fresh-map) + apply-map (assoc media-map main-id branch-file-id) + main-data (bm/remap-refs main-raw apply-map) - ;; did the branch carry its OWN changes before this update? - ;; (revn moved since the base was last positioned) - branch-diverged? - (pos? (- (:revn branch-file) - (:base-branch-revn branch))) + ;; did the branch carry its OWN changes before this update? + ;; (revn moved since the base was last positioned) + branch-diverged? + (pos? (- (:revn branch-file) + (:base-branch-revn branch))) - reposition-base! - (fn [ts branch-revn] - (let [new-base (fsnap/create! cfg main-file - {:label (str "branch-base/" (:name branch)) - :created-by "system" - :deleted-at (ct/in-future {:days 3650}) - :profile-id profile-id}) - ;; the ahead/behind revn gate compares each side's revn - ;; against this stored counter to SKIP the diff. After - ;; an update the new base equals MAIN, so a branch that - ;; had its own changes still differs from it even if - ;; its revn never moves again — keep the gate open by - ;; storing one revn less; the diff then reports the - ;; real counts. - branch-revn (if branch-diverged? (dec branch-revn) branch-revn)] - ;; the previous base is superseded: release its pin - (release-base-snapshot! cfg branch (ct/in-future delay)) - (db/update! conn :file-branch - {:base-snapshot-id (:id new-base) - :base-revn (:revn main-file) - :base-branch-revn branch-revn - :updated-at ts} - {:id branch-id} - {::db/return-keys false}))) + reposition-base! + (fn [ts branch-revn base-data] + ;; the base is pinned in the branch's frame — its media + ;; references name the branch's own rows — because it is + ;; what the op log replays over: the derived document + ;; carries that frame, 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 frame on read (`get-base-data`/`branch-base-data`). + (let [new-base (fsnap/create! cfg (assoc main-file :data base-data) + {:label (str "branch-base/" (:name branch)) + :created-by "system" + :deleted-at (ct/in-future {:days 3650}) + :profile-id profile-id}) + ;; the ahead/behind revn gate compares each side's revn + ;; against this stored counter to SKIP the diff. After + ;; an update the new base equals MAIN, so a branch that + ;; had its own changes still differs from it even if + ;; its revn never moves again — keep the gate open by + ;; storing one revn less; the diff then reports the + ;; real counts. + branch-revn (if branch-diverged? (dec branch-revn) branch-revn)] + ;; the previous base is superseded: release its pin + (release-base-snapshot! cfg branch (ct/in-future delay)) + (db/update! conn :file-branch + {:base-snapshot-id (:id new-base) + :base-revn (:revn main-file) + :base-branch-revn branch-revn + :updated-at ts} + {:id branch-id} + {::db/return-keys false}))) - merge-summary - (bm/compute-merge base-data main-raw branch-cmp :main->branch) + merge-summary + (bm/compute-merge base-data main-raw branch-cmp :main->branch) - conflicts (:conflicts merge-summary) - resolved? (fn [c] (bm/conflict-resolved? c (get resolutions (:id c)))) - unresolved (remove resolved? conflicts) + conflicts (:conflicts merge-summary) + resolved? (fn [c] (bm/conflict-resolved? c (get resolutions (:id c)))) + unresolved (remove resolved? conflicts) - ;; UI resolutions are in main/branch terms; the update applies - ;; main->branch (compute-changes target=branch, source=main), - ;; where :branch means "take the source (main)". So invert each - ;; side — including the per-attr maps, value by value. - flip (fn [v] (case v :main :branch, :branch :main, v)) - inverted (into {} (map (fn [[k v]] - [k (if (map? v) - (update-vals v flip) - (flip v))])) - resolutions)] + ;; Resolutions arrive document-keyed (`:main` = main's value). + ;; The update runs compute-changes with main as the source and + ;; the branch as the target, where the `:branch` keyword means + ;; "take the source (main)" — so invert each side to that + ;; vocabulary, including the per-attr maps, value by value. + flip (fn [v] (case v :main :branch, :branch :main, v)) + inverted (into {} (map (fn [[k v]] + [k (if (map? v) + (update-vals v flip) + (flip v))])) + resolutions)] - (cond - (seq unresolved) - (audited {:status :conflicts :conflicts conflicts} tpoint :update-from-main) + (cond + (seq unresolved) + (audited {:status :conflicts :conflicts conflicts} tpoint :update-from-main) - :else - ;; target = branch, source = main -> changes that bring main's - ;; net changes (and conflicts resolved to main) into the branch. - ;; The `:main->branch` summary maps to the same (theirs, ours) - ;; assignment compute-changes uses internally here, so it can - ;; be reused for the unsupported-kinds gate without re-diffing. - (let [{:keys [changes unsupported]} - (bm/compute-changes base-data branch-cmp main-raw - (or inverted {}) - merge-summary)] - (cond - (seq unsupported) - (audited {:status :unsupported :kinds (vec unsupported)} tpoint :update-from-main) + :else + ;; target = branch, source = main -> changes that bring main's + ;; net changes (and conflicts resolved to main) into the branch. + ;; The `:main->branch` summary reports main's changes against the + ;; branch, the same assignment compute-changes runs with here, so + ;; it can be reused for the unsupported-kinds gate without + ;; re-diffing. + (let [{:keys [changes unsupported]} + (bm/compute-changes base-data branch-cmp main-raw + (or inverted {}) + merge-summary)] + (cond + (seq unsupported) + (audited {:status :unsupported + :kinds (vec unsupported) + ;; the `:refuse` policies refuse on a named + ;; entity: surface the summary entries so + ;; the response names the parent or + ;; container it refuses on + :entities (vec (filter #(= :unsupported (:status %)) + (:changes merge-summary)))} + tpoint :update-from-main) - (and (empty? changes) (not branch-diverged?)) - (let [ts (ct/now)] - ;; the branch is in sync with main: the repositioned - ;; base already represents the branch, so the op log - ;; is emptied (old ops were built against the old base). - ;; The log is a branch's only durable record, so it may - ;; be emptied only when what it encodes already sits in - ;; the base. A diverged branch holds its own work in - ;; that log, so it falls through to the squash below, - ;; which re-derives the net against the new base. - (db/delete! conn :file-branch-change {:branch-id branch-id}) - (reposition-base! ts (:revn branch-file)) - (audited {:status :updated :revn (:revn branch-file)} tpoint :update-from-main)) + (and (empty? changes) (not branch-diverged?)) + (let [ts (ct/now)] + ;; the branch is in sync with main: the repositioned + ;; base already represents the branch, so the op log + ;; is emptied (old ops were built against the old base). + ;; The log is a branch's only durable record, so it may + ;; be emptied only when what it encodes already sits in + ;; the base. A diverged branch holds its own work in + ;; that log, so it falls through to the squash below, + ;; which re-derives the net against the new base. + (db/delete! conn :file-branch-change {:branch-id branch-id}) + ;; in sync, so no row is copied and the pairs are all + ;; the frame the base needs: unpaired rows stay named + ;; by the id main owns, which is what the branch + ;; references while it holds no copy + (reposition-base! ts (:revn branch-file) (bm/remap-refs main-raw pairs)) + (audited {:status :updated :revn (:revn branch-file)} tpoint :update-from-main)) - :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)] + :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)] - (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) - updated (-> branch-file - (update :revn inc) - (update :data #(cpc/process-changes % 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 frame, 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))) - (persist-branch-update! cfg updated ts branch-id net-changes)) + :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)) + (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))) + (persist-branch-update! cfg updated ts branch-id net-changes)) - (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 (def ^:private schema:materialize-file-branch [:map {:title "materialize-file-branch"} - [:file-id ::sm/uuid]]) + [:branch-file-id ::sm/uuid]]) (sv/defmethod ::materialize-file-branch "Turn a branch file into an ordinary file: persist its derived state as @@ -1435,15 +1538,19 @@ It keys on the branch FILE rather than on the branch metadata, which is what makes it idempotent: a file carrying no live branch row is already - materialised, and the command reports that without touching anything." + materialised, and the command reports that without touching anything. + + The `:branch-file-id` param is the branch FILE id (what + `::create-file-branch` returns as `:branch-file-id`), not the + `file_branch` row id the sibling commands take in `:branch-id`/`:id`." {::doc/added "2.16" ::webhooks/event? true ::sm/params schema:materialize-file-branch ::climit/id [[:materialize-file-branch/by-profile ::rpc/profile-id] [:materialize-file-branch/global]]} - [cfg {:keys [::rpc/profile-id file-id]}] + [cfg {:keys [::rpc/profile-id branch-file-id]}] (check-branching-enabled!) - (files/check-edition-permissions! cfg profile-id file-id) + (files/check-edition-permissions! cfg profile-id branch-file-id) (let [tpoint (ct/tpoint)] (db/tx-run! cfg @@ -1451,19 +1558,19 @@ ;; the advisory lock every save on this file takes: a concurrent ;; branch save must not land between the derive and the persist, or ;; its op would be dropped together with the log - (db/xact-lock! conn file-id) + (db/xact-lock! conn branch-file-id) - (let [branch (db/get* conn :file-branch {:branch-file-id file-id})] + (let [branch (db/get* conn :file-branch {:branch-file-id branch-file-id})] (if (nil? branch) - (audited {:status :materialized :file-id file-id :changed false} + (audited {:status :materialized :file-id branch-file-id :changed false} tpoint :materialize) - (let [file (bfc/get-file cfg file-id :realize? true) - team (teams/get-team conn :profile-id profile-id :file-id file-id) + (let [file (bfc/get-file cfg branch-file-id :realize? true) + team (teams/get-team conn :profile-id profile-id :file-id branch-file-id) delay (ldel/get-deletion-delay team) ts (ct/now)] (binding [pmap/*tracked* (pmap/create-tracked) - pmap/*load-fn* (partial fdata/load-pointer cfg file-id) + pmap/*load-fn* (partial fdata/load-pointer cfg branch-file-id) cfeat/*current* (:features file) cfeat/*previous* (:features file)] @@ -1484,7 +1591,7 @@ (when errors (l/wrn :hint "materialised file still has validation errors" - :file-id (str file-id) + :file-id (str branch-file-id) :codes (into [] (comp (map :code) (distinct)) errors))) ;; the derived state becomes the file's own payload @@ -1496,7 +1603,7 @@ ;; from here the ordinary paths apply (db/update! conn :file {:is-branch false} - {:id file-id} + {:id branch-file-id} {::db/return-keys false}) ;; the payload replaced the log @@ -1525,7 +1632,7 @@ (audited {:status :materialized - :file-id file-id + :file-id branch-file-id :changed true :revn (:revn file)} tpoint :materialize)))))))))) diff --git a/backend/src/app/rpc/commands/files_branch_policies.clj b/backend/src/app/rpc/commands/files_branch_policies.clj new file mode 100644 index 0000000000..1a665dd87f --- /dev/null +++ b/backend/src/app/rpc/commands/files_branch_policies.clj @@ -0,0 +1,103 @@ +;; 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 app.rpc.commands.files-branch-policies + "The branch-merge policy switch: reads the policies file and binds its + choices around the branch computations that read them. + + The file (`resources/app/branch-merge-policies.edn` by default, + `:branch-merge-policies-file` to point elsewhere) is a commented EDN + map with one key per policy. It is re-read whenever its mtime changes, + so a developer flips a policy by editing the file and re-running the + compare or merge — no restart. A key the file leaves out keeps its + default (`bm/default-policies`); a file that is unreadable, is not a + map, names an unknown policy or picks a value outside + `bm/policy-values` logs a warning and falls back to the defaults + entirely. + + `with-policies` binds `bm/*policies*` to the effective policies around + a computation; `policies-hash` turns them into a cache key component, + so summaries computed under different policies never share a cache + entry." + (:require + [app.common.files.branch-merge :as bm] + [app.common.logging :as l] + [app.config :as cf] + [clojure.edn :as edn] + [datoteka.fs :as fs])) + +(def ^:private state + "Cache of the last load: the file identity (path + mtime) and the + policies it yielded. A file is re-read only when its mtime changes." + (atom nil)) + +(defn- policies-path + "The configured policies file, or nil when it does not exist (an + unconfigured instance runs the defaults)." + [] + (let [path (cf/get :branch-merge-policies-file)] + (when (and (some? path) + (fs/exists? path) + (fs/regular-file? path)) + (fs/path path)))) + +(defn- warn-invalid! + [path reason] + (l/warn :hint "invalid branch merge policies file" + :path (str path) + :reason reason + :fallback "app.common.files.branch-merge/default-policies" + ::l/sync? true)) + +(defn- read-policies + "The policies map the file at `path` names — the entries it sets + overlay `bm/default-policies` — or nil after a warning when its + content is not a valid policies map." + [path] + (try + (let [data (edn/read-string (slurp path))] + (if (and (map? data) + (every? (fn [[key value]] + (contains? (get bm/policy-values key) value)) + data)) + (merge bm/default-policies data) + (do + (warn-invalid! path "not a map of policy keys to allowed values") + nil))) + (catch Throwable cause + (warn-invalid! path (ex-message cause)) + nil))) + +(defn effective-policies + "The policies currently in effect: what the policies file names, + re-read on mtime change, `bm/default-policies` when the file is + absent or invalid (after a warning)." + [] + (let [path (policies-path)] + (if (nil? path) + bm/default-policies + (let [mtime (inst-ms (fs/last-modified-time path)) + cache @state] + (if (and (= path (::path cache)) + (= mtime (::mtime cache))) + (::policies cache) + (let [policies (or (read-policies path) bm/default-policies)] + (reset! state {::path path ::mtime mtime ::policies policies}) + policies)))))) + +(defn policies-hash + "Hash of the policies currently bound (`bm/*policies*`), for cache + keys: two different policies must never share a cached summary, and a + key must hash exactly the policies its value was computed under." + [] + (hash bm/*policies*)) + +(defmacro with-policies + "Evaluate `body` with `bm/*policies*` bound to the effective + policies — the policies file, re-read on mtime change." + [& body] + `(binding [bm/*policies* (effective-policies)] + ~@body)) diff --git a/backend/src/app/rpc/commands/files_pull_request.clj b/backend/src/app/rpc/commands/files_pull_request.clj index 1c6ee5785f..9d2fc04040 100644 --- a/backend/src/app/rpc/commands/files_pull_request.clj +++ b/backend/src/app/rpc/commands/files_pull_request.clj @@ -282,15 +282,18 @@ (let [target-row (db/get-by-id cfg :file target-id) project (db/get-by-id cfg :project (:project-id target-row)) team-id (:team-id project) - reviewers (validate-reviewers! cfg team-id profile-id (or reviewers []))] + reviewers (validate-reviewers! cfg team-id profile-id (or reviewers [])) + messages (volatile! [])] (-> cfg (assoc ::quotes/profile-id profile-id) (assoc ::quotes/team-id team-id) (quotes/check! {::quotes/id ::quotes/pull-requests-per-team})) - (db/tx-run! + (fbranch/tx-run-notify! cfg + msgbus + messages (fn [{:keys [::db/conn] :as cfg}] ;; Serialize against concurrent update-file on the branch so ;; the review snapshot captures a consistent state (same @@ -357,12 +360,12 @@ :target-name (:name target-row) :reviewers reviewers}) - (mbus/pub! msgbus - :topic target-id - :message {:type :pull-request-created - :file-id target-id - :pull-request-id pr-id - :profile-id profile-id}) + (vswap! messages conj + {:topic target-id + :message {:type :pull-request-created + :file-id target-id + :pull-request-id pr-id + :profile-id profile-id}}) {:id pr-id :file-branch-id branch-id @@ -587,9 +590,12 @@ (let [team-id (perms/get-team-id-for-file cfg (:target-file-id pr)) reviewers (some->> reviewers - (validate-reviewers! cfg team-id (:created-by pr)))] - (db/tx-run! + (validate-reviewers! cfg team-id (:created-by pr))) + messages (volatile! [])] + (fbranch/tx-run-notify! cfg + msgbus + messages (fn [{:keys [::db/conn]}] (db/update! conn :file-pull-request (cond-> {:updated-at (ct/now)} @@ -622,12 +628,12 @@ :target-name (:target-name row) :reviewers added}))))) - (mbus/pub! msgbus - :topic (:target-file-id pr) - :message {:type :pull-request-updated - :file-id (:target-file-id pr) - :pull-request-id id - :profile-id profile-id}) + (vswap! messages conj + {:topic (:target-file-id pr) + :message {:type :pull-request-updated + :file-id (:target-file-id pr) + :pull-request-id id + :profile-id profile-id}}) {:id id :title (or title (:title pr)) @@ -651,7 +657,8 @@ ::climit/id [[:update-pull-request-snapshot/global]]} [{:keys [::mbus/msgbus] :as cfg} {:keys [::rpc/profile-id id]}] (check-pull-requests-enabled!) - (let [pr (get-pull-request* cfg id)] + (let [pr (get-pull-request* cfg id) + messages (volatile! [])] (when (not= "open" (:status pr)) (ex/raise :type :validation :code :pull-request-not-open @@ -661,8 +668,10 @@ ;; creating the pull request (files/check-edition-permissions! cfg profile-id (:source-file-id pr)) - (db/tx-run! + (fbranch/tx-run-notify! cfg + msgbus + messages (fn [{:keys [::db/conn] :as cfg}] ;; serialize against concurrent update-file on the branch so the ;; new snapshot captures a consistent state @@ -688,12 +697,12 @@ {:id id} {::db/return-keys false}) - (mbus/pub! msgbus - :topic (:target-file-id pr) - :message {:type :pull-request-updated - :file-id (:target-file-id pr) - :pull-request-id id - :profile-id profile-id}) + (vswap! messages conj + {:topic (:target-file-id pr) + :message {:type :pull-request-updated + :file-id (:target-file-id pr) + :pull-request-id id + :profile-id profile-id}}) {:id id :review-revn (:revn branch-file) :updated true}))))))) @@ -717,15 +726,18 @@ [{:keys [::mbus/msgbus] :as cfg} {:keys [::rpc/profile-id id state comment]}] (check-pull-requests-enabled!) - (let [pr (get-pull-request* cfg id)] + (let [pr (get-pull-request* cfg id) + messages (volatile! [])] (when (not= "open" (:status pr)) (ex/raise :type :validation :code :pull-request-not-open :pull-request-id id)) (files/check-read-permissions! cfg profile-id (:target-file-id pr)) - (db/tx-run! + (fbranch/tx-run-notify! cfg + msgbus + messages (fn [{:keys [::db/conn]}] (let [review (db/get* conn :file-pull-request-review {:pull-request-id id :profile-id profile-id})] @@ -743,13 +755,13 @@ {:pull-request-id id :profile-id profile-id} {::db/return-keys false}) - (mbus/pub! msgbus - :topic (:target-file-id pr) - :message {:type :pull-request-review-submitted - :file-id (:target-file-id pr) - :pull-request-id id - :profile-id profile-id - :state state}) + (vswap! messages conj + {:topic (:target-file-id pr) + :message {:type :pull-request-review-submitted + :file-id (:target-file-id pr) + :pull-request-id id + :profile-id profile-id + :state state}}) {:id id :profile-id profile-id @@ -772,15 +784,18 @@ ::sm/params schema:close-pull-request} [{:keys [::mbus/msgbus] :as cfg} {:keys [::rpc/profile-id id]}] (check-pull-requests-enabled!) - (let [pr (get-pull-request* cfg id)] + (let [pr (get-pull-request* cfg id) + messages (volatile! [])] (when (not= "open" (:status pr)) (ex/raise :type :validation :code :pull-request-not-open :pull-request-id id)) (check-author-or-admin! cfg profile-id pr) - (db/tx-run! + (fbranch/tx-run-notify! cfg + msgbus + messages (fn [{:keys [::db/conn] :as cfg}] (let [team (teams/get-team conn :profile-id profile-id :file-id (:target-file-id pr)) @@ -795,12 +810,12 @@ {::db/return-keys false}) (release-review-snapshot! cfg pr (ct/in-future delay)) - (mbus/pub! msgbus - :topic (:target-file-id pr) - :message {:type :pull-request-closed - :file-id (:target-file-id pr) - :pull-request-id id - :profile-id profile-id}) + (vswap! messages conj + {:topic (:target-file-id pr) + :message {:type :pull-request-closed + :file-id (:target-file-id pr) + :pull-request-id id + :profile-id profile-id}}) {:id id :status "closed"}))))) @@ -820,7 +835,8 @@ ::sm/params schema:reopen-pull-request} [{:keys [::mbus/msgbus] :as cfg} {:keys [::rpc/profile-id id]}] (check-pull-requests-enabled!) - (let [pr (get-pull-request* cfg id)] + (let [pr (get-pull-request* cfg id) + messages (volatile! [])] (when (not= "closed" (:status pr)) (ex/raise :type :validation :code :pull-request-not-closed @@ -836,8 +852,10 @@ :hint "the pull request's branch is no longer open" :pull-request-id id)) - (db/tx-run! + (fbranch/tx-run-notify! cfg + msgbus + messages (fn [{:keys [::db/conn] :as cfg}] (db/xact-lock! conn (:source-file-id pr)) @@ -872,12 +890,12 @@ {:id id} {::db/return-keys false}) - (mbus/pub! msgbus - :topic (:target-file-id pr) - :message {:type :pull-request-updated - :file-id (:target-file-id pr) - :pull-request-id id - :profile-id profile-id}) + (vswap! messages conj + {:topic (:target-file-id pr) + :message {:type :pull-request-updated + :file-id (:target-file-id pr) + :pull-request-id id + :profile-id profile-id}}) {:id id :status "open" :review-revn (:revn branch-file)})))))) diff --git a/backend/src/app/rpc/commands/files_snapshot.clj b/backend/src/app/rpc/commands/files_snapshot.clj index 032266a8d5..515af0024b 100644 --- a/backend/src/app/rpc/commands/files_snapshot.clj +++ b/backend/src/app/rpc/commands/files_snapshot.clj @@ -118,6 +118,16 @@ ;; Check permissions and read current file state (short-lived, outside restore transaction) (files/check-edition-permissions! pool profile-id file-id) (let [file (bfc/get-file cfg file-id) + + ;; A branch file's data payload is derived from the branch base + ;; and the operation log; restoring would persist a `file_data` + ;; row no read path consults. + _ (when (:is-branch file) + (ex/raise :type :validation + :code :branch-file-cant-be-restored + :hint "branch file data is derived from the branch base and the operation log; restore the snapshot on the source file or update the branch from main instead" + :file-id file-id)) + team (teams/get-team pool :profile-id profile-id :file-id file-id) @@ -161,6 +171,14 @@ [{:keys [::db/conn]} {:keys [::rpc/profile-id id label]}] (let [snapshot (fsnap/get-minimal-snapshot conn id)] (files/check-edition-permissions! conn profile-id (:file-id snapshot)) + + (when (not= (:created-by snapshot) "user") + (ex/raise :type :validation + :code :system-snapshots-cant-be-renamed + :file-id (:file-id snapshot) + :snapshot-id id + :profile-id profile-id)) + (fsnap/update! conn (assoc snapshot :label label)))) (def ^:private schema:remove-file-snapshot diff --git a/backend/src/app/rpc/commands/files_update.clj b/backend/src/app/rpc/commands/files_update.clj index 22cbebd630..9c4bbc45e1 100644 --- a/backend/src/app/rpc/commands/files_update.clj +++ b/backend/src/app/rpc/commands/files_update.clj @@ -10,6 +10,7 @@ [app.common.data :as d] [app.common.exceptions :as ex] [app.common.features :as cfeat] + [app.common.files.branch-merge :as bm] [app.common.files.changes :as cpc] [app.common.files.migrations :as fmg] [app.common.files.validate :as val] @@ -252,7 +253,12 @@ revn (get file :revn) - file + ;; The changes application runs the media fix-up, which may + ;; rewrite the media references. It returns the change vector + ;; as fixed: that is the vector a branch appends to its op + ;; log, the state its derive reproduces. The xlog row below + ;; keeps the client's changes, exactly as on an ordinary save. + [file op-changes] (binding [cfeat/*current* features cfeat/*previous* (:features file)] (update-file-data! cfg file @@ -290,7 +296,7 @@ {::db/return-keys false}) (if (:is-branch file) - (persist-branch-file! cfg file changes) + (persist-branch-file! cfg file op-changes) (persist-file! cfg file)) (when (contains? cf/flags :redis-cache) @@ -362,7 +368,17 @@ and the `file` row (revn, version, features, modified-at) plus the project modified-at are updated as usual, without any `file_data` write. The transient `file_change` xlog row (inserted by the caller) - keeps the lagged-changes machinery working unchanged." + keeps the lagged-changes machinery working unchanged. + + The vector stores the media fix-up the save ran: `update-file*` passes + the changes as rewritten by `process-changes-and-validate`, so the + derive reproduces the copied media rows and their references. + + The row records the data version the changes were applied at: + `update-file-data!` migrates the document to the current version + before it applies them, and the derive + (`app.binfile.common/branch-file-data`) migrates its replay to that + version before it applies the row." [{:keys [::db/conn ::timestamp] :as cfg} file changes] (let [modified-at (or timestamp (ct/now)) @@ -392,6 +408,7 @@ :file-id (:id file) :revn (:revn file) :changes (blob/encode changes) + :data-version (fmg/data-version) :created-at modified-at :updated-at modified-at} {::db/return-keys false}) @@ -493,10 +510,16 @@ (update :data cpc/process-changes changes) (update :data d/without-nils))) - file + ;; The media fix-up copies the foreign media rows into the file + ;; and rewrites the references on the file data. A branch + ;; persists no data: its state is the change vector, so the same + ;; rewrite is recorded in it and the derive reproduces the fix + ;; (`bm/remap-changes` is a no-op with an empty remap). + [file op-changes] (if-let [media-refs (-> @state :media-refs not-empty)] - (bfc/update-media-references! cfg file media-refs) - file)] + (let [[file media-index] (bfc/update-media-references! cfg file media-refs)] + [file (bm/remap-changes changes media-index)]) + [file changes])] (binding [pmap/*tracked* nil] (when (contains? cf/flags :soft-file-validation) @@ -513,7 +536,7 @@ (not skip-validate)) (val/validate-file-schema! file))) - file)) + [file op-changes])) (defn- take-snapshot? "Defines the rule when file `data` snapshot should be saved." diff --git a/backend/src/app/srepl/helpers.clj b/backend/src/app/srepl/helpers.clj index 18221f9434..bae8f2f8ca 100644 --- a/backend/src/app/srepl/helpers.clj +++ b/backend/src/app/srepl/helpers.clj @@ -10,6 +10,7 @@ (:require [app.binfile.common :as bfc] [app.common.data :as d] + [app.common.exceptions :as ex] [app.common.files.migrations :as fmg] [app.common.files.validate :as cfv] [app.common.time :as ct] @@ -159,6 +160,15 @@ :lock-for-update? true :realize? true) + ;; A branch file's data payload is derived from the branch base + ;; and the operation log; processing it would persist a + ;; `file_data` row no read path consults. + _ (when (:is-branch file) + (ex/raise :type :validation + :code :branch-file-cant-be-processed + :hint "branch file data is derived from the branch base and the operation log; process the source file instead" + :file-id file-id)) + libs (when with-libraries? (bfc/get-resolved-file-libraries system file)) diff --git a/backend/src/app/srepl/procs/media_refs.clj b/backend/src/app/srepl/procs/media_refs.clj index fc6d0721d7..3d6af798b0 100644 --- a/backend/src/app/srepl/procs/media_refs.clj +++ b/backend/src/app/srepl/procs/media_refs.clj @@ -36,7 +36,7 @@ having the same media object associated with two different files;" [cfg file] (let [media-refs (collect-media-refs (:data file))] - (bfc/update-media-references! cfg file media-refs))) + (first (bfc/update-media-references! cfg file media-refs)))) (def ^:private sql:get-files "SELECT f.id diff --git a/backend/src/app/tasks/file_gc.clj b/backend/src/app/tasks/file_gc.clj index 3d77b21045..22623ab551 100644 --- a/backend/src/app/tasks/file_gc.clj +++ b/backend/src/app/tasks/file_gc.clj @@ -229,13 +229,21 @@ (defn- process-file! [cfg {:keys [file-id] :as props}] (if-let [file (get-file cfg props)] - (let [file (->> file - (bfl/clean-file) - (clean-media! cfg) - (clean-fragments! cfg)) - file (assoc file :has-media-trimmed true)] - (bfc/update-file! cfg file) - true) + (if (:is-branch file) + (do + ;; A branch file's data payload is derived from the branch base + ;; and the operation log; cleaning it would persist a + ;; `file_data` row no read path consults. + (l/wrn :hint "skip branch file cleaning" + :file-id (str file-id)) + false) + (let [file (->> file + (bfl/clean-file) + (clean-media! cfg) + (clean-fragments! cfg)) + file (assoc file :has-media-trimmed true)] + (bfc/update-file! cfg file) + true)) (do (l/dbg :hint "skip cleaning, criteria does not match" :file-id (str file-id)) diff --git a/backend/src/app/tasks/file_gc_scheduler.clj b/backend/src/app/tasks/file_gc_scheduler.clj index 7eaa3801cc..fb2baa1406 100644 --- a/backend/src/app/tasks/file_gc_scheduler.clj +++ b/backend/src/app/tasks/file_gc_scheduler.clj @@ -25,6 +25,7 @@ WHERE f.has_media_trimmed IS false AND f.modified_at < ? AND f.deleted_at IS NULL + AND f.is_branch IS FALSE ORDER BY f.modified_at DESC FOR UPDATE OF f SKIP LOCKED") diff --git a/backend/test/backend_tests/binfile_test.clj b/backend/test/backend_tests/binfile_test.clj index a3931e60aa..2e3cf28141 100644 --- a/backend/test/backend_tests/binfile_test.clj +++ b/backend/test/backend_tests/binfile_test.clj @@ -2488,3 +2488,46 @@ (t/is (= (str (first result) "/" thumb-page-id "/" thumb-frame-id "/" thumb-tag) (:object-id thumb))) (t/is (some? (:media-id thumb))))))) + +;; ----------------------------------------------------------------------------- +;; Branch target protection +;; ----------------------------------------------------------------------------- + +(t/deftest import-overwrite-refuses-branch-file + ;; A branch file's data payload is derived from its merge base and op + ;; log, so an in-place import would write a `file_data` main row that + ;; no read path consults. + (with-redefs [cf/flags (conj cf/flags :branching)] + (let [profile (th/create-profile* 1) + file (prepare-simple-file profile) + output (tmp/tempfile :suffix ".zip")] + + (v3/export-files! + (-> th/*system* + (assoc ::bfc/ids #{(:id file)}) + (assoc ::bfc/export-type :detach-libraries)) + (io/output-stream output)) + + (let [out (th/command! {::th/type :create-file-branch + ::rpc/profile-id (:id profile) + :file-id (:id file) + :name "import-target"}) + branch-id (:branch-file-id (:result out)) + + error + (try + (-> th/*system* + (assoc ::bfc/project-id (:default-project-id profile)) + (assoc ::bfc/profile-id (:id profile)) + (assoc ::bfc/team-id (:default-team-id profile)) + (assoc ::bfc/file-id branch-id) + (assoc ::bfc/input output) + (v3/import-files!)) + :no-error + (catch Throwable e + (or (ex-data e) (some-> (ex-cause e) ex-data))))] + + (t/is (uuid? branch-id)) + (t/is (= :validation (:type error))) + (t/is (= :branch-file-cant-be-overwritten (:code error))) + (t/is (empty? (th/db-query :file-data {:file-id branch-id :type "main"}))))))) diff --git a/backend/test/backend_tests/branch_payload_writers_test.clj b/backend/test/backend_tests/branch_payload_writers_test.clj new file mode 100644 index 0000000000..8bfa6f0b26 --- /dev/null +++ b/backend/test/backend_tests/branch_payload_writers_test.clj @@ -0,0 +1,117 @@ +;; 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.branch-payload-writers-test + "Regression tests for the writers that must never persist a branch + file's `file_data` payload: `branch-file-data` derives the branch + from its merge base snapshot plus the op log, so a persisted main row + is invisible to every read path and silently desynchronises the + derived state." + (:require + [app.common.time :as ct] + [app.config :as cf] + [app.db :as db] + [app.rpc :as-alias rpc] + [app.srepl.helpers :as h] + [backend-tests.helpers :as th] + [clojure.test :as t])) + +(t/use-fixtures :once th/state-init) +(t/use-fixtures :each th/database-reset) + +(defn- create-branch! + [profile file name] + (let [out (th/command! {::th/type :create-file-branch + ::rpc/profile-id (:id profile) + :file-id (:id file) + :name name})] + (t/is (nil? (:error out))) + (:branch-file-id (:result out)))) + +(defn- create-file + [profile index] + (th/create-file* index {:profile-id (:id profile) + :project-id (:default-project-id profile) + :is-shared false})) + +(defn- payload-rows + "The `file_data` main rows of a file: the payload a branch file must + never have." + [file-id] + (th/db-query :file-data {:file-id file-id :type "main"})) + +(defn- scheduled-gc-file-ids + "The file ids of the `file-gc` tasks submitted so far." + [] + (->> (th/db-query :task {:name "file-gc"}) + (map (fn [{:keys [props]}] + (-> (if (db/pgobject? props) + (db/decode-transit-pgobject props) + props) + (get :file-id)))) + (into #{}))) + +(t/deftest process-file!-refuses-branch-file + ;; The admin repair entry points (`app.http.debug` file-repair and + ;; `app.srepl.main/repair-file!`) both run through `process-file!`, + ;; which persists through `bfc/update-file!`; on a branch that writes + ;; a payload row no read path consults. + (with-redefs [cf/flags (conj cf/flags :branching)] + (let [profile (th/create-profile* 1 {:is-active true}) + file (create-file profile 1) + branch-id (create-branch! profile file "repair-me") + + error + (try + ;; same shape as `app.srepl.main/repair-file!` and the + ;; debug file-repair route: the helper runs on a + ;; transaction-bound system + (db/tx-run! th/*system* + h/process-file! + branch-id + (fn [file _] (assoc file :name "repaired"))) + :no-error + (catch Throwable cause + (or (ex-data cause) (some-> (ex-cause cause) ex-data))))] + + (t/is (uuid? branch-id)) + (t/is (= :validation (:type error))) + (t/is (= :branch-file-cant-be-processed (:code error))) + (t/is (empty? (payload-rows branch-id)))))) + +(t/deftest file-gc-scheduler-never-selects-branch-files + (with-redefs [cf/flags (conj cf/flags :branching)] + (let [profile (th/create-profile* 1 {:is-active true}) + file (create-file profile 1) + branch-id (create-branch! profile file "gc-candidate") + threshold (ct/in-past {:days 8})] + + ;; both files look eligible: untrimmed and idle past the delay + (doseq [file-id [(:id file) branch-id]] + (th/db-update! :file + {:modified-at threshold + :has-media-trimmed false} + {:id file-id})) + + (t/is (map? (th/run-task! :file-gc-scheduler {}))) + + (t/is (= #{(:id file)} (scheduled-gc-file-ids)))))) + +(t/deftest file-gc-task-skips-branch-file + ;; Defensive counterpart of the scheduler guard: a file-gc run that + ;; reaches a branch file anyway must clean nothing and persist + ;; nothing. + (with-redefs [cf/flags (conj cf/flags :branching)] + (let [profile (th/create-profile* 1 {:is-active true}) + file (create-file profile 1) + branch-id (create-branch! profile file "gc-skip")] + + (th/db-update! :file {:has-media-trimmed false} {:id branch-id}) + + (let [result (th/run-task! :file-gc {:file-id branch-id})] + (t/is (false? result)) + (t/is (empty? (payload-rows branch-id))) + (t/is (false? (:has-media-trimmed (th/db-get :file {:id branch-id})))))))) diff --git a/backend/test/backend_tests/rpc_file_branch_oplog_test.clj b/backend/test/backend_tests/rpc_file_branch_oplog_test.clj index 50ed29f7e2..25075c53de 100644 --- a/backend/test/backend_tests/rpc_file_branch_oplog_test.clj +++ b/backend/test/backend_tests/rpc_file_branch_oplog_test.clj @@ -12,13 +12,16 @@ invariants on top of the behaviour covered by `backend-tests.rpc-file-branch-test`." (:require + [app.common.data :as d] [app.common.features :as cfeat] + [app.common.files.migrations :as fmg] [app.common.time :as ct] [app.common.types.shape :as cts] [app.common.uuid :as uuid] [app.config :as cf] [app.db :as db] [app.rpc :as-alias rpc] + [app.storage :as sto] [app.util.blob :as blob] [backend-tests.helpers :as th] [clojure.string :as str] @@ -268,7 +271,7 @@ ::rpc/profile-id (:id profile) :id branch-file-id})] (t/is (= "#00ff00" (get-in out [:result :data :pages-index page-id - :objects shape-id :fills 0 :fill-color])))) + :objects shape-id :fills 0 :fill-color])))) ;; main's own change arrives through the repositioned base, so the ;; net the update writes is empty. A ref left in main's frame would ;; make this shape differ from the new base and put it in the log. @@ -303,18 +306,17 @@ ::rpc/profile-id (:id profile) :id branch-file-id})] (t/is (= "#0000ff" (get-in out [:result :data :pages-index page-id - :objects shape-id :fills 0 :fill-color]))))))))) + :objects shape-id :fills 0 :fill-color]))))))))) (t/deftest update-resolutions-are-document-keyed ;; A resolution names a DOCUMENT, not the role the merge engine happened to - ;; hand it. In an update from main the engine runs with the branch as - ;; `theirs` and main as `ours` (`branch_merge.cljc::compute-merge*`), so - ;; `branch_merge.cljc::three-way-entities` writes the branch's value under - ;; the key named `:main` and main's value under the key named `:branch`. - ;; The client re-keys the conflicts it displays and sends resolutions in - ;; document terms; the command inverts them before applying - ;; (`files_branch.clj::update-branch-from-main`). This test pins that - ;; contract at the command boundary: `:main` brings main's value into the + ;; hand it. `branch_merge.cljc::compute-merge` reports every conflict with + ;; main's value under `:main` and the branch's under `:branch` in both + ;; directions, and the command applies each resolution in those same terms + ;; (`files_branch.clj::update-branch-from-main` inverts it before + ;; `branch_merge.cljc::compute-changes`, which runs with main as the source + ;; and the branch as the target). This test pins that contract at the + ;; command boundary: `:main` brings main's value into the ;; branch, `:branch` keeps the branch's value, and a per-attribute map ;; obeys the same vocabulary for the attribute it names. ;; @@ -746,7 +748,473 @@ (t/testing "materialize is what creates the payload row" (let [out (th/command! {::th/type :materialize-file-branch ::rpc/profile-id (:id profile) - :file-id branch-file-id})] + :branch-file-id branch-file-id})] (t/is (nil? (:error out))) (t/is (= :materialized (-> out :result :status)))) (t/is (some? (th/db-get :file-data {:file-id branch-file-id :type "main"}))))))) + +;;; --- Data versions across an upgrade +;; +;; A test-only file migration stands for a Penpot upgrade. Rebinding +;; `fmg/available-migrations` to the real list plus this name is the +;; upgrade: files written before the rebinding sit at the old data +;; version. The migration turns the color group separator "/" into " / " +;; and, like every real migration, assumes its input is at the old +;; version, so it corrupts a path already in the new format. A replay +;; that applies a segment at the wrong version shows up as a doubled +;; separator or an unspaced one. + +(def ^:private test-migration "9999-test-spaced-color-path") + +(defmethod fmg/migrate-data "9999-test-spaced-color-path" + [data _] + (d/update-when data :colors update-vals + (fn [color] + (d/update-when color :path str/replace "/" " / ")))) + +(defn- read-file + [profile file-id] + (let [out (th/command! {::th/type :get-file + ::rpc/profile-id (:id profile) + :id file-id})] + (t/is (nil? (:error out))) + (:result out))) + +;; `:modified-at` is the time each apply touched the color, which differs +;; between two files that went through the same history +(defn- colors-of + [file] + (update-vals (-> file :data :colors) #(dissoc % :modified-at))) + +(t/deftest branch-replays-each-op-at-the-data-version-it-was-written-at + ;; The reference is an ordinary file that goes through the same history: + ;; an op before the upgrade, the upgrade, an op after it. An ordinary + ;; file is migrated between the two ops, so the branch derive must + ;; migrate its document at the same point. + (with-redefs [cf/flags (conj cf/flags :branching)] + (let [profile (th/create-profile* 1 {:is-active true}) + proj-id (:default-project-id profile) + main (th/create-file* 1 {:profile-id (:id profile) + :project-id proj-id + :is-shared false}) + ordinary (th/create-file* 2 {:profile-id (:id profile) + :project-id proj-id + :is-shared false}) + upgraded (conj fmg/available-migrations test-migration) + c1 (uuid/random) + c2 (uuid/random) + c3 (uuid/random) + seed {:type :add-color + :color {:id c1 :name "One" :path "Brand/One" :color "#111111" :opacity 1}} + old-op {:type :add-color + :color {:id c2 :name "Two" :path "Brand/Two" :color "#222222" :opacity 1}} + ;; written by an editor that read the migrated document + new-op {:type :add-color + :color {:id c3 :name "Three" :path "Brand / Three" :color "#333333" :opacity 1}}] + + (apply-change* profile (:id main) seed) + (apply-change* profile (:id ordinary) seed) + + (let [branch-file-id (:branch-file-id (create-branch* profile (:id main) "straddle"))] + (apply-change* profile branch-file-id old-op) + (apply-change* profile (:id ordinary) old-op) + + (with-redefs [fmg/available-migrations upgraded] + (apply-change* profile branch-file-id new-op) + (apply-change* profile (:id ordinary) new-op) + + (let [expected (colors-of (read-file profile (:id ordinary))) + derived (colors-of (read-file profile branch-file-id))] + (t/testing "the reference holds every path in the new format" + (t/is (= ["Brand / One" "Brand / Two" "Brand / Three"] + (mapv #(get-in expected [% :path]) [c1 c2 c3])))) + + (t/testing "the branch derives the document the ordinary file holds" + (t/is (= expected derived))))))))) + +(t/deftest merge-after-an-upgrade-compares-against-a-migrated-base + ;; The branch renames a color before the upgrade and main never touches + ;; it. After the upgrade main and the branch read migrated, so the base + ;; must read migrated too, or main's migrated path reads as an edit and + ;; the rename as a modify-modify conflict. + (with-redefs [cf/flags (conj cf/flags :branching)] + (let [profile (th/create-profile* 1 {:is-active true}) + proj-id (:default-project-id profile) + main (th/create-file* 1 {:profile-id (:id profile) + :project-id proj-id + :is-shared false}) + upgraded (conj fmg/available-migrations test-migration) + c1 (uuid/random)] + + (apply-change* profile (:id main) + {:type :add-color + :color {:id c1 :name "One" :path "Brand/One" :color "#111111" :opacity 1}}) + + (let [create (create-branch* profile (:id main) "rename-before-upgrade")] + (apply-change* profile (:branch-file-id create) + {:type :mod-color + :color {:id c1 :name "Uno" :path "Brand/One" :color "#111111" :opacity 1}}) + + (with-redefs [fmg/available-migrations upgraded] + (t/testing "the compare reports the rename as a clean change" + (let [out (th/command! {::th/type :get-branch-diff + ::rpc/profile-id (:id profile) + :branch-id (:id create)})] + (t/is (nil? (:error out))) + (t/is (= 0 (-> out :result :stats :conflicts))))) + + (t/testing "the merge reports no conflict and applies the rename" + (let [out (th/command! {::th/type :merge-file-branch + ::rpc/profile-id (:id profile) + :branch-id (:id create)})] + (t/is (nil? (:error out))) + (t/is (= :merged (-> out :result :status))) + (t/is (empty? (-> out :result :conflicts)))) + (t/is (= {:name "Uno" :path "Brand / One"} + (-> (colors-of (read-file profile (:id main))) + (get c1) + (select-keys [:name :path])))))))))) + +(t/deftest steady-state-branch-reads-run-no-migration + ;; No upgrade since the branch was cut: base, op log, main and branch + ;; share one data version, so reading, comparing and merging the branch + ;; must not run a migration, not even an empty one (the schema check at + ;; the end of `fmg/migrate` walks the whole document). + (with-redefs [cf/flags (conj cf/flags :branching)] + (let [profile (th/create-profile* 1 {:is-active true}) + proj-id (:default-project-id profile) + main (th/create-file* 1 {:profile-id (:id profile) + :project-id proj-id + :is-shared false}) + create (create-branch* profile (:id main) "steady") + branch-file-id (:branch-file-id create) + real-migrate fmg/migrate + real-migrate-data fmg/migrate-data + calls (atom 0)] + + (with-redefs [fmg/migrate (fn [& args] + (swap! calls inc) + (apply real-migrate args)) + fmg/migrate-data (fn [data id] + (swap! calls inc) + (real-migrate-data data id))] + (apply-change* profile branch-file-id + {:type :add-color + :color {:id (uuid/random) :name "A" :path "Brand/A" :color "#111111" :opacity 1}}) + (apply-change* profile branch-file-id + {:type :add-color + :color {:id (uuid/random) :name "B" :path "Brand/B" :color "#222222" :opacity 1}}) + (apply-change* profile (:id main) + {:type :add-color + :color {:id (uuid/random) :name "M" :path "Brand/M" :color "#333333" :opacity 1}}) + + (read-file profile branch-file-id) + (t/is (= :updated (-> (th/command! {::th/type :update-branch-from-main + ::rpc/profile-id (:id profile) + :branch-id (:id create)}) + :result :status))) + (t/is (nil? (:error (th/command! {::th/type :get-branch-diff + ::rpc/profile-id (:id profile) + :branch-id (:id create)})))) + (let [out (th/command! {::th/type :merge-file-branch + ::rpc/profile-id (:id profile) + :branch-id (:id create)})] + (t/is (nil? (:error out))) + (t/is (= :merged (-> out :result :status)))) + + (t/is (zero? @calls)))))) + +(t/deftest update-from-main-after-an-upgrade-compares-against-a-migrated-base + ;; Same history as the merge case, integrated the other way: main's + ;; migrated path must not read as a main-side edit of the color the + ;; branch renamed. + (with-redefs [cf/flags (conj cf/flags :branching)] + (let [profile (th/create-profile* 1 {:is-active true}) + proj-id (:default-project-id profile) + main (th/create-file* 1 {:profile-id (:id profile) + :project-id proj-id + :is-shared false}) + upgraded (conj fmg/available-migrations test-migration) + c1 (uuid/random) + c2 (uuid/random)] + + (apply-change* profile (:id main) + {:type :add-color + :color {:id c1 :name "One" :path "Brand/One" :color "#111111" :opacity 1}}) + + (let [create (create-branch* profile (:id main) "update-after-upgrade")] + (apply-change* profile (:branch-file-id create) + {:type :mod-color + :color {:id c1 :name "Uno" :path "Brand/One" :color "#111111" :opacity 1}}) + + (with-redefs [fmg/available-migrations upgraded] + ;; main's own work after the upgrade gives the update something + ;; to bring in + (apply-change* profile (:id main) + {:type :add-color + :color {:id c2 :name "Two" :path "Brand / Two" :color "#222222" :opacity 1}}) + + (let [out (th/command! {::th/type :update-branch-from-main + ::rpc/profile-id (:id profile) + :branch-id (:id create)})] + (t/is (nil? (:error out))) + (t/is (= :updated (-> out :result :status))) + (t/is (empty? (-> out :result :conflicts)))) + + (t/testing "the branch keeps its rename and gains main's color" + (let [colors (colors-of (read-file profile (:branch-file-id create)))] + (t/is (= {:name "Uno" :path "Brand / One"} + (select-keys (get colors c1) [:name :path]))) + (t/is (= {:name "Two" :path "Brand / Two"} + (select-keys (get colors c2) [:name :path])))))))))) + +(t/deftest branch-replays-an-unstamped-row-at-the-base-version + ;; A row written before `file_branch_change.data_version` existed has + ;; no stamp. Such rows precede every stamped row and were written over + ;; the base, so the derive replays them at the base's version, as it did + ;; before the column existed. + (with-redefs [cf/flags (conj cf/flags :branching)] + (let [profile (th/create-profile* 1 {:is-active true}) + proj-id (:default-project-id profile) + main (th/create-file* 1 {:profile-id (:id profile) + :project-id proj-id + :is-shared false}) + ordinary (th/create-file* 2 {:profile-id (:id profile) + :project-id proj-id + :is-shared false}) + upgraded (conj fmg/available-migrations test-migration) + c1 (uuid/random) + c2 (uuid/random) + old-op {:type :add-color + :color {:id c1 :name "One" :path "Brand/One" :color "#111111" :opacity 1}} + new-op {:type :add-color + :color {:id c2 :name "Two" :path "Brand / Two" :color "#222222" :opacity 1}} + branch-file-id (:branch-file-id (create-branch* profile (:id main) "unstamped"))] + + (apply-change* profile branch-file-id old-op) + (apply-change* profile (:id ordinary) old-op) + (th/db-update! :file-branch-change {:data-version nil} {:file-id branch-file-id}) + + (with-redefs [fmg/available-migrations upgraded] + (apply-change* profile branch-file-id new-op) + (apply-change* profile (:id ordinary) new-op) + + (t/is (= [nil test-migration] + (->> (oplog-rows branch-file-id) + (sort-by :revn) + (mapv :data-version)))) + (t/is (= (colors-of (read-file profile (:id ordinary))) + (colors-of (read-file profile branch-file-id)))))))) + +(t/deftest update-from-main-conflict-sides-name-the-documents + ;; `update-branch-from-main` reports its conflicts in document terms: + ;; `:main` carries main's value and `:branch` the branch's, whatever the + ;; direction the engine ran in. Resolving the conflict to `:branch` then + ;; keeps the branch's value end to end. + (with-redefs [cf/flags (conj cf/flags :branching)] + (let [profile (th/create-profile* 1 {:is-active true}) + proj-id (:default-project-id profile) + branch-fill "#bb0000" + main-fill "#00bb00" + fills (fn [color] [{:fill-color color :fill-opacity 1}]) + file (th/create-file* 1 {:profile-id (:id profile) + :project-id proj-id + :is-shared false}) + main-id (:id file) + page-id (-> (th/command! {::th/type :get-file + ::rpc/profile-id (:id profile) + :id main-id}) + :result :data :pages first) + shape-id (uuid/random) + color-id (uuid/random)] + + ;; the shape enters the merge base before the fork + (apply-change* profile main-id + {:type :add-obj + :page-id page-id + :id shape-id + :parent-id uuid/zero + :frame-id uuid/zero + :obj (-> (cts/setup-shape + {:id shape-id :name "Coded" :type :rect + :parent-id uuid/zero :frame-id uuid/zero}) + (assoc :fills (fills "#000000")))}) + + (let [create (create-branch* profile main-id "update-conflict-sides") + branch-id (:id create) + branch-file-id (:branch-file-id create) + read-fill (fn [] + (get-in (th/command! {::th/type :get-file + ::rpc/profile-id (:id profile) + :id branch-file-id}) + [:result :data :pages-index page-id :objects shape-id + :fills 0 :fill-color]))] + + ;; the same attribute diverges on the two sides + (apply-change* profile branch-file-id + {:type :mod-obj + :page-id page-id + :id shape-id + :operations [{:type :set :attr :fills :val (fills branch-fill)}]}) + (apply-change* profile main-id + {:type :mod-obj + :page-id page-id + :id shape-id + :operations [{:type :set :attr :fills :val (fills main-fill)}]}) + ;; main also gains a change the branch never touched, so the update + ;; has something of main's to apply and takes the write path + (apply-change* profile main-id + {:type :add-color + :color {:id color-id :name "Main-only" + :color "#336699" :opacity 1}}) + + (t/testing "the conflict names the two documents" + (let [out (th/command! {::th/type :update-branch-from-main + ::rpc/profile-id (:id profile) + :branch-id branch-id}) + c (first (-> out :result :conflicts))] + (t/is (= :conflicts (-> out :result :status))) + (t/is (= shape-id (:id c))) + (t/is (= main-fill (get-in c [:main :fills 0 :fill-color]))) + (t/is (= branch-fill (get-in c [:branch :fills 0 :fill-color]))) + (t/is (= {:main (fills main-fill) :branch (fills branch-fill)} + (get-in c [:changed-attrs :fills]))))) + + (t/testing "resolved to :branch, the branch keeps its own value" + (let [out (th/command! {::th/type :update-branch-from-main + ::rpc/profile-id (:id profile) + :branch-id branch-id + :resolutions {shape-id :branch}})] + (t/is (nil? (:error out))) + (t/is (= :updated (-> out :result :status)))) + (t/is (= branch-fill (read-fill)))))))) + +;; --- media fix-up on branch saves + +(defn- foreign-media-setup + "The media fix-up scenario: a save into the branch adds an image shape + referencing a `file_media_object` row ANOTHER file owns, the case the + server-side media fix-up handles on an ordinary save. Returns the + pieces the assertions need." + [] + (let [profile (th/create-profile* 1 {:is-active true}) + proj-id (:default-project-id profile) + file (th/create-file* 1 {:profile-id (:id profile) + :project-id proj-id + :is-shared false}) + foreign (th/create-file* 2 {:profile-id (:id profile) + :project-id proj-id + :is-shared false}) + storage (-> (:app.storage/storage th/*system*) + (assoc :app.storage/backend :fs)) + sobj (sto/put-object! storage {::sto/content (sto/content "foreign-image") + :bucket :file-media-object + :content-type "image/png"}) + fmo (th/create-file-media-object* {:file-id (:id foreign) + :name "foreign.png" + :mtype "image/png" + :media-id (:id sobj)}) + create (create-branch* profile (:id file) "media-fixup") + branch-file-id (:branch-file-id create) + page-id (-> (read-file profile branch-file-id) :data :pages first) + shape-id (uuid/random)] + + (apply-change* profile branch-file-id + {:type :add-obj + :page-id page-id + :id shape-id + :parent-id uuid/zero + :frame-id uuid/zero + :obj (cts/setup-shape + {:id shape-id :name "Image" :type :image + :parent-id uuid/zero :frame-id uuid/zero + :metadata {:id (:id fmo) + :width 100 :height 100 + :mtype "image/png"}})}) + + {:profile profile + :main-id (:id file) + :branch-id (:id create) + :branch-file-id branch-file-id + :page-id page-id + :shape-id shape-id + :fmo-id (:id fmo)})) + +(defn- media-ref + "The media row id a shape references: image shapes carry it in + `:metadata`, fill images in their `:fills`." + [obj] + (or (get-in obj [:metadata :id]) + (get-in obj [:fills 0 :fill-image :id]))) + +(defn- derived-obj + [profile file-id page-id shape-id] + (-> (read-file profile file-id) + :data :pages-index (get page-id) :objects (get shape-id))) + +(t/deftest branch-save-fixes-foreign-media-refs-in-the-op-log + ;; An ordinary save carries the media fix-up with its payload: the + ;; foreign row is copied into the saving file and the reference is + ;; rewritten. A branch stores no payload — the change vector IS the + ;; state — so the rewrite has to land in the change vector before the + ;; op is appended, or the derive reproduces the foreign reference and + ;; the copied row is left unreferenced. + (with-redefs [cf/flags (conj cf/flags :branching)] + (let [{:keys [profile branch-file-id page-id shape-id fmo-id]} + (foreign-media-setup) + + stored-ref + (-> (oplog-rows branch-file-id) + first :changes blob/decode first :obj media-ref) + + derived-ref + (-> (derived-obj profile branch-file-id page-id shape-id) + media-ref)] + + (t/testing "the op log records the rewritten reference" + (t/is (= 1 (count (oplog-rows branch-file-id)))) + (t/is (uuid? stored-ref)) + (t/is (not= fmo-id stored-ref))) + + (t/testing "the derive reproduces the reference the op records" + (t/is (= stored-ref derived-ref))) + + (t/testing "the derived branch references a media row it owns" + (let [row (th/db-get :file-media-object {:id derived-ref})] + (t/is (some? row)) + (t/is (= branch-file-id (:file-id row))))) + + (t/testing "the copied row is the referenced one, not an orphan" + (let [rows (th/db-query :file-media-object {:file-id branch-file-id})] + (t/is (= 1 (count rows))) + (t/is (= derived-ref (:id (first rows))))))))) + +(t/deftest merge-carries-the-fixed-media-into-main + ;; The fix-up's copy is owned by the branch file, so the merge must + ;; carry the row into main and point main's shape at a row main owns. + ;; With the reference left foreign, `files_branch.clj::unpaired-media-rows` + ;; drops the row (it filters by branch ownership) and main ends up + ;; referencing media it does not own. + (with-redefs [cf/flags (conj cf/flags :branching)] + (let [{:keys [profile main-id branch-id branch-file-id page-id shape-id]} + (foreign-media-setup) + + out + (th/command! {::th/type :merge-file-branch + ::rpc/profile-id (:id profile) + :branch-id branch-id + :keep-branch true})] + + (t/is (nil? (:error out))) + (t/is (= :merged (-> out :result :status))) + + (let [ref (-> (derived-obj profile main-id page-id shape-id) media-ref) + row (th/db-get :file-media-object {:id ref})] + (t/is (some? row)) + (t/is (= main-id (:file-id row)))) + + ;; the branch keeps deriving its own state from the kept op log + (let [ref (-> (derived-obj profile branch-file-id page-id shape-id) media-ref) + row (th/db-get :file-media-object {:id ref})] + (t/is (some? row)) + (t/is (= branch-file-id (:file-id row))))))) diff --git a/backend/test/backend_tests/rpc_file_branch_test.clj b/backend/test/backend_tests/rpc_file_branch_test.clj index 86efd5393f..eb33542258 100644 --- a/backend/test/backend_tests/rpc_file_branch_test.clj +++ b/backend/test/backend_tests/rpc_file_branch_test.clj @@ -11,6 +11,7 @@ [app.common.files.branch-merge :as bm] [app.common.files.repair :as cfr] [app.common.files.validate :as cfv] + [app.common.logging :as l] [app.common.time :as ct] [app.common.types.shape :as cts] [app.common.uuid :as uuid] @@ -18,6 +19,8 @@ [app.db :as db] [app.msgbus :as mbus] [app.rpc :as-alias rpc] + [app.rpc.commands.files-branch :as fbranch] + [app.rpc.commands.files-branch-policies :as fbp] [app.storage :as sto] [app.util.blob :as blob] [backend-tests.helpers :as th] @@ -1136,9 +1139,9 @@ :id branch-file-id}) img-id (get-in out [:result :data :colors cid :image :id])] (t/is (some? img-id)) - ;; the colour's image keeps resolving to the right content (an - ;; inherited ref names MAIN's row: a branch stores no data, its - ;; document is the base snapshot plus the op log) + ;; the colour's image keeps resolving to the right content (the + ;; document names the branch's own paired copy: the base is pinned + ;; in the branch's frame and the op log replays over it) (let [row (th/db-get :file-media-object {:id img-id})] (t/is (= (:id sobj) (:media-id row))))) @@ -1192,7 +1195,7 @@ (t/testing "materialize persists the derived state and drops the branch" (let [out (th/command! {::th/type :materialize-file-branch ::rpc/profile-id (:id profile) - :file-id branch-file-id})] + :branch-file-id branch-file-id})] (t/is (nil? (:error out))) (t/is (= :materialized (-> out :result :status))) (t/is (true? (-> out :result :changed)))) @@ -1232,7 +1235,7 @@ (t/testing "materializing again is a no-op" (let [out (th/command! {::th/type :materialize-file-branch ::rpc/profile-id (:id profile) - :file-id branch-file-id})] + :branch-file-id branch-file-id})] (t/is (nil? (:error out))) (t/is (= :materialized (-> out :result :status))) (t/is (false? (-> out :result :changed))))))))) @@ -1516,7 +1519,7 @@ :name "audited-exit"}) out (th/command! {::th/type :materialize-file-branch ::rpc/profile-id (:id profile) - :file-id (-> created :result :branch-file-id)}) + :branch-file-id (-> created :result :branch-file-id)}) props (-> out :result meta :app.loggers.audit/props)] (t/is (nil? (:error out))) (t/is (= "materialize" (:branch-operation props))) @@ -1825,7 +1828,7 @@ cfr/repair-file no-repair] (let [out (th/command! {::th/type :materialize-file-branch ::rpc/profile-id (:id profile) - :file-id branch-file-id})] + :branch-file-id branch-file-id})] (t/is (nil? (:error out))) (t/is (= :materialized (-> out :result :status))) (t/is (true? (-> out :result :changed))))) @@ -1973,7 +1976,7 @@ :opacity 1}}])] (let [out (th/command! {::th/type :materialize-file-branch ::rpc/profile-id (:id profile) - :file-id b2-fid})] + :branch-file-id b2-fid})] (t/is (nil? (:error out))) (t/is (= :materialized (-> out :result :status))))) @@ -2263,3 +2266,404 @@ (t/is (= branch-file-id topic)) ;; the update was already committed when the message left (t/is (= (:revn message) branch-revn))))))) + +(t/deftest materialize-takes-the-branch-file-id + ;; `:branch-file-id` names the branch FILE — the id `::create-file-branch` + ;; returns under that same key — while the sibling commands take the + ;; `file_branch` row id. The old generic `:file-id` name is refused by + ;; the schema. + (with-redefs [cf/flags (conj cf/flags :branching)] + (let [profile (th/create-profile* 1 {:is-active true}) + proj-id (:default-project-id profile) + file (th/create-file* 1 {:profile-id (:id profile) + :project-id proj-id + :is-shared false}) + create (:result (th/command! {::th/type :create-file-branch + ::rpc/profile-id (:id profile) + :file-id (:id file) + :name "to-materialize"})) + branch-file-id (:branch-file-id create)] + + (t/testing "the old :file-id param is refused by the schema" + (let [{:keys [error]} (th/command! {::th/type :materialize-file-branch + ::rpc/profile-id (:id profile) + :file-id branch-file-id})] + (t/is (some? error)) + (t/is (th/ex-of-type? error :validation)) + (t/is (th/ex-of-code? error :params-validation))) + ;; refused before the handler runs, so the branch is untouched + (t/is (true? (:is-branch (th/db-get :file {:id branch-file-id}))))) + + (t/testing "materialize runs on :branch-file-id" + (let [{:keys [error result]} (th/command! {::th/type :materialize-file-branch + ::rpc/profile-id (:id profile) + :branch-file-id branch-file-id})] + (t/is (nil? error)) + (t/is (= :materialized (:status result))) + (t/is (true? (:changed result)))))))) + +;;; --- A comparison that cannot be made is never "in sync" +;; +;; The listing is read-only: it cannot repair anything, and merge and +;; update DO refuse loudly when the merge base cannot be resolved. So +;; the row carries the error marker and no counts at all: zeros read as +;; "in sync", and a branch that cannot be compared is not in sync. + +(t/deftest missing-base-snapshot-lists-an-error-marker + (with-redefs [cf/flags (conj cf/flags :branching)] + (let [profile (th/create-profile* 1 {:is-active true}) + proj-id (:default-project-id profile) + file (th/create-file* 1 {:profile-id (:id profile) + :project-id proj-id + :is-shared false}) + create (:result (th/command! {::th/type :create-file-branch + ::rpc/profile-id (:id profile) + :file-id (:id file) + :name "lost-base"})) + branch-id (:id create) + branch-file-id (:branch-file-id create)] + + ;; the branch diverged, so the listing pays for the comparison + (t/is (nil? (:error (apply-change* profile branch-file-id + {:type :add-color + :color {:id (uuid/random) + :name "Brand" + :color "#ff0000" + :opacity 1}})))) + + ;; the merge-base snapshot is gone + (let [base (:base-snapshot-id (first (th/db-query :file-branch {:id branch-id})))] + (t/is (some? base)) + (th/db-delete! :file-change {:id base}) + (t/is (empty? (th/db-query :file-change {:id base})))) + + (let [out (th/command! {::th/type :get-file-branches + ::rpc/profile-id (:id profile) + :file-id (:id file)}) + row (first (filter #(= branch-id (:id %)) (:result out)))] + (t/is (nil? (:error out))) + (t/is (some? row)) + (t/is (true? (:diff-error row)) "the row does not carry the error marker") + (t/is (nil? (:ahead row))) + (t/is (nil? (:behind row))) + (t/is (nil? (:conflicts row))))))) + +;;; --- The listing holds no pooled connection across the comparisons +;; +;; Each comparison takes its own connection and returns it before the +;; next one starts: the listing query uses one, the comparisons use one +;; each, and none of them is held while the others run. + +(t/deftest listing-compare-takes-a-connection-per-diff + (with-redefs [cf/flags (conj cf/flags :branching)] + (let [profile (th/create-profile* 1 {:is-active true}) + proj-id (:default-project-id profile) + file (th/create-file* 1 {:profile-id (:id profile) + :project-id proj-id + :is-shared false}) + create* (fn [name] + (:result (th/command! {::th/type :create-file-branch + ::rpc/profile-id (:id profile) + :file-id (:id file) + :name name}))) + branches [(create* "one") (create* "two")]] + + ;; both branches diverged, so the listing compares both + (doseq [branch branches] + (t/is (nil? (:error (apply-change* profile (:branch-file-id branch) + {:type :add-color + :color {:id (uuid/random) + :name "Brand" + :color "#ff0000" + :opacity 1}}))))) + + (let [orig-open db/open + orig-compute fbranch/branch-diff-counts! + checkouts (atom []) + runs (atom [])] + (with-redefs [db/open + (fn [system-or-pool] + (let [conn (orig-open system-or-pool)] + (swap! checkouts conj conn) + conn)) + + fbranch/branch-diff-counts! + (fn [cfg main-data branch] + (let [conn (db/get-connection cfg) + prev (:conn (peek @runs))] + (swap! runs conj + {:conn conn + ;; the previous comparison's connection + ;; is back in the pool by now + :prev-closed? (or (nil? prev) + (.isClosed ^java.sql.Connection prev)) + ;; every connection handed out so far and + ;; still checked out at this moment + :held (into [] + (remove #(.isClosed ^java.sql.Connection %)) + @checkouts)})) + (orig-compute cfg main-data branch))] + (t/is (nil? (:error (th/command! {::th/type :get-file-branches + ::rpc/profile-id (:id profile) + :file-id (:id file)}))))) + + (t/is (= 2 (count @runs)) "both branches were compared") + ;; every comparison runs with a connection of its own + (t/is (apply distinct? (map :conn @runs)) + "two comparisons shared one connection") + (t/is (every? :prev-closed? (rest @runs)) + "a connection is held across the comparisons") + ;; ...and while it runs, its own is the only one checked out: the + ;; listing's and the previous comparison's are back in the pool + (t/is (every? (fn [{:keys [conn held]}] (= [conn] held)) @runs) + "a connection is held while the comparisons run"))))) + +;;; --- Media pairing: the branch holds its own copies + +(defn- squashed-log-types + "Change types the branch's op log (`file_branch_change`) carries after + the squash an update-from-main performs." + [branch-id] + (into [] + (mapcat (fn [row] (map :type (blob/decode (:changes row))))) + (th/db-query :file-branch-change {:branch-id branch-id}))) + +(def ^:private media-change-types + #{:add-media :mod-media :del-media}) + +(t/deftest update-from-main-deletes-the-paired-media-copy + ;; main deletes a media object the branch holds as a paired copy: the + ;; delete travels through `bm/remap-changes` with the pair map and must + ;; name the branch's copy, not main's row — the branch holds neither the + ;; id the change was computed with nor a second copy of the content + (with-redefs [cf/flags (conj cf/flags :branching)] + (let [profile (th/create-profile* 1 {:is-active true}) + proj-id (:default-project-id profile) + file (th/create-file* 1 {:profile-id (:id profile) + :project-id proj-id}) + storage (-> (:app.storage/storage th/*system*) + (assoc :app.storage/backend :fs)) + sobj (sto/put-object! storage {::sto/content (sto/content "shared-image") + :bucket :file-media-object + :content-type "image/png"}) + fmo (th/create-file-media-object* {:file-id (:id file) + :name "shared.png" + :media-id (:id sobj)}) + _ (apply-change* profile (:id file) + {:type :add-media + :object {:id (:id fmo) :name "shared.png" + :media-id (:id sobj) + :width 100 :height 100 + :mtype "image/png"}}) + create (:result (th/command! {::th/type :create-file-branch + ::rpc/profile-id (:id profile) + :file-id (:id file) + :name "paired-delete"})) + branch-id (:id create) + branch-file-id (:branch-file-id create) + branch-media (fn [] + (let [out (th/command! {::th/type :get-file + ::rpc/profile-id (:id profile) + :id branch-file-id})] + (-> out :result :data :media)))] + ;; a main-side change so the first update reaches the write path and + ;; copies main's row into the branch + (t/is (nil? (:error (apply-change* profile (:id file) + {:type :add-color + :color {:id (uuid/random) :name "C1" + :color "#112233" :opacity 1}})))) + (let [out (th/command! {::th/type :update-branch-from-main + ::rpc/profile-id (:id profile) + :branch-id branch-id})] + (t/is (= :updated (-> out :result :status)))) + + (t/testing "the branch holds the media as its own paired copy" + (let [[media] (vals (branch-media))] + (t/is (= 1 (count (vals (branch-media))))) + (t/is (some? media)) + (t/is (not= (:id fmo) (:id media))) + (t/is (= (:id sobj) + (:media-id (th/db-get :file-media-object {:id (:id media)})))))) + + (t/testing "deleting it on main deletes the branch's copy" + (t/is (nil? (:error (apply-change* profile (:id file) + {:type :del-media :id (:id fmo)})))) + (let [out (th/command! {::th/type :update-branch-from-main + ::rpc/profile-id (:id profile) + :branch-id branch-id})] + (t/is (= :updated (-> out :result :status)))) + (t/is (empty? (branch-media))))))) + +(t/deftest repeated-updates-squash-no-phantom-media + ;; a second update from main must not squash media changes the branch + ;; never made: the write re-points main's media rows at the branch's + ;; copies, and the squashed log compares the updated branch with main's + ;; state — if one side is re-pointed and the other is not, the paired + ;; media reads as deleted+added on every update + (with-redefs [cf/flags (conj cf/flags :branching)] + (let [profile (th/create-profile* 1 {:is-active true}) + proj-id (:default-project-id profile) + storage (-> (:app.storage/storage th/*system*) + (assoc :app.storage/backend :fs)) + add-media-on-main! (fn [file name] + (let [sobj (sto/put-object! storage {::sto/content (sto/content name) + :bucket :file-media-object + :content-type "image/png"}) + fmo (th/create-file-media-object* {:file-id (:id file) + :name name + :media-id (:id sobj)})] + (apply-change* profile (:id file) + {:type :add-media + :object {:id (:id fmo) :name name + :media-id (:id sobj) + :width 100 :height 100 + :mtype "image/png"}}))) + add-color-on-main! (fn [file] + (apply-change* profile (:id file) + {:type :add-color + :color {:id (uuid/random) :name "C" + :color "#112233" :opacity 1}})) + update! (fn [branch-id] + (th/command! {::th/type :update-branch-from-main + ::rpc/profile-id (:id profile) + :branch-id branch-id}))] + + (t/testing "media added on main after the fork" + (let [file (th/create-file* 1 {:profile-id (:id profile) + :project-id proj-id}) + create (:result (th/command! {::th/type :create-file-branch + ::rpc/profile-id (:id profile) + :file-id (:id file) + :name "after-fork"})) + branch-id (:id create)] + (t/is (nil? (:error (add-media-on-main! file "after.png")))) + (t/is (= :updated (-> (update! branch-id) :result :status))) + (t/is (empty? (filter media-change-types (squashed-log-types branch-id)))) + ;; again, with and without new main changes + (t/is (nil? (:error (add-color-on-main! file)))) + (t/is (= :updated (-> (update! branch-id) :result :status))) + (t/is (empty? (filter media-change-types (squashed-log-types branch-id)))) + (t/is (= :updated (-> (update! branch-id) :result :status))) + (t/is (empty? (filter media-change-types (squashed-log-types branch-id)))))) + + (t/testing "media present before the fork" + (let [file (th/create-file* 2 {:profile-id (:id profile) + :project-id proj-id}) + _ (t/is (nil? (:error (add-media-on-main! file "before.png")))) + create (:result (th/command! {::th/type :create-file-branch + ::rpc/profile-id (:id profile) + :file-id (:id file) + :name "before-fork"})) + branch-id (:id create)] + ;; a main-side change so the update reaches the write path + (t/is (nil? (:error (add-color-on-main! file)))) + (t/is (= :updated (-> (update! branch-id) :result :status))) + (t/is (empty? (filter media-change-types (squashed-log-types branch-id)))) + ;; again, with and without new main changes + (t/is (nil? (:error (add-color-on-main! file)))) + (t/is (= :updated (-> (update! branch-id) :result :status))) + (t/is (empty? (filter media-change-types (squashed-log-types branch-id)))) + (t/is (= :updated (-> (update! branch-id) :result :status))) + (t/is (empty? (filter media-change-types (squashed-log-types branch-id))))))))) + +;; --- The branch-merge policy switch --- +;; +;; `resources/app/branch-merge-policies.edn` picks one alternative per +;; policy; the backend re-reads it on mtime change and binds the result +;; around every compare, merge, update and listing computation. These +;; tests pin what a developer flipping that file relies on. + +(t/deftest policies-file-invalid-falls-back-to-defaults + ;; An invalid policies file must not take a merge down with it: it + ;; logs a warning and the engine runs the built-in defaults. + (let [path (doto (java.io.File/createTempFile "branch-policies-" ".edn") + (.deleteOnExit)) + logged (volatile! []) + run (fn [content mtime] + (spit path content) + (.setLastModified path mtime) + (vreset! logged []) + (with-redefs [cf/config (assoc cf/config + :branch-merge-policies-file (str path)) + ;; `l/warn` expands to `emit-log`, so this + ;; captures what the loader logs + l/emit-log (fn [props _cause _context _logger level _sync?] + (let [props (if (delay? props) @props props)] + (vswap! logged conj + {:level level + :props (into {} props)})))] + (fbp/effective-policies))) + warned? (fn [] + (some (fn [record] + (and (= :warn (:level record)) + (= "invalid branch merge policies file" + (:hint (:props record))))) + @logged))] + + ;; a value outside the policy's alternatives is invalid + (t/is (= bm/default-policies (run "{:same-parent-reorder :not-an-alternative}" + 1700000000000))) + (t/is (warned?)) + + ;; a file that is not a policy map at all is invalid the same way + (t/is (= bm/default-policies (run "[1 2 3]" 1700000001000))) + (t/is (warned?)))) + +(t/deftest policies-file-reloads-on-mtime-change + ;; Editing the policies file changes the effective policy the very + ;; next compare reads — no restart: the loader re-reads on mtime + ;; change and binds the result around the comparison. + (with-redefs [cf/flags (conj cf/flags :branching)] + (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}) + branch-id (-> (th/command! {::th/type :create-file-branch + ::rpc/profile-id (:id profile) + :file-id (:id file) + :name "policies-reload"}) + :result :id) + path (doto (java.io.File/createTempFile "branch-policies-" ".edn") + (.deleteOnExit)) + seen (volatile! nil) + write! (fn [content mtime] + (spit path content) + (.setLastModified path mtime)) + compare! (fn [] + (let [out (th/command! {::th/type :get-branch-diff + ::rpc/profile-id (:id profile) + :branch-id branch-id})] + (t/is (nil? (:error out)))))] + + (write! "{:same-parent-reorder :refuse}" 1700000000000) + (with-redefs [cf/config (assoc cf/config + :branch-merge-policies-file (str path)) + bm/compute-merge (fn [& _] + (vreset! seen bm/*policies*) + {:changes [] :conflicts []})] + (compare!) + (t/is (= :refuse (get @seen :same-parent-reorder))) + + ;; the same file, edited in place so its mtime moves, is picked + ;; up by the next compare: the switch needs no restart + (write! "{:same-parent-reorder :ignore}" 1700000001000) + (compare!) + (t/is (= :ignore (get @seen :same-parent-reorder))))))) + +(t/deftest summary-cache-key-changes-with-policies + ;; Two different policies must never share a cached summary: the key + ;; hashes the policies the value was computed under. + (let [row {:base-snapshot-id (uuid/random) :source-revn 1 :branch-revn 2} + key-of (fn [policies] + (binding [bm/*policies* policies] + (#'fbranch/summary-cache-key row))) + k-default (key-of bm/default-policies) + k-ignore (key-of (assoc bm/default-policies :same-parent-reorder :ignore)) + k-expand (key-of (assoc bm/default-policies :container-delete-over-main-edits :expand))] + + ;; the key is stable for the same policies … + (t/is (= k-default (key-of bm/default-policies))) + ;; … and distinct for different ones + (t/is (not= k-default k-ignore)) + (t/is (not= k-default k-expand)) + (t/is (not= k-ignore k-expand)))) diff --git a/backend/test/backend_tests/rpc_file_pull_request_test.clj b/backend/test/backend_tests/rpc_file_pull_request_test.clj index 539c3740a4..8ae0908c56 100644 --- a/backend/test/backend_tests/rpc_file_pull_request_test.clj +++ b/backend/test/backend_tests/rpc_file_pull_request_test.clj @@ -12,6 +12,8 @@ [app.common.uuid :as uuid] [app.config :as cf] [app.db :as db] + [app.email :as eml] + [app.msgbus :as mbus] [app.rpc :as-alias rpc] [backend-tests.helpers :as th] [clojure.string :as str] @@ -738,3 +740,123 @@ error (:error out)] (t/is (some? error)) (t/is (= :branching-disabled (-> error ex-data :code))))) + +(t/deftest pull-request-commands-notify-only-after-the-commit + (with-redefs [cf/flags pr-flags] + (let [author (th/create-profile* 1 {:is-active true}) + reviewer (th/create-profile* 2 {:is-active true}) + file (th/create-file* 1 {:profile-id (:id author) + :project-id (:default-project-id author)})] + (th/create-team-role* {:team-id (:default-team-id author) + :profile-id (:id reviewer) + :role :editor}) + (let [branch (create-branch* author file "notify") + bfid (:branch-file-id branch) + actors {:author (:id author) :reviewer (:id reviewer)} + ;; one case per mutation; at the very moment `mbus/pub!` + ;; fires, `:view` reads the row ANOTHER pool connection sees + ;; and `:expected` is the state that must already be visible + ;; there (the transaction has committed) + cases + [{:label "create-pull-request" + :type :create-pull-request + :actor :author + :params (fn [_] {:branch-id (:id branch) + :title "review me" + :reviewers [(:id reviewer)]}) + :message-type :pull-request-created + :view (fn [id] (select-keys (th/db-get :file-pull-request {:id id}) + [:status])) + :expected (constantly {:status "open"})} + + {:label "update-pull-request" + :type :update-pull-request + :actor :author + :params (fn [id] {:id id :title "renamed"}) + :message-type :pull-request-updated + :view (fn [id] (select-keys (th/db-get :file-pull-request {:id id}) + [:title])) + :expected (constantly {:title "renamed"})} + + {:label "update-pull-request-snapshot" + :type :update-pull-request-snapshot + :actor :author + ;; the sandbox only republishes when the branch moved + :before (fn [] (add-color* author bfid "Extra")) + :params (fn [id] {:id id}) + :message-type :pull-request-updated + :view (fn [id] (select-keys (th/db-get :file-pull-request {:id id}) + [:review-revn])) + :expected (fn [_] {:review-revn (:revn (th/db-get :file {:id bfid}))})} + + {:label "submit-pull-request-review" + :type :submit-pull-request-review + :actor :reviewer + :params (fn [id] {:id id :state "approved" :comment "ship it"}) + :message-type :pull-request-review-submitted + :view (fn [id] (select-keys (th/db-get :file-pull-request-review + {:pull-request-id id + :profile-id (:id reviewer)}) + [:state :reviewed-revn])) + :expected (fn [id] {:state "approved" + :reviewed-revn (:review-revn (th/db-get :file-pull-request {:id id}))})} + + {:label "close-pull-request" + :type :close-pull-request + :actor :author + :params (fn [id] {:id id}) + :message-type :pull-request-closed + :view (fn [id] (select-keys (th/db-get :file-pull-request {:id id}) + [:status])) + :expected (constantly {:status "closed"})} + + {:label "reopen-pull-request" + :type :reopen-pull-request + :actor :author + :params (fn [id] {:id id}) + :message-type :pull-request-updated + :view (fn [id] (select-keys (th/db-get :file-pull-request {:id id}) + [:status])) + :expected (constantly {:status "open"})}]] + (loop [cases cases + pr-id nil] + (when-some [{:keys [label type actor before params message-type view expected]} + (first cases)] + (let [seen (atom []) + _ (when before (before)) + out (with-redefs [mbus/pub! + (fn [_ & {:keys [message]}] + (swap! seen conj {:message message + :row (view (:pull-request-id message))}))] + (th/command! (merge {::th/type type + ::rpc/profile-id (actors actor)} + (params pr-id))))] + (t/is (nil? (:error out)) (str label " runs")) + (let [{:keys [message row]} (first @seen)] + (t/is (= 1 (count @seen)) (str label " publishes once")) + (t/is (= message-type (:type message)) (str label " message type")) + (t/is (= (expected (:pull-request-id message)) row) + (str label " publishes only after the commit"))) + (recur (rest cases) (or pr-id (-> out :result :id)))))))))) + +(t/deftest rolled-back-pull-request-commands-notify-nothing + (with-redefs [cf/flags pr-flags] + (let [author (th/create-profile* 1 {:is-active true}) + reviewer (th/create-profile* 2 {:is-active true}) + file (th/create-file* 1 {:profile-id (:id author) + :project-id (:default-project-id author)})] + (th/create-team-role* {:team-id (:default-team-id author) + :profile-id (:id reviewer) + :role :editor}) + (let [branch (create-branch* author file "rollback") + seen (atom [])] + ;; the reviewer emails are queued inside the transaction: make + ;; that queueing fail after the pull request row is written + (with-redefs [mbus/pub! (fn [_ & {:keys [message]}] + (swap! seen conj message)) + eml/send! (fn [_] (throw (IllegalStateException. "boom")))] + (let [out (create-pr* author (:id branch) {:reviewers [(:id reviewer)]})] + (t/is (some? (:error out))))) + (t/is (empty? @seen)) + (t/is (empty? (th/db-query :file-pull-request + {:file-branch-id (:id branch)}))))))) diff --git a/backend/test/backend_tests/rpc_file_snapshot_test.clj b/backend/test/backend_tests/rpc_file_snapshot_test.clj index a04e7c407b..84437c0a77 100644 --- a/backend/test/backend_tests/rpc_file_snapshot_test.clj +++ b/backend/test/backend_tests/rpc_file_snapshot_test.clj @@ -220,3 +220,115 @@ ;; (th/print-result! out) (t/is (nil? (:error out))) (t/is (true? (:result out))))))) + +(t/deftest snapshots-rename-guard + ;; Renaming a snapshot the user does not own must not convert it into + ;; a user snapshot: `fsnap/update!` flips `:created-by` to the caller + ;; and clears `:deleted-at`, so an unguarded rename makes the branch + ;; base pin (and any other system snapshot) deletable. + (with-redefs [cf/flags (conj cf/flags :branching)] + (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}) + + branch (:result (th/command! {::th/type :create-file-branch + ::rpc/profile-id (:id profile) + :file-id (:id file) + :name "rename-pin"})) + + ;; the pin is a system snapshot, so it carries a future + ;; deleted-at and only shows up without the deleted filter + pin (th/db-get :file-change + {:file-id (:id file) + :label "branch-base/rename-pin"} + {::db/remove-deleted false})] + + (t/testing "the branch base pin is a system snapshot" + (t/is (uuid? (:branch-file-id branch))) + (t/is (uuid? (:id pin))) + (t/is (= "system" (:created-by pin)))) + + (t/testing "renaming the branch base pin is refused" + (let [out (th/command! {::th/type :update-file-snapshot + ::rpc/profile-id (:id profile) + :id (:id pin) + :label "stolen-label"})] + (t/is (some? (:error out))) + (t/is (= :system-snapshots-cant-be-renamed (th/ex-code (:error out)))))) + + (t/testing "the pin keeps its label and system ownership" + (let [pin (th/db-get :file-change {:id (:id pin)} {::db/remove-deleted false})] + (t/is (= "branch-base/rename-pin" (:label pin))) + (t/is (= "system" (:created-by pin))))) + + (t/testing "the pin is still not deletable" + (let [out (th/command! {::th/type :delete-file-snapshot + ::rpc/profile-id (:id profile) + :file-id (:id file) + :id (:id pin)})] + (t/is (some? (:error out))) + (t/is (= :system-snapshots-cant-be-deleted (th/ex-code (:error out)))))) + + (t/testing "other system snapshots are refused the same way" + ;; restoring creates a system backup snapshot of the current + ;; state; renaming it must not adopt it either + (let [file2 (th/create-file* 2 {:profile-id (:id profile) + :project-id (:default-project-id profile) + :is-shared false}) + user-snap (:result (th/command! {::th/type :create-file-snapshot + ::rpc/profile-id (:id profile) + :file-id (:id file2) + :label "user-version"}))] + + (t/is (nil? (:error (th/command! {::th/type :restore-file-snapshot + ::rpc/profile-id (:id profile) + :file-id (:id file2) + :id (:id user-snap)})))) + + (let [backup (th/db-get :file-change + {:file-id (:id file2) + :created-by "system"} + {::db/remove-deleted false}) + out (th/command! {::th/type :update-file-snapshot + ::rpc/profile-id (:id profile) + :id (:id backup) + :label "stolen-backup"})] + (t/is (uuid? (:id backup))) + (t/is (some? (:error out))) + (t/is (= :system-snapshots-cant-be-renamed (th/ex-code (:error out)))) + (t/is (= "system" (:created-by (th/db-get :file-change {:id (:id backup)} + {::db/remove-deleted false})))))))))) + +(t/deftest snapshots-restore-guard + ;; Restoring onto a branch file would write the restored document as + ;; the branch's own `file_data` payload and advance its revn, while + ;; `branch-file-data` keeps deriving from the branch base and the op + ;; log and never reads that payload: the branch silently + ;; desynchronises. + (with-redefs [cf/flags (conj cf/flags :branching)] + (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}) + branch (:result (th/command! {::th/type :create-file-branch + ::rpc/profile-id (:id profile) + :file-id (:id file) + :name "restore-target"})) + branch-id (:branch-file-id branch) + + snap (:result (th/command! {::th/type :create-file-snapshot + ::rpc/profile-id (:id profile) + :file-id branch-id + :label "branch-version"})) + + out (th/command! {::th/type :restore-file-snapshot + ::rpc/profile-id (:id profile) + :file-id branch-id + :id (:id snap)})] + + (t/is (uuid? branch-id)) + (t/is (uuid? (:id snap))) + (t/is (some? (:error out))) + (t/is (= :branch-file-cant-be-restored (th/ex-code (:error out)))) + (t/is (empty? (th/db-query :file-data {:file-id branch-id :type "main"})))))) diff --git a/common/src/app/common/files/branch_merge.cljc b/common/src/app/common/files/branch_merge.cljc index 945a54907c..6d80f8b58e 100644 --- a/common/src/app/common/files/branch_merge.cljc +++ b/common/src/app/common/files/branch_merge.cljc @@ -17,16 +17,72 @@ `unsupported-kinds` reports so the caller refuses them. Direction `:branch->main` (merge/compare) treats main as `theirs` and - branch as `ours`; `:main->branch` (update from main) swaps them." + branch as `ours`; `:main->branch` (update from main) swaps them. The + reported payload names the DOCUMENTS either way (see `compute-merge`)." (:require [app.common.data :as d] [app.common.files.helpers :as cfh] [app.common.types.component :as ctk] + [app.common.types.pages-list :as ctpl] [app.common.types.tokens-lib :as ctob] [app.common.uuid :as uuid] [clojure.set :as set] [clojure.string :as str])) +;; --- Tree-shape policies --- +;; +;; Three tree-shape cases have more than one defensible merge. The engine +;; reads the choice from `*policies*`; the backend binds it from +;; `backend/resources/app/branch-merge-policies.edn` around every compare, +;; merge and update. + +(def default-policies + "Policy chosen for each tree-shape case when none is configured." + {:same-parent-reorder :merge + :addition-under-deleted-parent :conflict + :container-delete-over-main-edits :conflict}) + +(def policy-values + "Allowed alternatives per policy key. + + `:same-parent-reorder`: one side reorders the children of a parent both + sides keep. + `:merge` detected, reported as a `:shapes` attr on the parent and + applied as `:mov-objects`; both sides reordering it + differently is a conflict on the parent. + `:refuse` reported as an `:unsupported` `:shape-order` entry naming + the parent, so the merge or update refuses. + `:ignore` invisible and lost (the behaviour before the policy). + + `:addition-under-deleted-parent`: the target deleted container P and the + source added a shape inside it. + `:conflict` a `:modify-delete` conflict on P (see `three-way-entities`). + `:refuse` reported as an `:unsupported` `:shape-orphan` entry naming + P. + `:reparent-to-ancestor` the addition lands under the nearest ancestor + the target still has. + `:page-root` the addition lands at the page root (the behaviour before + the policy). + + `:container-delete-over-main-edits`: the source deleted container F while + the target modified or added something in F's subtree. + `:conflict` a `:delete-modify` conflict on F. + `:expand` only what the source deleted goes; the target's additions + move to F's parent. + `:cascade` F goes with its whole subtree (the behaviour before the + policy)." + {:same-parent-reorder #{:merge :refuse :ignore} + :addition-under-deleted-parent #{:conflict :refuse :reparent-to-ancestor :page-root} + :container-delete-over-main-edits #{:conflict :expand :cascade}}) + +(def ^:dynamic *policies* + "Effective policies; the engine reads only `(get *policies* k)`." + default-policies) + +(defn- policy + [k] + (get *policies* k (get default-policies k))) + (defn- entity-label [kind v] (or (:name v) @@ -75,11 +131,15 @@ (defn- merge-attrs "Entity to apply for a per-attr resolution: start from main (`t`) and overlay branch's value for each differing attr resolved to `:branch`. - For `res = :branch` this equals `o`; for `:main`/nil it equals `t`." + For `res = :branch` this equals `o`; for `:main`/nil it equals `t`. + An attr the winning side does not carry is REMOVED (absent key — how the + closed change schemas express removal) rather than assoc-ed nil." [t o res] (reduce (fn [acc [k {:keys [branch]}]] (if (= :branch (attr-side res k)) - (assoc acc k branch) + (if (nil? branch) + (dissoc acc k) + (assoc acc k branch)) acc)) t (shallow-attr-diff t o))) @@ -174,9 +234,15 @@ (defn three-way-entities "Diff one indexed entity collection (id->value) across base/theirs/ours. - Returns `{:changes [..] :conflicts [..]}` where changes are the - branch's net additions/modifications/deletions that apply cleanly to - main, and conflicts are entities both sides diverged on. + Returns `{:changes [..] :conflicts [..]}` where changes are `ours`' net + additions/modifications/deletions that apply cleanly to `theirs`, and + conflicts are entities both sides diverged on. + + Entries label the two sides for the `:branch->main` roles: `:main` holds + the `theirs` value and `:branch` the `ours` one. `compute-merge` renames + them to the two documents before reporting them (see `doc-sides`), so a + summary names main's value `:main` and the branch's `:branch` in both + directions. `ctx`: `{:kind :page-id }`. Optional display knobs (do NOT affect the actual merge, only this summary): @@ -282,6 +348,25 @@ [page] (select-keys page [:name :background :pixel-grid-color :pixel-grid-opacity])) +(def ^:private clearable-page-meta + "Page meta attrs the `:mod-page` schema expresses removal for with an + explicit nil (`[:maybe ...]` slots: nil is what `mod-page` removes on)." + [:background :pixel-grid-color :pixel-grid-opacity]) + +(defn- page-meta-clears + "The `:mod-page` attrs for the winning meta map `m` of a page whose + target meta is `t`: a clearable attr `m` lacks but `t` still carries is + emitted as explicit nil — the value `mod-page` removes on (an absent key + would leave main's value in place)." + [t m] + (reduce (fn [acc k] + (cond-> acc + (and (not (contains? m k)) + (contains? t k)) + (assoc k nil))) + m + clearable-page-meta)) + (defn- page-extra "Residual page attrs that no pass handles — kept as `:page-attrs` to be refused (never silently dropped). Objects, name/background/grid, guides, @@ -328,9 +413,318 @@ (transient {}) (or pd {})))) +;; --- Shape tree --- +;; +;; `three-way-entities` classifies shapes one by one, while containment +;; and child order are relations between them. The helpers below put the +;; tree back: they find same-parent reorders for the classification and +;; apply the tree-shape policies (`*policies*`) to a page's result. They +;; work in the roles of `three-way-entities`: `to` is the target of the +;; change (theirs) and `oo` its source (ours). + +(defn- index-of + [coll x] + (first (keep-indexed (fn [i v] (when (= v x) i)) coll))) + +(defn- subtree-ids + "`id` plus all its descendants' ids, walking `:shapes` in `objects`." + [objects id] + (loop [pending [id] out []] + (if (empty? pending) + out + (let [cur (peek pending)] + (recur (into (pop pending) (get-in objects [cur :shapes])) + (conj out cur)))))) + +(defn- shape-depth + "Depth of a shape in its objects tree (root = 0). Used to order moves so a + container is relocated before the shapes the branch moved into it." + [objects id] + (loop [id id d 0] + (let [p (:parent-id (get objects id))] + (if (and p (not= p id) (contains? objects p)) + (recur p (inc d)) + d)))) + +(defn- root-id? + "True for the page root and for a missing parent." + [id] + (or (nil? id) (= id uuid/zero))) + +(defn- preorder-ids + "`id` and its descendants in `objects`, parents first and children in + `:shapes` order." + [objects id] + (loop [stack (list id) out []] + (if (empty? stack) + out + (let [cur (first stack)] + (recur (into (rest stack) (reverse (get-in objects [cur :shapes]))) + (conj out cur)))))) + +(defn- relative-order + [shapes keep] + (filterv #(contains? keep %) shapes)) + +(defn- child-reorder + "Relative order, on each side, of the children `os` shares with `bs` + (and with `ts` when `theirs?`), when `os` changes it; nil otherwise. + Equal vectors short-circuit, so an untouched parent costs one `=`." + [bs ts os theirs?] + (when-not (or (identical? bs os) (= bs os)) + (let [keep (cond-> (set/intersection (set bs) (set os)) + theirs? (set/intersection (set ts)))] + (when (> (count keep) 1) + (let [order-b (relative-order bs keep) + order-o (relative-order os keep)] + (when (not= order-b order-o) + {:base order-b + :theirs (when theirs? (relative-order ts keep)) + :ours order-o})))))) + +(defn- shape-reorders + "Parent id -> `child-reorder` for every parent whose children `oo` + reorders against `bo`." + [bo to oo] + (persistent! + (reduce-kv (fn [acc id o] + (let [os (:shapes o) + b (when (some? os) (get bo id))] + (if (nil? b) + acc + (let [t (get to id)] + (if-let [r (child-reorder (:shapes b) (:shapes t) os (some? t))] + (assoc! acc id r) + acc))))) + (transient {}) + (or oo {})))) + +(defn- classification-objects + "The stripped objects maps (see `strip-shapes`) a page's shapes are + classified on, plus the same-parent reorders `oo` makes. + + Under `:same-parent-reorder :merge` a reordered parent carries the + relative order of its shared children as `:shapes` on every side that + has it, so the reorder classifies as a change of the parent and both + sides reordering it differently as a conflict on it. `:refuse` finds + the reorders without classifying them; `:ignore` skips the scan." + [bo to oo] + (let [mode (policy :same-parent-reorder) + reorders (if (= :ignore mode) {} (shape-reorders bo to oo)) + inject (fn [objects side] + (if (and (= :merge mode) (seq reorders)) + (reduce-kv (fn [acc id r] + (if (contains? acc id) + (assoc-in acc [id :shapes] (get r side)) + acc)) + objects + reorders) + objects))] + {:sbo (inject (strip-shapes bo) :base) + :sto (inject (strip-shapes to) :theirs) + :soo (inject (strip-shapes oo) :ours) + :reorders reorders})) + +(defn- tree-modes + "The tree-shape policies in the roles of `three-way-entities` for `dir`. + + The policies name the documents and the engine handles two role + shapes: `:lost`, the target deleted a container the source edits + inside (main deleted P and the branch added into it, when merging), + and `:dropped`, the source deleted a container the target edits into + (the branch deleted F while main edited inside it, when merging). A + merge maps each policy to its own shape; an update from main swaps the + roles, so each policy drives the other shape through the alternative + that means the same thing for the documents. + + A mechanism's alternatives: + `:lost` `:conflict` (a `:modify-delete` conflict on the container: + `:branch` restores it as the source has it, additions + included, `:main` drops the source's shapes), `:refuse`, + `:reparent-to-ancestor`, `:page-root`, `:cascade` (the + container goes with its whole subtree). + `:dropped` `:conflict` (a `:delete-modify` conflict on the container: + `:branch` deletes the whole subtree knowingly, `:main` + keeps it as the target has it), `:expand` (the target's + shapes relocate to the container's slot in its parent), + `:page-root`, `:refuse`, `:cascade`." + [dir] + (let [update? (= dir :main->branch) + add (policy :addition-under-deleted-parent) + cont (policy :container-delete-over-main-edits)] + {:order (policy :same-parent-reorder) + :lost (if update? + (get {:conflict :conflict :expand :reparent-to-ancestor :cascade :cascade} + cont :conflict) + (get {:conflict :conflict :refuse :refuse + :reparent-to-ancestor :reparent-to-ancestor :page-root :page-root} + add :conflict)) + :dropped (if update? + (get {:conflict :conflict :refuse :refuse + :reparent-to-ancestor :expand :page-root :page-root} + add :conflict) + (get {:conflict :conflict :expand :expand :cascade :cascade} + cont :conflict))})) + +(defn- lost-root + "Highest shape on `id`'s ancestry in the source tree `oo`, `id` + included, that the target deleted. The walk climbs while a shape is + absent from the target `to`, either deleted there (it is in the base + `bo`) or added by the source; nil when it meets no deleted shape." + [bo to oo id] + (loop [cur id top nil n (count oo)] + (if (or (root-id? cur) (contains? to cur) (not (contains? oo cur)) (neg? n)) + top + (recur (:parent-id (get oo cur)) + (if (contains? bo cur) cur top) + (dec n))))) + +(defn- target-subtree-edits + "Ids in the target's subtree of `id`, `id` excluded, that the target + added, changed or (unless `order-mode` is `:ignore`) reordered the + children of, against the base." + [bo to sbo sto order-mode id] + (filterv (fn [d] + (let [b (get bo d)] + (or (nil? b) + (not= (strip-nil-attrs (get sbo d)) (strip-nil-attrs (get sto d))) + (and (not= :ignore order-mode) + (some? (child-reorder (:shapes b) nil (:shapes (get to d)) false)))))) + (rest (preorder-ids to id)))) + +(defn- source-deleted-roots + "The ids of `deleted` whose parent in `to` is not in `deleted`: the + topmost shapes of each deleted subtree." + [to deleted] + (filterv #(not (contains? deleted (:parent-id (get to %)))) deleted)) + +(defn- tree-policy-pass + "Apply the tree-shape policies (`tree-modes`) to one page's shape + result `res` from `three-way-entities`. + + `:same-parent-reorder :refuse` adds an `:unsupported` `:shape-order` + entry per reordered parent the merge would have to reorder. + + `:lost` gathers the source's additions, and its changes to shapes the + target deleted, under the highest deleted shape on their path + (`lost-root`). `:conflict` replaces them with one `:modify-delete` + conflict on that shape: resolved to `:branch` it restores the shape + and its subtree as the source has them, additions included; resolved + to `:main` it leaves them out. `:refuse` adds an `:unsupported` + `:shape-orphan` entry per deleted shape holding an addition. The other + alternatives act in `page-shape-changes`. + + `:dropped` looks at the topmost shapes the source deleted whose + subtree the target edited (added, changed or reordered something in). + `:conflict` turns each into one `:delete-modify` conflict that replaces + its `:deleted` entry and every entry inside its subtree: resolved to + `:branch` the whole subtree goes, resolved to `:main` it stays as the + target has it. `:refuse` adds an `:unsupported` `:shape-orphan` entry + per such shape the target added inside. The other alternatives act in + `page-shape-changes`. + + A region conflict lists the shapes it decides for in `:subtree-edits` + (`[{:id :label}]`). Without any of these cases the pass returns `res` + as it is." + [{:keys [changes conflicts] :as res} bo to oo sbo sto reorders page-id modes] + (let [{lost-mode :lost dropped-mode :dropped order-mode :order} modes + label (fn [id] (entity-label :shape (or (get oo id) (get to id) (get bo id)))) + edits (fn [ids] (mapv (fn [id] {:id id :label (label id)}) ids)) + entry (fn [m] (assoc m :kind (:kind m :shape) :page-id page-id :label (label (:id m)))) + added? #(= :added (:status %)) + + refused-orders + (when (= :refuse order-mode) + (into [] (keep (fn [[id {:keys [theirs ours]}]] + (when (not= theirs ours) + (entry {:kind :shape-order :status :unsupported :id id + :policy :same-parent-reorder})))) + reorders)) + + ;; [id root] for the source's edits inside a container the target + ;; deleted, in result order + lost + (case lost-mode + :conflict (into [] (keep (fn [{:keys [id]}] + (when-let [r (lost-root bo to oo id)] [id r]))) + (concat (filter added? changes) + (filter #(= :modify-delete (:reason %)) conflicts))) + :refuse (into [] (keep (fn [{:keys [id]}] + (when-let [r (lost-root bo to oo id)] [id r]))) + (filter added? changes)) + []) + lost-ids (into #{} (map first) lost) + lost-by (group-by second lost) + + ;; topmost shapes the source deleted whose subtree the target edited + dropped + (if (contains? #{:conflict :refuse} dropped-mode) + (let [deleted (into #{} (comp (filter #(or (= :deleted (:status %)) + (= :delete-modify (:reason %)))) + (map :id)) + (concat changes conflicts))] + (into [] (keep (fn [f] + (let [e (cond->> (target-subtree-edits bo to sbo sto order-mode f) + (= :refuse dropped-mode) (filterv #(not (contains? bo %))))] + (when (seq e) [f e])))) + (source-deleted-roots to deleted))) + []) + dropped-in (into #{} (mapcat (fn [[f _]] (preorder-ids to f))) dropped)] + + (if (and (empty? refused-orders) (empty? lost) (empty? dropped)) + res + (let [lost-conflict? (= :conflict lost-mode) + dropped-conflict? (= :conflict dropped-mode) + region-edits (merge (into {} (map (fn [[r pairs]] + [r (edits (into [] (comp (map first) (remove #{r})) pairs))])) + (when lost-conflict? lost-by)) + (when dropped-conflict? (into {} (map (fn [[f e]] [f (edits e)])) dropped))) + own-reason (fn [id] (if (contains? lost-by id) :modify-delete :delete-modify)) + absorbed? (fn [{:keys [id status reason]}] + (or (and lost-conflict? (contains? lost-ids id) + (or (= :added status) (= :modify-delete reason)) + (not (contains? region-edits id))) + (and dropped-conflict? (contains? dropped-in id) + (or (= :deleted status) (= :delete-modify reason))))) + kept-conflicts (into [] (remove absorbed?) conflicts) + own (into #{} (keep (fn [{:keys [id reason]}] + (when (and (contains? region-edits id) + (= reason (own-reason id))) + id))) + kept-conflicts) + conflicts' (-> (mapv (fn [c] + (if (and (contains? own (:id c)) + (= (:reason c) (own-reason (:id c)))) + (assoc c :subtree-edits (get region-edits (:id c))) + c)) + kept-conflicts) + (into (comp (remove own) + (map (fn [r] + (entry {:status :conflict :id r + :reason (own-reason r) + :subtree-edits (get region-edits r)})))) + (keys region-edits))) + refused-orphans (concat + (when (= :refuse lost-mode) + (map (fn [[r pairs]] + (entry {:kind :shape-orphan :status :unsupported :id r + :policy :addition-under-deleted-parent + :shapes (mapv first pairs)})) + lost-by)) + (when (= :refuse dropped-mode) + (map (fn [[f e]] + (entry {:kind :shape-orphan :status :unsupported :id f + :policy :addition-under-deleted-parent + :shapes e})) + dropped)))] + {:changes (-> (into [] (remove absorbed?) changes) + (into refused-orders) + (into refused-orphans)) + :conflicts conflicts'})))) + (defn- diff-pages - ([base theirs ours] (diff-pages base theirs ours nil)) - ([base theirs ours only-pages] + ([base theirs ours] (diff-pages base theirs ours nil :branch->main)) + ([base theirs ours only-pages dir] ;; `only-pages` bounds every page pass, the presence one included, ;; because `page-content` strips the shapes of every page it looks at ;; and that is most of what a whole-file comparison costs. It is the @@ -395,19 +789,25 @@ (plugin-of ours pid) {:kind :page-plugin :page-id pid})) common) - ;; objects (shapes) on common pages (mergeable: :shape). The page - ;; root frame (uuid/zero) is skipped and the shapes are diffed - ;; STRIPPED of derived attrs (`shape-ignored-attrs`) so that pure - ;; `:shapes`/`:touched`/geometry-cache churn neither shows up as a - ;; change nor manufactures false conflicts (their merge is driven - ;; by add/del/move ops, not by these values). + ;; objects (shapes) on common pages (mergeable: :shape). The shapes + ;; are diffed STRIPPED of derived attrs (`shape-ignored-attrs`) and + ;; with the same-parent reorders folded in as `:shapes` of their + ;; parent (`classification-objects`), so derived churn neither shows + ;; up as a change nor manufactures false conflicts, while a reorder + ;; is a change of the parent. The page root frame (uuid/zero) is + ;; skipped unless the reordering touches it: top-level layer order + ;; is a real, user-meaningful change. + modes (tree-modes dir) obj-diffs (map (fn [pid] (let [bo (get-in base [:pages-index pid :objects] {}) to (get-in theirs [:pages-index pid :objects] {}) oo (get-in ours [:pages-index pid :objects] {}) - res (three-way-entities (strip-shapes bo) (strip-shapes to) (strip-shapes oo) + {:keys [sbo sto soo reorders]} (classification-objects bo to oo) + res (three-way-entities sbo sto soo {:kind :shape :page-id pid - :ignore-ids #{uuid/zero}}) + :ignore-ids (if (contains? reorders uuid/zero) + #{} + #{uuid/zero})}) ;; enrich each entry with the shape's type/component ;; nature, read from whichever side still has it enrich (fn [e] @@ -423,9 +823,18 @@ (assoc e :base (get bo (:id e)) :main (get to (:id e)) - :branch (get oo (:id e))))] - {:changes (mapv enrich (:changes res)) - :conflicts (mapv (comp rehydrate enrich) (:conflicts res))})) + :branch (get oo (:id e)))) + passed (tree-policy-pass res bo to oo sbo sto reorders pid modes)] + {:changes (mapv (fn [e] + ;; a `:refuse` entry names the + ;; container it could not place + ;; under; it is not a shape to + ;; display + (if (= :unsupported (:status e)) + e + (enrich e))) + (:changes passed)) + :conflicts (mapv (comp rehydrate enrich) (:conflicts passed))})) common)] (merge-results (concat [presence meta-diff extra-diff order] guides-diffs flows-diffs grids-diffs plugins-diffs obj-diffs))))) @@ -509,6 +918,19 @@ (let [s (ctob/get-set lib set-id)] [(ctob/get-name s) (ctob/get-description s)])) +(defn- set-rename-wins? + "True when the rename/description change for `sid` is emitted: branch + changed the set metadata and either main left it at the base or the + resolution takes branch. Those renames run before the set-order moves + in the change list, so they settle the names the moves address." + [bl ml ol resolutions sid] + (let [b (set-meta-of bl sid) + m (set-meta-of ml sid) + o (set-meta-of ol sid)] + (and (not= o b) + (or (= m b) + (= (get resolutions sid) :branch))))) + (defn- lib-tokens-by-id "token-id -> token (plain map) for a single set." [lib set-id] @@ -686,9 +1108,13 @@ whole map, so `:obj`, `:page`, `:params`, and a component's `:objects` are complete on their own. The payloads it cannot see are the values that ARE the reference: a media object's `:id` (its `:media-id` is a storage key and - must not be touched), a library color's `:image` id, and an operation value - that is the reference itself. Token changes are left alone: no id in - `id-map` is a token id." + must not be touched), a library color's `:image` id, a `:del-media`'s + top-level `:id`, and an operation value that is the reference itself. The + top-level `:id` of the other delete changes (`:del-color`, + `:del-typography`, `:del-component`, `:del-obj`, `:del-page`) is NOT such a + value: those name entities the two files share by id, never a media row, + so they are left alone — only a media id or the file id is ever a key of + `id-map`. Token changes are left alone: no id in `id-map` is a token id." [changes id-map] (if (empty? id-map) changes @@ -696,6 +1122,9 @@ relink #(cfh/relink-refs % lookup)] (mapv (fn [change] (cond-> (relink change) + (= :del-media (:type change)) + (update :id lookup) + (uuid? (:id (:object change))) (update-in [:object :id] lookup) @@ -724,12 +1153,38 @@ (transient {}) (or index {})))) +(defn- doc-sides + "Rewrite one summary entry from the comparison roles to the documents. + + `three-way-entities` reports entries in the `:branch->main` roles — the + `theirs` value under `:main`, the `ours` value under `:branch`. For + `:main->branch` the engine runs with those roles fed the other way round + (so the reported changes are main's), and this renames the payload back + before `compute-merge` reports it: the two entity sides, the two values + inside every `:changed-attrs` pair, and the two delete reasons. + `:delete-modify` names the branch's deletion against main's modification + and `:modify-delete` the branch's modification against main's deletion — + the same meaning in both directions." + [{:keys [status changed-attrs] :as entry}] + (let [entry (cond-> entry + (map? changed-attrs) + (assoc :changed-attrs + (into {} (map (fn [[k v]] [k {:main (:branch v) :branch (:main v)}])) + changed-attrs)))] + (if (= :conflict status) + (-> entry + (assoc :main (:branch entry) :branch (:main entry)) + (update :reason #(get {:delete-modify :modify-delete + :modify-delete :delete-modify} % %))) + entry))) + (defn- compute-merge* "The comparison itself. Both arities of `compute-merge` land here rather than one delegating to the other through the var, so that a test which counts engine calls counts comparisons and not dispatches." [base main branch dir only-pages] - (let [[theirs ours] (if (= dir :main->branch) [branch main] [main branch]) + (let [update? (= dir :main->branch) + [theirs ours] (if update? [branch main] [main branch]) results [(three-way-entities (strip-modified-at (:colors base)) (strip-modified-at (:colors theirs)) (strip-modified-at (:colors ours)) @@ -744,11 +1199,20 @@ {:kind :component}) (three-way-entities (:media base) (:media theirs) (:media ours) {:kind :media}) - (diff-pages base theirs ours only-pages) + (diff-pages base theirs ours only-pages dir) (diff-tokens base theirs ours)] - {:keys [changes conflicts]} (merge-results results)] + {:keys [changes conflicts]} (merge-results results) + ;; the engine reports `ours`' changes against `theirs` and labels + ;; those roles `:main`/`:branch`; the summary names the DOCUMENTS, + ;; so `:main->branch` (theirs=branch, ours=main) is renamed here + ;; (see `doc-sides`) + changes (if update? (mapv doc-sides changes) changes) + conflicts (if update? (mapv doc-sides conflicts) conflicts)] {:changes changes :conflicts conflicts + ;; the tree-shape policies act per direction (`tree-modes`), so + ;; `compute-changes` needs to know which one this summary is + :dir dir :stats {:added (count (filterv #(= :added (:status %)) changes)) :modified (count (filterv #(= :modified (:status %)) changes)) :deleted (count (filterv #(= :deleted (:status %)) changes)) @@ -762,6 +1226,15 @@ :conflicts [ ...] ; need resolution :stats {:added n :modified n :deleted n :conflicts n}} + Every entry names the two DOCUMENTS, whatever `dir`: `:main` carries + main's value, `:branch` the branch's, and each `:changed-attrs` pair + (`attribute -> {:main v :branch v}`) says the same. The two delete + reasons do not flip with `dir` either: `:delete-modify` names the + branch's deletion against main's modification, `:modify-delete` the + branch's modification against main's deletion. The `:changes` do follow + `dir` — `:branch->main` reports the branch's outgoing changes, + `:main->branch` main's incoming ones. + `opts` may carry `:only-pages`, a set of page ids the page passes are bounded to. It is sound exactly when `ours` cannot differ from `base` outside that set, because then no page outside it can carry an @@ -849,10 +1322,6 @@ [] (set/union (set (keys base)) (set (keys theirs)) (set (keys ours))))) -(defn- index-of - [coll x] - (first (keep-indexed (fn [i v] (when (= v x) i)) coll))) - (def ^:private structural-set-attrs "Attrs NOT expressible as a plain `:set` op: containment/order are applied via `:mov-objects` and add/del object changes, so setting their raw values @@ -895,26 +1364,6 @@ [:selrect :points]) ops))) -(defn- subtree-ids - "`id` plus all its descendants' ids, walking `:shapes` in `objects`." - [objects id] - (loop [pending [id] out []] - (if (empty? pending) - out - (let [cur (peek pending)] - (recur (into (pop pending) (get-in objects [cur :shapes])) - (conj out cur)))))) - -(defn- shape-depth - "Depth of a shape in its objects tree (root = 0). Used to order moves so a - container is relocated before the shapes the branch moved into it." - [objects id] - (loop [id id d 0] - (let [p (:parent-id (get objects id))] - (if (and p (not= p id) (contains? objects p)) - (recur p (inc d)) - d)))) - (defn- page-move-changes "Emit `:mov-objects` for EXISTING shapes the branch reparented to a different container, when the branch wins (main left the shape untouched, @@ -948,18 +1397,177 @@ :shapes [id] :ignore-touched true})))) +(defn- reorder-ops + "`:mov-objects` operations that make the parent's children follow + `order-o` (the source's order) among the shapes the target keeps. The + target's other children keep their slots; each shape out of place is + moved, one at a time, to the slot its relative order demands." + [to order-o page-id id] + (let [keep (set order-o) + cur0 (vec (get-in to [id :shapes])) + slots (into [] (keep-indexed (fn [i x] (when (contains? keep x) i))) cur0) + ;; the target's children with the shared ones in the source's + ;; order: the slots the shared shapes sit in, filled left to right + wanted (loop [src slots [x & xs] order-o out (vec cur0)] + (if (or (nil? x) (empty? src)) + out + (recur (rest src) xs (assoc out (first src) x))))] + (loop [i 0 cur cur0 out []] + (if (>= i (count wanted)) + out + (let [x (nth wanted i) + j (index-of cur x)] + (if (or (nil? j) (= i j)) + (recur (inc i) cur out) + (recur (inc i) + (d/insert-at-index cur i [x]) + (conj out {:type :mov-objects :page-id page-id + :parent-id id :index i :shapes [x] + :ignore-touched true})))))))) + +(defn- page-reorder-changes + "`:mov-objects` operations for the same-parent reorders (`reorders`) + the source wins: its order is the entry's `:ours`, or it resolved the + parent to `:branch`/`{:shapes :branch}`. Applied before everything + else, on the tree as the target has it." + [to _oo sbo sto reorders resolutions page-id] + (into [] + (mapcat (fn [[id {:keys [ours]}]] + (let [res (get resolutions id)] + (when (and (contains? to id) + (or (= (get sbo id) (get sto id)) + (= :branch (attr-side res :shapes)))) + (reorder-ops to ours page-id id))))) + reorders)) + +(defn- placement + "Where the merge creates the added shape `id`: its parent, its frame + and the index it takes among that parent's children. `lost-mode` is + the `:lost` alternative (`tree-modes`). + An orphan — a shape whose parent the result lacks, its `lost-root` + deleted — is created at the slot its lost root has under the nearest + ancestor the result keeps (`:reparent-to-ancestor`), at that slot but + on the page root (`:page-root`, `:refuse`), or not at all (`:cascade`, + which never calls this). Children of a placed shape keep their place + under it." + [oo to all-adds lost-mode root-id id] + (let [o (get oo id) + host (:parent-id o) + anchor (loop [cur host n (count oo)] + (cond + (root-id? cur) root-id + (or (contains? to cur) (contains? all-adds cur)) cur + (neg? n) root-id + :else (recur (:parent-id (get oo cur)) (dec n)))) + orphan? (not= anchor host) + chain (when orphan? + ;; the direct child of `anchor` on `id`'s ancestry + (loop [cur host n (count oo)] + (if (or (root-id? cur) (= anchor (:parent-id (get oo cur)))) + cur + (recur (:parent-id (get oo cur)) (dec n))))) + to-root? (and orphan? (contains? #{:page-root :refuse} lost-mode)) + parent (if to-root? root-id anchor) + index (if orphan? + (if to-root? + (index-of (get-in oo [host :shapes]) id) + (+ (or (index-of (get-in oo [anchor :shapes]) chain) 0) + (or (index-of (filterv #(contains? all-adds %) + (get-in oo [chain :shapes])) + id) + 0))) + (index-of (get-in oo [host :shapes]) id))] + {:parent parent + :frame (cond + (root-id? parent) uuid/zero + (= :frame (:type (get oo parent))) parent + :else (or (:frame-id (get oo parent)) uuid/zero)) + :index index + :depth (if orphan? + (inc (shape-depth oo anchor)) + (shape-depth oo id))})) + +(defn- expand-relocations + "Where the target's shapes move when the merge deletes a container out + from under them (`:dropped` `:expand`/`:page-root`): out of each + container the source deleted, to its slot in the nearest ancestor the + target keeps (`:expand`) or to the page root (`:page-root`). Shapes + whose target parent another relocated shape is travel with it. + Returns {container {:parent p :index i :depth d :shapes [...]}}." + [to deleted root-id mode] + (let [anchor (fn [f] + (loop [cur (:parent-id (get to f)) n (count to)] + (cond + (root-id? cur) root-id + (not (contains? deleted cur)) cur + (neg? n) root-id + :else (recur (:parent-id (get to cur)) (dec n))))) + lift? (fn [id] + (and (contains? to id) + (not (contains? deleted id)) + (contains? deleted (:parent-id (get to id))))) + lift-all? (fn [id] (and (contains? to id) (not (contains? deleted id)))) + groups (into {} + (keep (fn [f] + (let [ids (into [] (filter lift-all?) (rest (preorder-ids to f)))] + ;; only shapes whose own parent is gone need + ;; lifting; the others travel with them + (when-let [ids (seq (filter lift? ids))] + [f (vec ids)])))) + (source-deleted-roots to deleted))] + (persistent! + (reduce-kv (fn [acc f ids] + (let [p (if (= :page-root mode) root-id (anchor f)) + i (index-of (get-in to [(:parent-id (get to f)) :shapes]) f)] + (assoc! acc f {:parent p + :index i + :depth (if (= p root-id) 0 (inc (shape-depth to p))) + :shapes ids}))) + (transient {}) + groups)))) + +(defn- move-changes + "`:mov-objects` for the shapes `moves` relocates. Groups landing in the + same parent at the same slot (an expand out of nested containers) are + merged, so the group keeps one contiguous slot." + [moves page-id] + (->> moves + (sort-by (fn [[_ {:keys [depth]}]] depth)) + (reduce (fn [out [_ {:keys [parent index shapes]}]] + (let [k [parent index] + g [k {:parent parent :index index :shapes (vec shapes)}]] + (if-let [prev (peek out)] + (if (= k (key prev)) + (conj (pop out) [k (update (val prev) :shapes into shapes)]) + (conj out g)) + (conj out g)))) + []) + (map (fn [[_ {:keys [parent index shapes]}]] + {:type :mov-objects :page-id page-id :parent-id parent + :index index :shapes (vec shapes) :ignore-touched true})) + (vec))) + (defn- page-shape-changes - [base theirs ours resolutions page-id] + "Changes for one page's shapes under `dir`, with the tree-shape + policies (`tree-modes`) applied on top of `flat-changes`: + `:same-parent-reorder` reorders emit `:mov-objects`; `:lost` places or + restores the source's shapes under a container the target deleted; and + `:dropped` lifts the target's shapes out of a container the source + deleted before it goes. The order is reorders, relocations, + add/mod/del, moves: a relocation may depend on a new container and a + move on a new parent. + Returns `{:changes [...] :unsupported #{entries..}}`: the `:refuse` + alternatives report `:shape-orphan` entries naming the container + instead of a placement the merge cannot honour." + [base theirs ours resolutions page-id dir] (let [bo (get-in base [:pages-index page-id :objects] {}) to (get-in theirs [:pages-index page-id :objects] {}) oo (get-in ours [:pages-index page-id :objects] {}) - - ;; classification runs on STRIPPED shapes (no derived attrs) so - ;; `:shapes`/`:touched`/cache churn cannot fabricate changes or - ;; conflicts; emission reads the FULL maps. - sbo (strip-shapes bo) - sto (strip-shapes to) - soo (strip-shapes oo) + root-id uuid/zero + modes (tree-modes dir) + {lost-mode :lost dropped-mode :dropped order-mode :order} modes + snil= (fn [a b] (= (strip-nil-attrs a) (strip-nil-attrs b))) + {:keys [sbo sto soo reorders]} (classification-objects bo to oo) ;; modifications + deletions (additions handled below, ordered) mod-del @@ -978,51 +1586,119 @@ {:type :del-obj :page-id page-id :id id :ignore-touched true})) (filterv some?)) - ;; additions: present in branch, absent from base and main - added-set (into #{} (filter (fn [id] - (and (contains? oo id) - (not (contains? bo id)) - (not (contains? to id))))) - (keys oo)) + ;; the ids the merge deletes. `:dropped :conflict` resolved to + ;; `:main` keeps the container's whole subtree as the target has + ;; it, so no delete inside it is emitted + deleted (into #{} (keep (fn [{:keys [type id]}] + (when (= :del-obj type) id))) + mod-del) + dropped-roots (when (contains? #{:conflict :expand :page-root :refuse} dropped-mode) + (source-deleted-roots to deleted)) + kept (when (= :conflict dropped-mode) + (into #{} (mapcat #(preorder-ids to %)) + (filter #(= :main (get resolutions %)) dropped-roots))) + mod-del (if (seq kept) + (filterv (fn [{:keys [type id]}] + (not (and (= :del-obj type) (contains? kept id)))) + mod-del) + mod-del) - ;; modify-delete conflicts resolved to `:branch`: the branch modified - ;; a shape main deleted and the user chose to keep it — re-add its - ;; whole surviving subtree (main's delete was recursive), except the - ;; descendants main still has (it moved them out before deleting) + ;; `:lost`: the source's shapes under a container the target + ;; deleted — its additions and its changes to deleted shapes + lost-pairs (into [] + (keep (fn [id] + (when (and (contains? oo id) + (or (not (contains? bo id)) + (and (not (contains? to id)) + (not (snil= (get sbo id) (get soo id)))))) + (when-let [r (lost-root bo to oo id)] + [id r])))) + (keys oo)) + lost (into {} lost-pairs) + + ;; same-parent reorders, on the tree as the target has it + reorder-changes (when (= :merge order-mode) + (page-reorder-changes to oo sbo sto reorders resolutions page-id)) + + ;; `:dropped` `:expand`/`:page-root`: the target's shapes the + ;; deleted container would take with it move out before the delete + expand-moves (if (contains? #{:expand :page-root} dropped-mode) + (expand-relocations to deleted root-id dropped-mode) + {}) + expand-changes (move-changes expand-moves page-id) + + ;; additions: present in the source, absent from the base and the + ;; target, plus the shapes a modify-delete conflict resolved to + ;; `:branch` restores (the target's delete was recursive: the whole + ;; surviving subtree comes back, except the descendants the target + ;; still has — it moved them out before deleting) + additions (into #{} + (filter (fn [id] + (and (contains? oo id) + (not (contains? bo id)) + (not (contains? to id))))) + (keys oo)) + added-set (if (contains? #{:conflict :cascade} lost-mode) + ;; under `:lost :conflict` the region conflict on the + ;; lost root decides an addition's fate; under + ;; `:cascade` the container goes with its whole subtree + (into #{} (remove lost) additions) + additions) + ;; a modify-delete resolved to `:branch` re-adds its whole + ;; surviving subtree (the target's delete was recursive), except + ;; the descendants the target still has — it moved them out before + ;; deleting. Under `:lost :conflict` the region conflict on the + ;; lost root decides instead: resolved to `:branch`, the root's + ;; whole subtree comes back. restore-set (into #{} - (comp (filter (fn [id] - (and (contains? bo id) - (not (contains? to id)) - (not= (get sbo id) (get soo id)) - (= :branch (get resolutions id))))) + (remove #(contains? to %)) + (into #{} (mapcat #(subtree-ids oo %)) - (remove #(contains? to %))) - (keys oo)) + (cond + (= :conflict lost-mode) + (into #{} (comp (filter (fn [[_ r]] (= :branch (get resolutions r)))) + (map second)) + lost-pairs) + (= :cascade lost-mode) + [] + + :else + (keep (fn [id] + (when (and (contains? bo id) + (not (contains? to id)) + (not (snil= (get sbo id) (get soo id))) + (= :branch (get resolutions id))) + id)) + (keys oo))))) all-adds (set/union added-set restore-set) + ;; where each shape is created: its parent, its frame and the index + ;; it takes there (see `placement` for orphans) + placements (into {} (map (fn [id] [id (placement oo to all-adds lost-mode root-id id)])) all-adds) + ;; topological order so a newly-added parent is created before its - ;; newly-added children + ;; newly-added children; within one parent, the source's sibling + ;; order (`:index`), so added siblings keep it ordered (loop [pending (vec all-adds) done #{} out []] (if (empty? pending) out (let [ready (filterv (fn [id] - (let [p (:parent-id (get oo id))] - (or (not (contains? all-adds p)) - (contains? done p)))) + (let [p (:parent (get placements id))] + (or (root-id? p) (contains? to p) (contains? done p)))) pending) ready (if (seq ready) ready (subvec pending 0 1))] (recur (filterv (complement (set ready)) pending) (into done ready) - (into out ready))))) + (into out (sort-by (juxt :depth :index) + (map (fn [id] (assoc (get placements id) :id id)) + ready))))))) add-changes - (mapv (fn [id] - (let [o (get oo id) - parent (:parent-id o) - index (index-of (get-in oo [parent :shapes]) id)] + (mapv (fn [{:keys [id parent frame index]}] + (let [o (get oo id)] {:type :add-obj :page-id page-id :id id @@ -1031,17 +1707,40 @@ ;; appended by their own add-obj (add-shape inserts at index) :obj (cond-> o (contains? o :shapes) (assoc :shapes [])) :parent-id parent - :frame-id (:frame-id o) + :frame-id frame :index index :ignore-touched true})) ordered) ;; reparenting of EXISTING shapes — applied last, after new ;; containers exist and attr/add changes settled - move-changes (page-move-changes to oo sbo sto resolutions page-id)] - (-> mod-del - (into add-changes) - (into move-changes)))) + move-changes (page-move-changes to oo sbo sto resolutions page-id) + + ;; `:refuse`: the merge cannot place these shapes where they + ;; belong, so it refuses instead, naming the container + refused + (concat + (when (= :refuse lost-mode) + (->> (set/union added-set restore-set) + (keep (fn [id] (when-let [r (get lost id)] [r id]))) + (group-by first) + (map (fn [[r pairs]] + {:kind :shape-orphan :status :unsupported :id r + :page-id page-id + :label (entity-label :shape (get bo r)) + :policy :addition-under-deleted-parent + :shapes (mapv second pairs)})))) + (when (= :refuse dropped-mode) + (map (fn [f] + {:kind :shape-orphan :status :unsupported :id f + :page-id page-id + :label (entity-label :shape (get to f)) + :policy :addition-under-deleted-parent + :shapes (into [] (remove #(contains? bo %)) (rest (preorder-ids to f)))}) + dropped-roots)))] + {:changes (into (vec (concat reorder-changes expand-changes mod-del)) + (concat add-changes move-changes)) + :unsupported (into #{} refused)})) (defn compute-changes "Translate the branch→main merge into a vector of raw change maps @@ -1052,8 +1751,9 @@ no conflict remains unresolved before applying). Returns `{:changes [..] :unsupported #{kinds..}}`. When `:unsupported` - is non-empty the caller must refuse the merge (the only kind it cannot - translate is `:page-attrs`, the residual page attrs no pass handles). + is non-empty the caller must refuse the merge: `:page-attrs` (the + residual page attrs no pass handles) is untranslatable, and the shape + pass reports its `:refuse` policy refusals there too. The 5-arity accepts the `compute-merge` summary the caller usually already computed (for the conflict gate), so the full three-way diff is @@ -1108,9 +1808,11 @@ (fn [pid] {:type :del-page :id pid})) (filterv some?)) pmeta (fn [pi] (into {} (map (fn [id] [id (page-meta (get pi id))])) tri-common-pages)) - page-meta-changes (->> (flat-changes (pmeta bpi) (pmeta mpi) (pmeta opi) resolutions + bpm (pmeta bpi) tpm (pmeta mpi) opm (pmeta opi) + page-meta-changes (->> (flat-changes bpm tpm opm resolutions (fn [_ _] nil) - (fn [pid m] (assoc m :type :mod-page :id pid)) + (fn [pid m] (-> (page-meta-clears (get tpm pid) m) + (assoc :type :mod-page :id pid))) (fn [_] nil)) (filterv some?)) @@ -1160,16 +1862,56 @@ (fn [[ns k]] {:type :set-plugin-data :object-type :page :object-id pid :namespace ns :key k :value nil})))) common-pages) - ;; page order: reorder common pages to branch's order via mov-page + ;; page order: reorder the common pages to branch's order via + ;; mov-page. Every :index counts the FULL :pages vector as it is + ;; when the op runs: the presence changes above are already in it + ;; and the moves before it have landed, so a page main added keeps + ;; its slot while the common pages reorder around it. page-order-changes (let [order-of (fn [data] (filterv tri-common-pages (or (:pages data) []))) bo (order-of base) mo (order-of main) oo (order-of branch)] (if (and (not= oo bo) (or (= mo bo) (= (get resolutions :page-order) :branch))) - (vec (map-indexed (fn [i pid] {:type :mov-page :id pid :index i}) oo)) + (let [run-pages (reduce (fn [pages change] + (case (:type change) + :add-page (:pages (ctpl/add-page {:pages pages} (:page change))) + :del-page (:pages (ctpl/delete-page {:pages pages} (:id change))) + pages)) + (vec (or (:pages main) [])) + page-presence) + ;; target: the common pages in branch's order, every + ;; other page where it already is + target (first (reduce (fn [[out order] pid] + (if (and (contains? tri-common-pages pid) (seq order)) + [(conj out (first order)) (rest order)] + [(conj out pid) order])) + [[] oo] + run-pages))] + ;; land the pages left to right: slot i is already the right + ;; index against the vector the op runs on (the prefix before + ;; i is settled and the page comes from below it) + (loop [cur run-pages i 0 out []] + (cond + (>= i (count target)) + out + + (= (nth cur i) (nth target i)) + (recur cur (inc i) out) + + :else + (let [pid (nth target i)] + (recur (d/insert-at-index cur i [pid]) + (inc i) + (conj out {:type :mov-page :id pid :index i})))))) [])) - shapes (into [] (mapcat #(page-shape-changes base main branch resolutions %)) common-pages) + ;; shapes: the tree-shape policies act per page (see + ;; `page-shape-changes`); its `:unsupported` entries name the + ;; container a `:refuse` alternative could not place under + dir (or (:dir merge-summary) :branch->main) + shapes-res (mapv (fn [pid] (page-shape-changes base main branch resolutions pid dir)) + common-pages) + shapes (into [] (mapcat :changes) shapes-res) ;; components: row metadata (shapes handled by the shape/page passes). ;; A branch soft-delete keeps the row with `:deleted true`; surface it @@ -1205,12 +1947,7 @@ common-sets (set/intersection (lib-set-ids bl) (lib-set-ids ml) (lib-set-ids ol)) set-rename-changes (into [] - (comp (filter (fn [sid] - (let [b (set-meta-of bl sid) - m (set-meta-of ml sid) - o (set-meta-of ol sid)] - (and (not= o b) - (or (= m b) (= (get resolutions sid) :branch)))))) + (comp (filter (fn [sid] (set-rename-wins? bl ml ol resolutions sid))) (map (fn [sid] {:type :set-token-set :id sid :attrs (set-rename-attrs ml ol sid)}))) common-sets) @@ -1246,7 +1983,13 @@ oo (set-order-by-id ol common-sets)] (if (and (not= oo bo) (or (= mo bo) (= (get resolutions :token-set-order) :branch))) - (let [names (mapv #(ctob/get-name (ctob/get-set ol %)) oo)] + ;; the moves address the sets by name as the renames above + ;; leave them: branch's name where the rename wins, main's + ;; where main's rename stands + (let [names (mapv (fn [sid] + (ctob/get-name + (ctob/get-set (if (set-rename-wins? bl ml ol resolutions sid) ol ml) sid))) + oo)] (vec (for [i (range (- (count names) 2) -1 -1)] {:type :move-token-set :from-path (set-name->path (nth names i)) @@ -1280,7 +2023,7 @@ (fn [tid t] {:type :set-token-theme :id tid :attrs t}) (fn [tid] {:type :set-token-theme :id tid :attrs nil}))] - {:unsupported unsupported + {:unsupported (into unsupported (map :kind) (mapcat :unsupported shapes-res)) ;; components before shapes so del-component can store the main-instance ;; objects (still on the page) before del-obj removes them :changes (vec (concat page-presence components shapes page-meta-changes diff --git a/common/src/app/common/files/migrations.cljc b/common/src/app/common/files/migrations.cljc index 649f980021..1cddc363d1 100644 --- a/common/src/app/common/files/migrations.cljc +++ b/common/src/app/common/files/migrations.cljc @@ -63,29 +63,96 @@ (def xf:map-name (map :name)) +(defn data-version + "The current data version: the name of the last available migration. + A document holds the set of migrations applied to it and `migrate` + applies the available ones it lacks in list order, so a data version + is a prefix of `available-migrations` and its last name identifies it." + [] + (first (rseq available-migrations))) + +(defn- migration-ordinal + "Sort key of a migration name in `available-migrations`: every + `legacy-N` name precedes every numbered `NNNN-...` name, and each + family sorts by its number. Nil for a name that follows neither + pattern." + [name] + (if-let [[_ n] (re-matches #"legacy-(\d+)" name)] + [0 (d/parse-integer n)] + (when-let [[_ n] (re-find #"^(\d+)" name)] + [1 (d/parse-integer n)]))) + +(defn data-version-migrations + "The migrations that make up data version `version`: the prefix of + `available-migrations` that ends at that name. + + A migration removed from the list (a revert) leaves a recorded + version with no position to cut at. The prefix then ends at the + nearest earlier available name, by the number the name carries; a + name with the same number is not earlier, because it replaces the + removed one. The migrations past the cut apply at the next version + boundary or at the end, as they would on an ordinary file. A removed + name that carries no number yields an empty set." + [version] + (if (contains? available-migrations version) + (reduce (fn [result name] + (let [result (conj result name)] + (if (= name version) + (reduced result) + result))) + (d/ordered-set) + available-migrations) + (if-let [ordinal (migration-ordinal version)] + (into (d/ordered-set) + (take-while #(neg? (compare (migration-ordinal %) ordinal))) + available-migrations) + (d/ordered-set)))) + +(defn need-migration-to? + "True when `file` has not reached data version `version`. A nil + `version` names no version and needs nothing. A file that already + holds the version's last migration has reached it, which costs one + set lookup." + [file version] + (let [migrations (:migrations file)] + (and (some? version) + (not (contains? migrations version)) + (boolean + (->> migrations + (set/difference (data-version-migrations version)) + (not-empty)))))) + (defn migrate - [{:keys [id] :as file} libs] + "Apply to `file` the migrations of `target` (all available ones by + default) it has not applied yet, in list order. The file data schema + describes the current data version only, so the result is checked + against it only when `target` is the whole list." + ([file libs] + (migrate file libs available-migrations)) + ([{:keys [id] :as file} libs target] + (let [diff + (set/difference target (:migrations file)) - (let [diff - (set/difference available-migrations (:migrations file)) + data (-> (:data file) + (assoc :libs libs)) - data (-> (:data file) - (assoc :libs libs)) + data + (reduce migrate-data data diff) - data - (reduce migrate-data data diff) + data + (cond-> (-> data + (assoc :id id) + (dissoc :version) + (dissoc :libs)) + ;; `target` is a prefix of the list, so equal counts mean + ;; the whole list + (= (count target) (count available-migrations)) + (ctf/check-file-data))] - data - (-> data - (assoc :id id) - (dissoc :version) - (dissoc :libs) - (ctf/check-file-data))] - - (-> file - (assoc :data data) - (update :migrations set/union diff) - (vary-meta assoc ::migrated (not-empty diff))))) + (-> file + (assoc :data data) + (update :migrations set/union diff) + (vary-meta assoc ::migrated (not-empty diff)))))) (defn generate-migrations-from-version "A function that generates new format migration from the old, @@ -98,8 +165,8 @@ result (transduce xform conj (d/ordered-set) (range 1 (inc cfd/version)))] result)) -(defn migrate-file - [file libs] +(defn- migrate-file* + [file libs target] (binding [cfeat/*new* (atom #{})] (let [version (or (:version file) (-> file :data :version)) @@ -119,7 +186,7 @@ ;; from this function that executes on each file ;; migration operation (update :features cfeat/migrate-legacy-features) - (migrate libs) + (migrate libs target) (update :features (fnil into #{}) (deref cfeat/*new*)))] ;; NOTE: When we have no previous migrations, we report all @@ -129,6 +196,18 @@ (vary-meta file assoc ::migrated (:migrations file)) file)))) +(defn migrate-file + [file libs] + (migrate-file* file libs available-migrations)) + +(defn migrate-file-to + "Migrate `file` up to data version `version` instead of the current + one. A document replayed from an op log moves through the versions + its ops were written at, the way an ordinary file moves through + them across upgrades." + [file libs version] + (migrate-file* file libs (data-version-migrations version))) + (defn migrated? [file] (boolean (-> file meta ::migrated))) diff --git a/common/test/common_tests/files_branch_merge_test.cljc b/common/test/common_tests/files_branch_merge_test.cljc index 5501031f16..8949139fe8 100644 --- a/common/test/common_tests/files_branch_merge_test.cljc +++ b/common/test/common_tests/files_branch_merge_test.cljc @@ -8,6 +8,9 @@ (:require [app.common.files.branch-merge :as bm] [app.common.files.changes :as cfc] + [app.common.types.page :as ctp] + [app.common.types.shape :as cts] + [app.common.types.shape-tree :as ctst] [app.common.types.tokens-lib :as ctob] [app.common.uuid :as uuid] [clojure.test :as t])) @@ -70,13 +73,17 @@ (t/is (= 0 (-> r :stats :modified))))) (t/deftest shape-with-only-structural-change-hidden - ;; a shape whose ONLY diff is structural/derived (here children reorder) - ;; is not reported as modified in the summary. - (let [base (mkdata {:s1 {:id :s1 :name "A" :shapes [:c1 :c2]}}) - branch (mkdata {:s1 {:id :s1 :name "A" :shapes [:c2 :c1]}}) - r (bm/compute-merge base base branch :branch->main)] - (t/is (= [] (:changes r))) - (t/is (= 0 (-> r :stats :modified))))) + ;; under `:same-parent-reorder :ignore` a shape whose ONLY diff is a + ;; children reorder is not reported, and the merge emits nothing for it + ;; (the reorder is lost; see the `same-parent-reorder-*` tests for the + ;; other alternatives) + (binding [bm/*policies* (assoc bm/default-policies :same-parent-reorder :ignore)] + (let [base (mkdata {:s1 {:id :s1 :name "A" :shapes [:c1 :c2]}}) + branch (mkdata {:s1 {:id :s1 :name "A" :shapes [:c2 :c1]}}) + r (bm/compute-merge base base branch :branch->main)] + (t/is (= [] (:changes r))) + (t/is (= 0 (-> r :stats :modified))) + (t/is (= [] (:changes (bm/compute-changes base base branch))))))) (t/deftest derived-attrs-stripped-containment-kept-and-merged ;; SUMMARY strips only derived/cache attrs (:shapes/:selrect/:points), so @@ -994,3 +1001,456 @@ (t/is (= selrect (get-in c [:branch :selrect]))) (t/is (= "MAIN" (get-in c [:main :name]))) (t/is (= "BRANCH" (get-in c [:branch :name]))))) + +(t/deftest main->branch-conflict-sides-name-the-documents + ;; A conflict descriptor names the DOCUMENTS in both directions: `:main` + ;; is main's value and `:branch` the branch's, the `:changed-attrs` + ;; pairs included. + (let [base (mkdata {:s1 {:id :s1 :name "A" :fill "red"}}) + main (mkdata {:s1 {:id :s1 :name "A" :fill "green"}}) + branch (mkdata {:s1 {:id :s1 :name "A" :fill "blue"}}) + r (bm/compute-merge base main branch :main->branch) + c (first (:conflicts r))] + (t/is (= 1 (-> r :stats :conflicts))) + (t/is (= :modify-modify (:reason c))) + (t/is (= "green" (get-in c [:main :fill]))) + (t/is (= "blue" (get-in c [:branch :fill]))) + (t/is (= {:main "green" :branch "blue"} (get-in c [:changed-attrs :fill]))))) + +(t/deftest delete-reasons-name-the-same-side-in-both-directions + ;; `:delete-modify` names the branch's deletion against main's + ;; modification, `:modify-delete` the branch's modification against + ;; main's deletion — the same meaning in both directions. + (let [base (mkdata {:s1 {:id :s1 :name "A" :fill "red"}}) + main (mkdata {:s1 {:id :s1 :name "A" :fill "green"}}) + branch (mkdata {}) + r (bm/compute-merge base main branch :main->branch) + c (first (:conflicts r))] + (t/is (= 1 (-> r :stats :conflicts))) + (t/is (= :delete-modify (:reason c))) + (t/is (= "green" (get-in c [:main :fill]))) + (t/is (nil? (:branch c)))) + (let [base (mkdata {:s1 {:id :s1 :name "A" :fill "red"}}) + main (mkdata {}) + branch (mkdata {:s1 {:id :s1 :name "A" :fill "blue"}}) + r (bm/compute-merge base main branch :main->branch) + c (first (:conflicts r))] + (t/is (= 1 (-> r :stats :conflicts))) + (t/is (= :modify-delete (:reason c))) + (t/is (nil? (:main c))) + (t/is (= "blue" (get-in c [:branch :fill]))))) + +(t/deftest remap-changes-rewrites-a-del-media-id + ;; the id map carries the two file ids and the media ids (`media-pairs` + ;; plus the fresh ids of the copied rows). Of the change types + ;; `compute-changes` emits with a top-level `:id`, only `:del-media`'s + ;; names a media object, a reference through that map; its `:id` is the + ;; whole payload and `relink-refs` cannot see it. The others name + ;; entities the two files share by id (colour, typography, component, + ;; shape, page), never a media row, so they must come out untouched — + ;; re-pointing one through a media-pair map would corrupt it. + (let [media-old (uuid/next) + media-new (uuid/next) + color-id (uuid/next) + typo-id (uuid/next) + comp-id (uuid/next) + shape-id (uuid/next) + page-id (uuid/next) + changes [{:type :del-media :id media-old} + {:type :add-media :object {:id media-old :media-id media-old + :name "img" :width 1 :height 1 + :mtype "image/png"}} + {:type :mod-media :object {:id media-old :name "renamed"}} + {:type :del-color :id color-id} + {:type :del-typography :id typo-id} + {:type :del-component :id comp-id} + {:type :del-obj :page-id page-id :id shape-id + :ignore-touched true}] + out (bm/remap-changes changes {media-old media-new})] + (t/is (= media-new (:id (nth out 0)))) + (t/is (= media-new (get-in (nth out 1) [:object :id]))) + (t/is (= media-new (get-in (nth out 2) [:object :id]))) + (t/is (= color-id (:id (nth out 3)))) + (t/is (= typo-id (:id (nth out 4)))) + (t/is (= comp-id (:id (nth out 5)))) + (t/is (= shape-id (:id (nth out 6)))))) + +;;; --- Tree-shape policies (`bm/*policies*`) --- + +(defn- add-tree-shape + "Add a real shape (`cts/setup-shape`) under `parent` (nil = page root) + at `index` (nil = on top)." + [page id parent type name index] + (let [parent (or parent uuid/zero) + pobj (get-in page [:objects parent]) + frame-id (if (= :frame (:type pobj)) parent (:frame-id pobj)) + shape (cts/setup-shape {:id id :type type :name name + :x 0 :y 0 :width 10 :height 10})] + (ctst/add-shape id shape page frame-id parent index true))) + +(defn- tree-data + "File data with one page built from `specs`, each `[id parent type + name]`, parents first. The shapes are real, so `cfc/process-changes` + validates the merged tree." + [& specs] + (let [pid (uuid/custom 7 1) + page (reduce (fn [page [id parent type name]] + (add-tree-shape page id parent type name nil)) + (ctp/make-empty-page {:id pid :name "Page 1"}) + specs)] + {:pages [pid] :pages-index {pid page} + :colors {} :typographies {} :components {} :media {}})) + +(defn- tree-page-id [data] (first (:pages data))) +(defn- tree-objects [data] (get-in data [:pages-index (tree-page-id data) :objects])) +(defn- tree-children [data id] (get-in (tree-objects data) [id :shapes])) + +(defn- tree-edit + [data f & args] + (apply update-in data [:pages-index (tree-page-id data) :objects] f args)) + +(defn- tree-add + [data id parent type name & {:keys [index]}] + (update-in data [:pages-index (tree-page-id data)] add-tree-shape id parent type name index)) + +(defn- tree-delete + [data id] + (update-in data [:pages-index (tree-page-id data)] ctst/delete-shape id true)) + +(defn- merged + "Merge `branch` into `main` under `resolutions` and apply the changes + to main through the production change pipeline." + [base main branch resolutions] + (let [{:keys [changes unsupported]} (bm/compute-changes base main branch resolutions)] + {:unsupported unsupported + :changes changes + :data (cfc/process-changes main changes)})) + +(defn- policies + [k v] + (assoc bm/default-policies k v)) + +(t/deftest same-parent-reorder-merge-is-shown-and-applied + ;; ws1: base and main hold [A B] in F and the branch [B A]. Under the + ;; default `:merge` the reorder is a modification of F and lands. + (let [f (uuid/next) a (uuid/next) b (uuid/next) m (uuid/next) + base (tree-data [f nil :frame "F"] [a f :rect "A"] [b f :rect "B"]) + branch (tree-edit base assoc-in [f :shapes] [b a]) + r (bm/compute-merge base base branch :branch->main) + entry (first (:changes r)) + {:keys [data unsupported]} (merged base base branch {})] + (t/is (= 1 (-> r :stats :modified))) + (t/is (= [f] (mapv :id (:changes r)))) + (t/is (= {:main [a b] :branch [b a]} (get-in entry [:changed-attrs :shapes]))) + (t/is (empty? unsupported)) + (t/is (= [b a] (tree-children data f))) + + (t/testing "main adding a child to F is not a conflict and keeps its slot" + (let [main (tree-add base m f :rect "M") + r (bm/compute-merge base main branch :branch->main)] + (t/is (= [] (:conflicts r))) + (t/is (= [b a m] (tree-children (:data (merged base main branch {})) f))))) + + (t/testing "update from main reports and applies main's reorder" + (let [main (tree-edit base assoc-in [f :shapes] [b a]) + r (bm/compute-merge base main base :main->branch)] + (t/is (= {:main [b a] :branch [a b]} + (get-in (first (:changes r)) [:changed-attrs :shapes]))) + (t/is (= [b a] (tree-children (:data (merged base base main {})) f))))))) + +(t/deftest same-parent-reorder-merge-both-sides-conflict + ;; both sides reorder F differently: a conflict on F whose resolution + ;; picks the order + (let [f (uuid/next) a (uuid/next) b (uuid/next) c (uuid/next) + base (tree-data [f nil :frame "F"] [a f :rect "A"] [b f :rect "B"] [c f :rect "C"]) + main (tree-edit base assoc-in [f :shapes] [c a b]) + branch (tree-edit base assoc-in [f :shapes] [b a c]) + {:keys [conflicts]} (bm/compute-merge base main branch :branch->main) + cf (first conflicts)] + (t/is (= [[f :modify-modify]] (mapv (juxt :id :reason) conflicts))) + (t/is (= {:main [c a b] :branch [b a c]} (get-in cf [:changed-attrs :shapes]))) + (t/is (= [b a c] (tree-children (:data (merged base main branch {f :branch})) f))) + (t/is (= [c a b] (tree-children (:data (merged base main branch {f :main})) f))) + (t/is (= [b a c] (tree-children (:data (merged base main branch {f {:shapes :branch}})) f))))) + +(t/deftest same-parent-reorder-refuse + ;; `:refuse`: the reorder is an `:unsupported` entry naming F, so the + ;; merge refuses + (binding [bm/*policies* (policies :same-parent-reorder :refuse)] + (let [f (uuid/next) a (uuid/next) b (uuid/next) + base (tree-data [f nil :frame "F"] [a f :rect "A"] [b f :rect "B"]) + branch (tree-edit base assoc-in [f :shapes] [b a]) + r (bm/compute-merge base base branch :branch->main)] + (t/is (= [{:kind :shape-order :status :unsupported :id f :page-id (tree-page-id base) + :label "F" :policy :same-parent-reorder}] + (:changes r))) + (t/is (= #{:shape-order} (bm/unsupported-kinds (:changes r)))) + (t/is (= #{:shape-order} (:unsupported (bm/compute-changes base base branch {}))))))) + +(t/deftest same-parent-reorder-ignore + ;; `:ignore`: the reorder is invisible and the merge loses it + (binding [bm/*policies* (policies :same-parent-reorder :ignore)] + (let [f (uuid/next) a (uuid/next) b (uuid/next) + base (tree-data [f nil :frame "F"] [a f :rect "A"] [b f :rect "B"]) + branch (tree-edit base assoc-in [f :shapes] [b a]) + r (bm/compute-merge base base branch :branch->main)] + (t/is (= {:added 0 :modified 0 :deleted 0 :conflicts 0} (:stats r))) + (t/is (= [a b] (tree-children (:data (merged base base branch {})) f)))))) + +(t/deftest added-siblings-keep-the-branch-order + ;; ws1: main adds Z at index 0 of F, the branch adds siblings to F. The + ;; merged F holds the branch's siblings in the branch's order. + (let [f (uuid/custom 9 100) + z (uuid/custom 9 200) + ss (mapv #(uuid/custom 9 %) (range 1 9)) + base (tree-data [f nil :frame "F"]) + main (tree-add base z f :rect "Z" :index 0) + branch (reduce (fn [d [i s]] (tree-add d s f :rect (str "S" i))) + base (map-indexed vector ss)) + out (tree-children (:data (merged base main branch {})) f)] + (t/is (= ss (filterv (set ss) out))) + (t/is (= (inc (count ss)) (count out))))) + +(t/deftest addition-under-deleted-parent-conflict + ;; ws1: main deletes frame P, the branch adds M inside P. Default + ;; `:conflict`: a `:modify-delete` conflict on P; `:branch` restores P as + ;; the branch has it, `:main` drops M. + (let [p (uuid/next) c (uuid/next) m (uuid/next) + base (tree-data [p nil :frame "P"] [c p :rect "C"]) + main (tree-delete base p) + branch (tree-add base m p :rect "M") + r (bm/compute-merge base main branch :branch->main) + cf (first (:conflicts r))] + (t/is (= [[p :modify-delete]] (mapv (juxt :id :reason) (:conflicts r)))) + (t/is (= [{:id m :label "M"}] (:subtree-edits cf))) + (t/is (= "P" (get-in cf [:branch :name]))) + (t/is (not-any? #(= m (:id %)) (:changes r))) + (let [objs (tree-objects (:data (merged base main branch {p :branch})))] + (t/is (= [p] (get-in objs [uuid/zero :shapes]))) + (t/is (= [c m] (get-in objs [p :shapes]))) + (t/is (= p (get-in objs [m :parent-id])))) + (let [objs (tree-objects (:data (merged base main branch {p :main})))] + (t/is (= #{uuid/zero} (set (keys objs))))))) + +(t/deftest addition-under-deleted-parent-conflict-lifts-restores + ;; ws1: main deletes frame P, the branch renames its child C. The + ;; conflict sits on P, and `:branch` restores P around C instead of + ;; putting C on the page root. + (let [p (uuid/next) c (uuid/next) + base (tree-data [p nil :frame "P"] [c p :rect "C"]) + main (tree-delete base p) + branch (tree-edit base assoc-in [c :name] "C renamed") + r (bm/compute-merge base main branch :branch->main)] + (t/is (= [[p :modify-delete]] (mapv (juxt :id :reason) (:conflicts r)))) + (t/is (= [{:id c :label "C renamed"}] (:subtree-edits (first (:conflicts r))))) + (let [objs (tree-objects (:data (merged base main branch {p :branch})))] + (t/is (= [p] (get-in objs [uuid/zero :shapes]))) + (t/is (= p (get-in objs [c :parent-id]))) + (t/is (= "C renamed" (get-in objs [c :name])))))) + +(t/deftest addition-under-deleted-parent-refuse + ;; `:refuse`: the addition is an `:unsupported` entry naming P, and so + ;; is a restore that would lose its parent + (binding [bm/*policies* (policies :addition-under-deleted-parent :refuse)] + (let [p (uuid/next) c (uuid/next) m (uuid/next) + base (tree-data [p nil :frame "P"] [c p :rect "C"]) + main (tree-delete base p) + branch (tree-add base m p :rect "M") + r (bm/compute-merge base main branch :branch->main)] + (t/is (= [{:kind :shape-orphan :status :unsupported :id p :page-id (tree-page-id base) + :label "P" :policy :addition-under-deleted-parent :shapes [m]}] + (filterv #(= :unsupported (:status %)) (:changes r)))) + (t/is (= #{:shape-orphan} (:unsupported (bm/compute-changes base main branch {})))) + (let [branch (tree-edit base assoc-in [c :name] "C renamed")] + (t/is (= [[c :modify-delete]] + (mapv (juxt :id :reason) (:conflicts (bm/compute-merge base main branch :branch->main))))) + (t/is (= #{:shape-orphan} (:unsupported (bm/compute-changes base main branch {c :branch})))) + (t/is (empty? (:unsupported (bm/compute-changes base main branch {c :main})))))))) + +(t/deftest addition-under-deleted-parent-reparent-to-ancestor + ;; `:reparent-to-ancestor`: main deletes P inside board G; the branch's + ;; addition M and a restored C land under G, where P was + (binding [bm/*policies* (policies :addition-under-deleted-parent :reparent-to-ancestor)] + (let [g (uuid/next) h (uuid/next) p (uuid/next) c (uuid/next) m (uuid/next) + base (tree-data [g nil :frame "G"] [h g :rect "H"] [p g :frame "P"] [c p :rect "C"]) + main (tree-delete base p) + branch (tree-add base m p :rect "M") + r (bm/compute-merge base main branch :branch->main) + {:keys [data unsupported]} (merged base main branch {}) + objs (tree-objects data)] + (t/is (= [] (:conflicts r))) + (t/is (empty? unsupported)) + (t/is (= [h m] (get-in objs [g :shapes]))) + (t/is (= g (get-in objs [m :parent-id]))) + (t/is (= g (get-in objs [m :frame-id]))) + (let [branch (tree-edit base assoc-in [c :name] "C renamed") + objs (tree-objects (:data (merged base main branch {c :branch})))] + (t/is (= [h c] (get-in objs [g :shapes]))) + (t/is (= g (get-in objs [c :frame-id]))))))) + +(t/deftest addition-under-deleted-parent-page-root + ;; `:page-root`: the addition falls back to the page root + (binding [bm/*policies* (policies :addition-under-deleted-parent :page-root)] + (let [p (uuid/next) c (uuid/next) m (uuid/next) + base (tree-data [p nil :frame "P"] [c p :rect "C"]) + main (tree-delete base p) + branch (tree-add base m p :rect "M") + objs (tree-objects (:data (merged base main branch {})))] + (t/is (= [] (:conflicts (bm/compute-merge base main branch :branch->main)))) + (t/is (= [m] (get-in objs [uuid/zero :shapes]))) + (t/is (= uuid/zero (get-in objs [m :parent-id])))))) + +(defn- container-delete-case + "ws1: the branch deletes frame F, main recolours its child C and adds N + inside it; D is an untouched child of F and K a sibling of F." + [] + (let [f (uuid/next) c (uuid/next) d (uuid/next) n (uuid/next) k (uuid/next) + base (tree-data [k nil :rect "K"] [f nil :frame "F"] [c f :rect "C"] [d f :rect "D"]) + main (-> base + (tree-edit assoc-in [c :fills] [{:fill-color "#FF0000" :fill-opacity 1}]) + (tree-add n f :rect "N")) + branch (tree-delete base f)] + {:f f :c c :d d :n n :k k :base base :main main :branch branch})) + +(t/deftest container-delete-over-main-edits-conflict + ;; default `:conflict`: one `:delete-modify` conflict on F. `:main` keeps + ;; F and its subtree as main has them, `:branch` deletes it all. + (let [{:keys [f c d n k base main branch]} (container-delete-case) + r (bm/compute-merge base main branch :branch->main)] + (t/is (= [[f :delete-modify]] (mapv (juxt :id :reason) (:conflicts r)))) + (t/is (= #{c n} (set (map :id (:subtree-edits (first (:conflicts r))))))) + (t/is (= [] (:changes r))) + (let [objs (tree-objects (:data (merged base main branch {f :main})))] + (t/is (= [k f] (get-in objs [uuid/zero :shapes]))) + (t/is (= [c d n] (get-in objs [f :shapes]))) + (t/is (= "#FF0000" (get-in objs [c :fills 0 :fill-color])))) + (let [objs (tree-objects (:data (merged base main branch {f :branch})))] + (t/is (= #{uuid/zero k} (set (keys objs))))))) + +(t/deftest container-delete-over-main-edits-expand + ;; `:expand`: only what the branch deleted goes; main's addition N, and + ;; C when its conflict is resolved to `:main`, move to F's parent where + ;; F was + (binding [bm/*policies* (policies :container-delete-over-main-edits :expand)] + (let [{:keys [f c d n k base main branch]} (container-delete-case) + r (bm/compute-merge base main branch :branch->main)] + (t/is (= [[c :delete-modify]] (mapv (juxt :id :reason) (:conflicts r)))) + (t/is (= #{f d} (set (map :id (:changes r))))) + (let [objs (tree-objects (:data (merged base main branch {c :main})))] + (t/is (= [k c n] (get-in objs [uuid/zero :shapes]))) + (t/is (= #{uuid/zero k c n} (set (keys objs)))) + (t/is (= uuid/zero (get-in objs [n :frame-id]))) + (t/is (= "#FF0000" (get-in objs [c :fills 0 :fill-color])))) + (let [objs (tree-objects (:data (merged base main branch {c :branch})))] + (t/is (= [k n] (get-in objs [uuid/zero :shapes]))))))) + +(t/deftest container-delete-over-main-edits-cascade + ;; `:cascade`: F goes with its whole subtree, main's edits included + (binding [bm/*policies* (policies :container-delete-over-main-edits :cascade)] + (let [{:keys [f c d k base main branch]} (container-delete-case) + r (bm/compute-merge base main branch :branch->main)] + (t/is (= [[c :delete-modify]] (mapv (juxt :id :reason) (:conflicts r)))) + (t/is (= #{f d} (set (map :id (filter #(= :deleted (:status %)) (:changes r)))))) + (let [objs (tree-objects (:data (merged base main branch {c :main})))] + (t/is (= #{uuid/zero k} (set (keys objs)))))))) + +;;; --- Regression tests: mov-page indexes --- + +(t/deftest compute-changes-page-order-counts-full-pages + ;; `:mov-page :index` counts the FULL :pages vector as it is when the op + ;; runs: a page main added keeps its slot while the common pages reorder + ;; to branch's order around it. Counting the common-pages order instead + ;; pushed such a page out of its slot (to the end). + (let [p1 (uuid/next) p2 (uuid/next) p3 (uuid/next) x (uuid/next) + page (fn [id n] {:id id :name n :objects {}}) + pages3 {p1 (page p1 "P1") p2 (page p2 "P2") p3 (page p3 "P3")} + pages4 (assoc pages3 x (page x "X")) + order (fn [main-pages] + (let [base (pages-data pages3 [p1 p2 p3]) + main (pages-data pages4 main-pages) + branch (pages-data pages3 [p1 p3 p2]) + {:keys [changes]} (bm/compute-changes base main branch)] + (:pages (cfc/process-changes main changes))))] + ;; main's extra page at the end: the reorder comes out right + (t/is (= [p1 p3 p2 x] (order [p1 p2 p3 x]))) + ;; main's extra page interleaved: it keeps its slot + (t/is (= [p1 x p3 p2] (order [p1 x p2 p3]))) + (t/is (= [x p1 p3 p2] (order [x p1 p2 p3]))))) + +;;; --- Regression tests: cleared page meta --- + +(t/deftest compute-changes-page-meta-clear-carries-nil + ;; a branch that renames a page and clears its background must REMOVE the + ;; background: `mod-page` removes only on an explicit nil, so the change + ;; carries it — an absent key would leave main's background in place + (let [pid (uuid/next) + base (pages-data {pid {:id pid :name "P" :objects {} :background "#ff0000"}} [pid]) + branch (assoc-in base [:pages-index pid] {:id pid :name "Renamed" :objects {}}) + {:keys [changes unsupported]} (bm/compute-changes base base branch) + mod (first (filter #(= :mod-page (:type %)) changes)) + data' (cfc/process-changes base changes)] + (t/is (empty? unsupported)) + (t/is (= "Renamed" (:name mod))) + (t/is (contains? mod :background)) + (t/is (nil? (:background mod))) + (t/is (= "Renamed" (get-in data' [:pages-index pid :name]))) + (t/is (not (contains? (get-in data' [:pages-index pid]) :background))))) + +;;; --- Regression tests: per-attr resolution on flat collections --- + +(t/deftest compute-changes-per-attr-removes-missing-attr + ;; main added an :opacity the branch does not carry; resolving that attr + ;; to :branch takes branch's state, where the attr is ABSENT — the shape + ;; `schema:library-color` expresses removal with (closed map: optional + ;; keys, never nil values) + (let [cid (uuid/next) + base (mkdata {} :colors {cid {:id cid :name "A" :color "#ff0000"}}) + main (mkdata {} :colors {cid {:id cid :name "A" :color "#ff0000" :opacity 0.5}}) + branch (mkdata {} :colors {cid {:id cid :name "Brnc" :color "#ff0000"}}) + {:keys [changes]} (bm/compute-changes base main branch {cid {:name :branch :opacity :branch}}) + color (-> (group-by :type changes) :mod-color first :color)] + (t/is (= "Brnc" (:name color))) + (t/is (not (contains? color :opacity))) + ;; round-trip: the applied color carries no :opacity either + (let [data' (cfc/process-changes main changes)] + (t/is (not (contains? (get-in data' [:colors cid]) :opacity)))))) + +;;; --- Regression tests: token-set order vs renames --- + +(t/deftest compute-changes-token-set-order-after-rename + ;; main renamed alpha to ALPHA while the branch reordered to [beta alpha]: + ;; the moves must address the sets by the names they carry AFTER the + ;; emitted renames settle (main's rename stands), else `move-set` finds no + ;; set at the stale name and the reorder silently drops + (let [a (uuid/next) b (uuid/next) + base-lib (-> (ctob/make-tokens-lib) + (ctob/add-set (ctob/make-token-set {:id a :name "alpha"})) + (ctob/add-set (ctob/make-token-set {:id b :name "beta"}))) + main-lib (ctob/update-set base-lib a + (fn [s] (ctob/make-token-set {:id (ctob/get-id s) + :name "ALPHA" + :tokens (ctob/get-tokens base-lib a)}))) + branch-lib (ctob/move-set base-lib ["beta"] ["beta"] ["alpha"] false) + {:keys [changes unsupported]} (bm/compute-changes (with-tokens base-lib) + (with-tokens main-lib) + (with-tokens branch-lib)) + data' (cfc/process-changes {:tokens-lib main-lib} changes)] + (t/is (empty? unsupported)) + (t/is (seq (filter #(= :move-token-set (:type %)) changes))) + ;; the reorder survives main's rename + (t/is (= ["beta" "ALPHA"] (mapv ctob/get-name (ctob/get-sets (:tokens-lib data'))))))) + +;;; --- Regression tests: shape-pass refusals --- + +(t/deftest compute-changes-shape-pass-refusals-surface + ;; a `:refuse` policy reports its refusals from the shape pass; they must + ;; reach the caller's `:unsupported` even when the merge summary handed + ;; to the 5-arity carries none of them — dropping the pass's + ;; `:unsupported` would silently turn a refused merge into a clean one + (binding [bm/*policies* (policies :addition-under-deleted-parent :refuse)] + (let [p (uuid/next) c (uuid/next) m (uuid/next) + base (tree-data [p nil :frame "P"] [c p :rect "C"]) + main (tree-delete base p) + branch (tree-add base m p :rect "M") + {:keys [unsupported]} (bm/compute-changes base main branch {} {:changes [] :conflicts []})] + (t/is (= #{:shape-orphan} unsupported))))) diff --git a/common/test/common_tests/files_migrations_test.cljc b/common/test/common_tests/files_migrations_test.cljc index 7e92deda66..ab7794b5c5 100644 --- a/common/test/common_tests/files_migrations_test.cljc +++ b/common/test/common_tests/files_migrations_test.cljc @@ -28,6 +28,52 @@ (t/is (= cfm/available-migrations (:migrations file'))) (t/is (= 3 (:sum (:data file')))))))) +(t/deftest data-version-migrations-cut-the-list-at-a-version + (let [migrations (into (d/ordered-set) + ["legacy-2" "legacy-10" "0001-a" "0002-b" "0002-c" "0003-d" "0005b-f"])] + (with-redefs [cfm/available-migrations migrations] + (t/is (= "0005b-f" (cfm/data-version))) + + (t/testing "an available name ends the prefix at itself" + (t/is (= ["legacy-2" "legacy-10" "0001-a" "0002-b"] + (vec (cfm/data-version-migrations "0002-b"))))) + + (t/testing "a removed name ends the prefix at the nearest earlier number" + (t/is (= ["legacy-2" "legacy-10" "0001-a" "0002-b" "0002-c" "0003-d"] + (vec (cfm/data-version-migrations "0004-e")))) + (t/is (= ["legacy-2"] + (vec (cfm/data-version-migrations "legacy-5"))))) + + (t/testing "a name with the same number replaces a removed one, so it is not earlier" + (t/is (= ["legacy-2" "legacy-10" "0001-a" "0002-b" "0002-c" "0003-d"] + (vec (cfm/data-version-migrations "0005-f"))))) + + (t/testing "a removed name with no number cuts nothing" + (t/is (empty? (cfm/data-version-migrations "unknown"))))))) + +(t/deftest migrate-file-to-stops-at-a-version + (let [migrations (into (d/ordered-set) ["test/1" "test/2" "test/3"]) + file {:data {:sum 1} + :id 1 + :migrations (d/ordered-set "test/1")}] + ;; the file data schema describes the current version only, so a + ;; document stopped at an older one is not checked against it + (with-redefs [cfm/available-migrations migrations + ctf/check-file-data (fn [_] (throw (ex-info "checked" {})))] + (t/is (cfm/need-migration-to? file "test/2")) + (t/is (not (cfm/need-migration-to? file "test/1"))) + (t/is (not (cfm/need-migration-to? file nil))) + + (let [file' (cfm/migrate-file-to file nil "test/2")] + (t/is (= 2 (-> file' :data :sum))) + (t/is (= #{"test/1" "test/2"} (set (:migrations file')))) + (t/is (not (cfm/need-migration-to? file' "test/2"))) + (t/is (cfm/need-migration-to? file' "test/3")) + + (t/testing "the step that reaches the current version is checked" + (t/is (thrown? #?(:clj Exception :cljs :default) + (cfm/migrate-file-to file' nil "test/3")))))))) + (t/deftest migration-0024b-fix-stroke-cap-placement (let [shape-id (uuid/next) page-id (uuid/next) diff --git a/frontend/src/app/main/data/dashboard.cljs b/frontend/src/app/main/data/dashboard.cljs index b0e47eafea..f1eeba1a5a 100644 --- a/frontend/src/app/main/data/dashboard.cljs +++ b/frontend/src/app/main/data/dashboard.cljs @@ -23,9 +23,11 @@ [app.main.data.helpers :as dsh] [app.main.data.modal :as modal] [app.main.data.notifications :as ntf] + [app.main.data.project :as dpj] [app.main.data.team :as dtm] [app.main.data.websocket :as dws] [app.main.repo :as rp] + [app.main.router :as rt] [app.main.store :as st] [app.util.i18n :as i18n :refer [tr]] [app.util.sse :as sse] @@ -41,6 +43,8 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (declare fetch-projects) +(declare fetch-recent-files) +(declare refetch-placeholder-data) (declare process-message) (defn initialize @@ -63,6 +67,12 @@ (->> stream (rx/filter (ptk/type? ::dws/opened)) (rx/map #(dws/send initmsg))) + (->> stream + (rx/filter (ptk/type? ::dws/opened)) + ;; One refetch of the data the placeholder waits for on + ;; every (re)connection, so a store that never took an + ;; answer during an outage recovers without a reload. + (rx/map (fn [_] (refetch-placeholder-data team-id)))) (->> stream (rx/filter (ptk/type? ::dws/message)) (rx/map deref) @@ -91,11 +101,12 @@ (ptk/reify ::projects-fetched ptk/UpdateEvent (update [_ state] - (reduce (fn [state {:keys [id] :as project}] - ;; Replace completely instead of merge to ensure deleted-at is removed - (assoc-in state [:projects id] project)) - state - projects)))) + (-> (reduce (fn [state {:keys [id] :as project}] + ;; Replace completely instead of merge to ensure deleted-at is removed + (assoc-in state [:projects id] project)) + state + projects) + (update :dashboard-fetch-failures dissoc ::fetch-projects))))) (defn fetch-projects [team-id] @@ -103,7 +114,14 @@ ptk/WatchEvent (watch [_ _ _] (->> (rp/cmd! :get-projects {:team-id team-id}) - (rx/map projects-fetched))))) + (rx/map projects-fetched) + (rx/timeout rp/fetch-timeout-ms + (rx/throw (ex-info "fetch timeout" {:type :timeout}))) + (rx/catch (fn [cause] + ;; Resolve the placeholder into a failure state + ;; instead of leaving it spinning forever. + (rx/of (fn [state] + (assoc-in state [:dashboard-fetch-failures ::fetch-projects] cause))))))))) ;; --- EVENT: search @@ -140,7 +158,8 @@ (let [files (d/index-by :id files)] (-> state (assoc :recent-files files) - (update :files d/merge files)))))) + (update :files d/merge files) + (update :dashboard-fetch-failures dissoc ::fetch-recent-files)))))) (defn fetch-recent-files ([] (fetch-recent-files nil)) @@ -150,7 +169,31 @@ (watch [_ state _] (when-let [team-id (or team-id (:current-team-id state))] (->> (rp/cmd! :get-team-recent-files {:team-id team-id}) - (rx/map recent-files-fetched))))))) + (rx/map recent-files-fetched) + (rx/timeout rp/fetch-timeout-ms + (rx/throw (ex-info "fetch timeout" {:type :timeout}))) + (rx/catch (fn [cause] + ;; Resolve the placeholder into a failure state + ;; instead of leaving it spinning forever. + (rx/of (fn [state] + (assoc-in state [:dashboard-fetch-failures ::fetch-recent-files] cause))))))))))) + +;; --- EVENT: refetch-placeholder-data + +(defn- refetch-placeholder-data + "One refetch of the data the dashboard placeholder waits for: the team + projects and recent files, and the project files when the current + screen shows a project." + [team-id] + (ptk/reify ::refetch-placeholder-data + ptk/WatchEvent + (watch [_ state _] + (let [project-id (some-> (rt/get-params state) :project-id uuid/parse*)] + (rx/concat + (rx/of (fetch-projects team-id) + (fetch-recent-files team-id)) + (when project-id + (rx/of (dpj/fetch-files project-id)))))))) ;; --- EVENT: fetch-template-files diff --git a/frontend/src/app/main/data/project.cljs b/frontend/src/app/main/data/project.cljs index 1d7db839c6..27ae8f15db 100644 --- a/frontend/src/app/main/data/project.cljs +++ b/frontend/src/app/main/data/project.cljs @@ -62,6 +62,7 @@ (update [_ state] (-> state (update :files merge (d/index-by :id files)) + (update :dashboard-fetch-failures dissoc ::fetch-files) (d/update-in-when [:projects project-id] (fn [project] (assoc project :count (count files)))))))) @@ -73,7 +74,14 @@ (watch [_ state _] (when-let [project-id (or project-id (:current-project-id state))] (->> (rp/cmd! :get-project-files {:project-id project-id}) - (rx/map (partial files-fetched project-id)))))))) + (rx/map (partial files-fetched project-id)) + (rx/timeout rp/fetch-timeout-ms + (rx/throw (ex-info "fetch timeout" {:type :timeout}))) + (rx/catch (fn [cause] + ;; Resolve the placeholder into a failure state + ;; instead of leaving it spinning forever. + (rx/of (fn [state] + (assoc-in state [:dashboard-fetch-failures ::fetch-files] cause))))))))))) diff --git a/frontend/src/app/main/data/workspace/branches.cljs b/frontend/src/app/main/data/workspace/branches.cljs index ea18012d93..a67f478221 100644 --- a/frontend/src/app/main/data/workspace/branches.cljs +++ b/frontend/src/app/main/data/workspace/branches.cljs @@ -215,7 +215,8 @@ (rx/catch (fn [cause] (rx/of (refusal-notification cause (tr "workspace.branches.lifecycle.error"))))))))) (defn materialize-branch - "Turn a branch into an ordinary file: `file-id` is the branch's FILE, and + "Turn a branch into an ordinary file: `branch-file-id` is the branch's + FILE (the id `create-file-branch` returns), not the branch row id, and the command persists the branch's derived state as the file's own data payload, drops the op log and clears the branch marker, so every later read and write takes the ordinary route. The content stays; what goes is @@ -223,12 +224,12 @@ merged into it. The branch row is soft-deleted, so refreshing the panel drops the row and refreshing the context drops the banner when the file that left the branch is the open one." - [file-id] - (assert (uuid? file-id) "expected valid uuid for `file-id`") + [branch-file-id] + (assert (uuid? branch-file-id) "expected valid uuid for `branch-file-id`") (ptk/reify ::materialize-branch ptk/WatchEvent (watch [_ _ _] - (->> (rp/cmd! :materialize-file-branch {:file-id file-id}) + (->> (rp/cmd! :materialize-file-branch {:branch-file-id branch-file-id}) (rx/mapcat (fn [_] (rx/of (ntf/success (tr "workspace.branches.materialize.success")) (fetch-branches) (fetch-branch-context)))) diff --git a/frontend/src/app/main/refs.cljs b/frontend/src/app/main/refs.cljs index 11b00fca82..4ccd578d35 100644 --- a/frontend/src/app/main/refs.cljs +++ b/frontend/src/app/main/refs.cljs @@ -59,6 +59,11 @@ ;; dashboard: open pull requests awaiting the current profile's review (l/derived #(get % :dashboard-pending-reviews) st/state)) +(def fetch-failures + ;; dashboard: fetches that timed out or failed, keyed by fetch event; + ;; non-empty while the placeholder waits for data it will not get + (l/derived #(get % :dashboard-fetch-failures) st/state)) + (def team (l/derived dsh/lookup-team st/state)) diff --git a/frontend/src/app/main/repo.cljs b/frontend/src/app/main/repo.cljs index 01ce9e4c01..0d8daf5b24 100644 --- a/frontend/src/app/main/repo.cljs +++ b/frontend/src/app/main/repo.cljs @@ -46,6 +46,13 @@ {:max-retries 3 :base-delay-ms 1000}) +(def fetch-timeout-ms + "Milliseconds a fetch may stay unanswered before callers resolve it + into a failure state. Conservative: an idempotent request retried + under `default-retry-config` legitimately waits up to 15s in back-off + alone, so the bound leaves room for the whole retry budget." + 30000) + (defn with-retry "Wrap `observable-fn` (a zero-arg function returning an Observable) so that retryable errors are retried up to `:max-retries` times with diff --git a/frontend/src/app/main/ui/dashboard.cljs b/frontend/src/app/main/ui/dashboard.cljs index c83a33e97d..952714bec8 100644 --- a/frontend/src/app/main/ui/dashboard.cljs +++ b/frontend/src/app/main/ui/dashboard.cljs @@ -29,6 +29,7 @@ [app.main.ui.dashboard.import] [app.main.ui.dashboard.layout-toggle :as lt] [app.main.ui.dashboard.libraries :refer [libraries-page*]] + [app.main.ui.dashboard.placeholder :refer [loading-placeholder*]] [app.main.ui.dashboard.projects :refer [projects-section*]] [app.main.ui.dashboard.search :refer [search-page*]] [app.main.ui.dashboard.sidebar :refer [sidebar*]] @@ -61,6 +62,8 @@ permissions (:permissions team) + failed? (boolean (seq (mf/deref refs/fetch-failures))) + default-project-id (get default-project :id) @@ -99,7 +102,7 @@ (case section :dashboard-recent - (when (seq projects) + (if (seq projects) [:* [:> projects-section* {:team team :projects projects @@ -112,7 +115,10 @@ :project-id project-id :team-id team-id :default-project-id default-project-id - :content-width @content-width}])]) + :content-width @content-width}])] + ;; A failed fetch must stay visible instead of a blank section. + (when ^boolean failed? + [:> loading-placeholder*])) :dashboard-fonts [:> fonts-page* {:team team}] @@ -121,7 +127,7 @@ [:> font-providers-page* {:team team}] :dashboard-files - (when project + (if project [:* [:> files-section* {:team team :project project @@ -132,7 +138,10 @@ :team-id team-id :project-id project-id :default-project-id default-project-id - :content-width @content-width}])]) + :content-width @content-width}])] + ;; A failed fetch must stay visible instead of a blank section. + (when ^boolean failed? + [:> loading-placeholder*])) :dashboard-search [:> search-page* {:team team diff --git a/frontend/src/app/main/ui/dashboard/branches_popover.cljs b/frontend/src/app/main/ui/dashboard/branches_popover.cljs index a670742305..7c617776ab 100644 --- a/frontend/src/app/main/ui/dashboard/branches_popover.cljs +++ b/frontend/src/app/main/ui/dashboard/branches_popover.cljs @@ -1,5 +1,5 @@ ;; 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 +;; 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 @@ -78,7 +78,13 @@ :on-click on-open-branch} [:> i/icon* {:icon-id i/git-branch :size "s"}] [:span {:class (stl/css :branches-popover-name)} (:name b)] - [:span {:class (stl/css :branches-popover-counts)} - (dm/str "↑" (:ahead b) " ↓" (:behind b))]])] + (if (or (:diff-error b) (nil? (:ahead b))) + ;; the comparison could not be made: the warning stands + ;; where the counts would, because zeros read as "in sync" + [:span {:class (stl/css :branches-popover-error) + :title (tr "workspace.branches.counts.error")} + [:> i/icon* {:icon-id i/triangle-alert :size "s"}]] + [:span {:class (stl/css :branches-popover-counts)} + (dm/str "↑" (:ahead b) " ↓" (:behind b))])])] [:> button* {:variant "primary" :icon i/add :on-click on-create} (tr "workspace.branches.new")]]]])) diff --git a/frontend/src/app/main/ui/dashboard/branches_popover.scss b/frontend/src/app/main/ui/dashboard/branches_popover.scss index 6ef7982584..38de424df9 100644 --- a/frontend/src/app/main/ui/dashboard/branches_popover.scss +++ b/frontend/src/app/main/ui/dashboard/branches_popover.scss @@ -84,3 +84,9 @@ color: var(--color-foreground-secondary); } + +.branches-popover-error { + display: inline-flex; + align-items: center; + color: var(--color-foreground-warning); +} diff --git a/frontend/src/app/main/ui/dashboard/files.cljs b/frontend/src/app/main/ui/dashboard/files.cljs index b3318fc6f8..fb3584d365 100644 --- a/frontend/src/app/main/ui/dashboard/files.cljs +++ b/frontend/src/app/main/ui/dashboard/files.cljs @@ -179,9 +179,12 @@ loading? (and (some? (:count project)) (not= (:count project) file-count)) + failed? (boolean (seq (mf/deref refs/fetch-failures))) + empty-state-viewer (and (not can-edit?) (= 0 file-count) - (not loading?)) + (not loading?) + (not failed?)) selected-files (mf/deref refs/selected-files) @@ -233,7 +236,7 @@ (tr "dashboard.empty-placeholder-drafts-subtitle") (tr "dashboard.empty-placeholder-files-subtitle"))}] [:> grid* {:project project - :files (if loading? nil files) + :files (if (or loading? (and failed? (empty? files))) nil files) :selected-files selected-files :can-edit can-edit? :origin :files diff --git a/frontend/src/app/main/ui/dashboard/placeholder.cljs b/frontend/src/app/main/ui/dashboard/placeholder.cljs index 100f1ed4f3..cfd7dad317 100644 --- a/frontend/src/app/main/ui/dashboard/placeholder.cljs +++ b/frontend/src/app/main/ui/dashboard/placeholder.cljs @@ -8,8 +8,10 @@ (:require-macros [app.main.style :as stl]) (:require [app.main.data.event :as ev] + [app.main.refs :as refs] [app.main.store :as st] [app.main.ui.dashboard.import :as udi] + [app.main.ui.ds.notifications.context-notification :refer [context-notification*]] [app.main.ui.ds.product.empty-placeholder :refer [empty-placeholder*]] [app.main.ui.ds.product.loader :refer [loader*]] [app.main.ui.icons :as deprecated-icon] @@ -135,8 +137,14 @@ (mf/defc loading-placeholder* [] - [:> loader* {:width 32 - :title (tr "labels.loading") - :class (stl/css :placeholder-loader)} - [:span {:class (stl/css :placeholder-text)} - (tr "dashboard.loading-files")]]) + (let [failures (mf/deref refs/fetch-failures)] + (if (seq failures) + ;; A fetch that timed out or failed resolves the placeholder into + ;; a failure state instead of spinning forever. + [:> context-notification* {:level :error} + (tr "errors.unexpected-error")] + [:> loader* {:width 32 + :title (tr "labels.loading") + :class (stl/css :placeholder-loader)} + [:span {:class (stl/css :placeholder-text)} + (tr "dashboard.loading-files")]]))) diff --git a/frontend/src/app/main/ui/dashboard/projects.cljs b/frontend/src/app/main/ui/dashboard/projects.cljs index fef26f5b9b..db709c1f26 100644 --- a/frontend/src/app/main/ui/dashboard/projects.cljs +++ b/frontend/src/app/main/ui/dashboard/projects.cljs @@ -108,9 +108,12 @@ loading? (and (pos? (:count project)) (empty? files)) + failed? (boolean (seq (mf/deref refs/fetch-failures))) + is-draft? (:is-default project) empty? (and (not can-edit) - (= 0 file-count)) + (= 0 file-count) + (not failed?)) dstate (mf/deref refs/dashboard-local) edit-id (:project-for-edit dstate) @@ -311,7 +314,7 @@ [:> line-grid* {:project project :team team - :files (if loading? nil files) + :files (if (or loading? (and failed? (empty? files))) nil files) :create-fn create-file :can-edit can-edit :limit limit diff --git a/frontend/src/app/main/ui/workspace/sidebar/branches.cljs b/frontend/src/app/main/ui/workspace/sidebar/branches.cljs index 380417e518..48ba65b26b 100644 --- a/frontend/src/app/main/ui/workspace/sidebar/branches.cljs +++ b/frontend/src/app/main/ui/workspace/sidebar/branches.cljs @@ -484,6 +484,18 @@ :accept-style :primary :on-accept (fn [_] (st/emit! (dwb/update-branch-from-main branch)))}))) +;; --- Diff counts: known, or honestly unknown +;; +;; A row whose comparison could not be made carries no counts at all (and +;; the `:diff-error` marker), because zeros read as "in sync" and a +;; branch that cannot be compared is not in sync. Every surface showing +;; the counts shows the comparison warning in their place. + +(defn- counts-error? + [row] + (or (:diff-error row) + (nil? (:ahead row)))) + ;; --- Branch info dialog (read-only info card + editable description) (mf/defc branch-info-dialog* @@ -589,15 +601,20 @@ [:div {:class (stl/css :info-row)} [:dt {:class (stl/css :info-key)} (tr "workspace.branches.info.changes")] [:dd {:class (stl/css :info-val :info-counts)} - [:span {:class (stl/css :count-ahead) - :title (tr "workspace.branches.counts.ahead")} - [:> i/icon* {:icon-id i/arrow-up :size "s"}] (dm/str (:ahead branch 0))] - [:span {:class (stl/css :count-behind) - :title (tr "workspace.branches.counts.behind")} - [:> i/icon* {:icon-id i/arrow-down :size "s"}] (dm/str (:behind branch 0))] - (when (pos? (:conflicts branch 0)) - [:span {:class (stl/css :item-badge :badge-conflict)} - (tr "workspace.branches.banner.conflicts" (dm/str (:conflicts branch)))])]]) + (if (counts-error? branch) + [:span {:class (stl/css :count-error) + :title (tr "workspace.branches.counts.error")} + [:> i/icon* {:icon-id i/triangle-alert :size "s"}]] + [:* + [:span {:class (stl/css :count-ahead) + :title (tr "workspace.branches.counts.ahead")} + [:> i/icon* {:icon-id i/arrow-up :size "s"}] (dm/str (:ahead branch 0))] + [:span {:class (stl/css :count-behind) + :title (tr "workspace.branches.counts.behind")} + [:> i/icon* {:icon-id i/arrow-down :size "s"}] (dm/str (:behind branch 0))] + (when (pos? (:conflicts branch 0)) + [:span {:class (stl/css :item-badge :badge-conflict)} + (tr "workspace.branches.banner.conflicts" (dm/str (:conflicts branch)))])])]]) (when (:merged-at branch) [:div {:class (stl/css :info-row)} @@ -820,14 +837,19 @@ [:div {:class (stl/css :branch-entry-aside)} (when (and (not archived?) (not main?)) [:div {:class (stl/css :branch-entry-counts)} - [:span {:class (stl/css :count-ahead) - :title (tr "workspace.branches.counts.ahead")} - [:> i/icon* {:icon-id i/arrow-up :size "s"}] - (dm/str ahead)] - [:span {:class (stl/css :count-behind) - :title (tr "workspace.branches.counts.behind")} - [:> i/icon* {:icon-id i/arrow-down :size "s"}] - (dm/str behind)]]) + (if (counts-error? entry) + [:span {:class (stl/css :count-error) + :title (tr "workspace.branches.counts.error")} + [:> i/icon* {:icon-id i/triangle-alert :size "s"}]] + [:* + [:span {:class (stl/css :count-ahead) + :title (tr "workspace.branches.counts.ahead")} + [:> i/icon* {:icon-id i/arrow-up :size "s"}] + (dm/str ahead)] + [:span {:class (stl/css :count-behind) + :title (tr "workspace.branches.counts.behind")} + [:> i/icon* {:icon-id i/arrow-down :size "s"}] + (dm/str behind)]])]) (when-not main? [:> icon-button* {:variant "ghost" @@ -843,7 +865,7 @@ (when-not archived? [:> dropdown-menu-item* {:class (stl/css :menu-option) :on-click on-compare} (tr "workspace.branches.compare")]) - (when (and (not archived?) (pos? behind)) + (when (and (not archived?) (pos? (or behind 0))) [:> dropdown-menu-item* {:class (stl/css :menu-option) :on-click on-update} (tr "workspace.branches.update")]) ;; review lifecycle: a branch without an open pull request offers to @@ -1515,25 +1537,6 @@ (map? res) (get res attr) :else nil)) -(defn- document-sides - "Re-key one conflict from a `:main->branch` payload's role names to the two - documents the resolution modal names, where `:main` holds the branch and - `:branch` holds main (`branch-merge.cljc::compute-merge*` feeds the branch - as `theirs` and main as `ours` in that direction, and - `branch-merge.cljc::three-way-entities` writes `:main` for `theirs`). The - base side, the id, the reason and the label read the same in both - directions, as do the resolution keywords the commands take, so only the - two sides and the values inside `:changed-attrs` move." - [conflict] - (let [swap (fn [sides] {:main (:branch sides) :branch (:main sides)})] - (cond-> (assoc conflict - :main (:branch conflict) - :branch (:main conflict)) - (map? (:changed-attrs conflict)) - (assoc :changed-attrs (into {} - (map (fn [[attr sides]] [attr (swap sides)])) - (:changed-attrs conflict)))))) - (mf/defc conflict-preview-row* "The BASE · MAIN · BRANCH · RESULT preview strip on top of the detail panel. RESULT updates live as per-property choices change." @@ -1603,18 +1606,10 @@ ;; enable (vcs:tp-update-conflict-frame). Prefer what the command said. conflicts (if (seq conflicts) conflicts (:conflicts diff)) - ;; In update mode the payload's two sides arrive role-keyed rather than - ;; document-keyed: `branch-merge.cljc::compute-merge*` runs the - ;; `:main->branch` direction with the branch as `theirs` and main as - ;; `ours`, and `branch-merge.cljc::three-way-entities` names those - ;; `:main` and `:branch`. Every heading, chip and button below names - ;; the two documents, so an update hands the branch where the modal - ;; says main. Re-key the payload once, here: the mode-dependent - ;; mapping lives in this one binding. Resolutions stay in document - ;; terms, which is what both commands expect of them. - conflicts (if (= mode :update) - (mapv document-sides conflicts) - conflicts) + ;; the payload's two sides are document-keyed in both directions: + ;; `:main` holds main's value and `:branch` the branch's + ;; (`branch-merge.cljc::compute-merge`), which is what every heading, + ;; chip and button below names. Resolutions use the same vocabulary. resolutions (or resolutions {}) total (count conflicts) resolved (count (filterv #(bm/conflict-resolved? % (get resolutions (:id %))) conflicts)) @@ -1929,12 +1924,17 @@ (let [conflicts (or (:conflicts ctx) 0)] [:div {:class (stl/css :branch-banner-actions)} [:span {:class (stl/css :branch-banner-counts)} - [:span {:class (stl/css :count-ahead) - :title (tr "workspace.branches.counts.ahead")} - [:> i/icon* {:icon-id i/arrow-up :size "s"}] (dm/str (:ahead ctx))] - [:span {:class (stl/css :count-behind) - :title (tr "workspace.branches.counts.behind")} - [:> i/icon* {:icon-id i/arrow-down :size "s"}] (dm/str (:behind ctx))]] + (if (counts-error? ctx) + [:span {:class (stl/css :count-error) + :title (tr "workspace.branches.counts.error")} + [:> i/icon* {:icon-id i/triangle-alert :size "s"}]] + [:* + [:span {:class (stl/css :count-ahead) + :title (tr "workspace.branches.counts.ahead")} + [:> i/icon* {:icon-id i/arrow-up :size "s"}] (dm/str (:ahead ctx))] + [:span {:class (stl/css :count-behind) + :title (tr "workspace.branches.counts.behind")} + [:> i/icon* {:icon-id i/arrow-down :size "s"}] (dm/str (:behind ctx))]])] (when (pos? conflicts) [:span {:class (stl/css :item-badge :badge-conflict)} @@ -1952,7 +1952,7 @@ :on-click on-resolve} (tr "workspace.branches.conflicts.resolve")] - (pos? (:behind ctx)) + (pos? (or (:behind ctx) 0)) [:> button* {:variant "primary" :icon i/status-update :on-click on-update} @@ -1966,13 +1966,13 @@ :on-click on-open-review} (tr "workspace.pull-requests.actions.open-review")] - (and prs-enabled? (pos? (:ahead ctx))) + (and prs-enabled? (pos? (or (:ahead ctx) 0))) [:> button* {:variant "primary" :icon i/git-pull-request-arrow :on-click on-request-review} (tr "workspace.pull-requests.menu.request-review")] - (pos? (:ahead ctx)) + (pos? (or (:ahead ctx) 0)) [:> button* {:variant "primary" :icon i/git-merge :on-click on-merge} diff --git a/frontend/src/app/main/ui/workspace/sidebar/branches.scss b/frontend/src/app/main/ui/workspace/sidebar/branches.scss index 95b0c55883..26635e1bdd 100644 --- a/frontend/src/app/main/ui/workspace/sidebar/branches.scss +++ b/frontend/src/app/main/ui/workspace/sidebar/branches.scss @@ -204,6 +204,12 @@ color: var(--color-accent-primary); } +.count-error { + display: inline-flex; + align-items: center; + color: var(--color-foreground-warning); +} + // --- Create branch dialog .modal-overlay { diff --git a/frontend/test/frontend_tests/data/dashboard_test.cljs b/frontend/test/frontend_tests/data/dashboard_test.cljs index 12fefdb476..00eaa7612c 100644 --- a/frontend/test/frontend_tests/data/dashboard_test.cljs +++ b/frontend/test/frontend_tests/data/dashboard_test.cljs @@ -10,6 +10,7 @@ [app.config :as cf] [app.main.data.common :as dcm] [app.main.data.dashboard :as dd] + [app.main.data.project :as dpj] [app.main.data.websocket :as dws] [app.main.repo :as rp] [app.main.router :as rt] @@ -130,3 +131,80 @@ (await (async/observe (ptk/watch (dd/initialize team-id) state stream) :on-next #(swap! processed conj (ptk/type %)))))) (t/is (= 1 (count (filter #{::dcm/handle-organization-change-sso} @processed)))))) + +(t/deftest never-answering-recent-files-fetch-resolves-placeholder-to-failure + (t/async done + (let [team-id (uuid/next) + state {:current-team-id team-id}] + (mock/with-mocks + {rp/fetch-timeout-ms 50 + rp/cmd! (mock/stub (fn [_ _] (rx/subject)))} + (fn [done'] + (->> (ptk/watch (dd/fetch-recent-files team-id) state nil) + (rx/reduce (fn [state event] (ptk/update event state)) state) + ;; The guard fails the test instead of spinning when no + ;; failure state arrives within the bound. + (rx/timeout 1000 (rx/throw (ex-info "no failure state within the bound" {}))) + (rx/subs! + (fn [state] + (t/is (contains? (:dashboard-fetch-failures state) ::dd/fetch-recent-files) + "the placeholder resolves into a failure state")) + (fn [cause] + (t/is false (str "unexpected error: " cause)) + (done')) + (fn [] + (done'))))) + done)))) + +(t/deftest never-answering-project-files-fetch-resolves-placeholder-to-failure + (t/async done + (let [project-id (uuid/next) + state {}] + (mock/with-mocks + {rp/fetch-timeout-ms 50 + rp/cmd! (mock/stub (fn [_ _] (rx/subject)))} + (fn [done'] + (->> (ptk/watch (dpj/fetch-files project-id) state nil) + (rx/reduce (fn [state event] (ptk/update event state)) state) + (rx/timeout 1000 (rx/throw (ex-info "no failure state within the bound" {}))) + (rx/subs! + (fn [state] + (t/is (contains? (:dashboard-fetch-failures state) ::dpj/fetch-files) + "the placeholder resolves into a failure state")) + (fn [cause] + (t/is false (str "unexpected error: " cause)) + (done')) + (fn [] + (done'))))) + done)))) + +(t/deftest websocket-reconnect-refetches-placeholder-data + (t/async done + (let [team-id (uuid/next) + project-id (uuid/next) + calls (atom []) + state {:current-team-id team-id + :route {:params {:query {:project-id (str project-id)}}}} + store (ptk/store {:state state + :on-error (fn [cause] (t/is false (str cause)))})] + (mock/with-mocks + {rp/cmd! (mock/stub (fn [cmd params] + (swap! calls conj [cmd params]) + (rx/of nil)))} + (fn [done'] + (ptk/emit! store (dd/initialize team-id)) + (ptk/emit! store (ptk/data-event ::dws/opened {})) + (t/is (= 2 (count (filter #(= :get-projects (first %)) @calls))) + "the reconnect refetches the team projects exactly once") + (t/is (= 1 (count (filter #(= :get-team-recent-files (first %)) @calls))) + "the reconnect refetches the recent files exactly once") + (t/is (= 1 (count (filter #(= :get-project-files (first %)) @calls))) + "the reconnect refetches the project files exactly once") + (t/is (= [{:project-id project-id}] + (into [] (comp (filter #(= :get-project-files (first %))) + (map second)) + @calls)) + "the refetched project files are the ones the placeholder waits for") + (rx/dispose! store) + (done')) + done)))) diff --git a/frontend/translations/en.po b/frontend/translations/en.po index 0c18c75bc0..f1caa5deae 100644 --- a/frontend/translations/en.po +++ b/frontend/translations/en.po @@ -6696,6 +6696,10 @@ msgstr "" "(shapes, pages, components, colours, typographies, media, and tokens), not " "saves." +#: src/app/main/ui/workspace/sidebar/branches.cljs:606, src/app/main/ui/workspace/sidebar/branches.cljs:842, src/app/main/ui/workspace/sidebar/branches.cljs:1956, src/app/main/ui/dashboard/branches_popover.cljs:85 +msgid "workspace.branches.counts.error" +msgstr "Couldn't compare this branch with main" + #: src/app/main/ui/workspace/sidebar/branches.cljs:299 msgid "workspace.branches.create.derive-from" msgstr "Derive from"