github/penpot
1
0
Fork 0
mirror of https://github.com/penpot/penpot.git synced 2026-10-29 05:50:35 +00:00
Code Issues Packages Projects Releases Wiki Activity

Merge branch 'issue-12410' into iop-vc-preview

Browse Source 
Brings in the fragmented file data stabilization across snapshots and
GC (penpot#12410) and the per-library pointer loader fix. Four files
conflicted.

file_gc.clj `process-file!` keeps the branch's `:is-branch` skip and
its warning; ordinary files run the new body under `with-pointers`
(snapshot liveness, reattach of unchanged fragments, fragment
cleaning).

files_snapshot.clj `restore-file-snapshot` takes the new backup
transaction, which reads the file FOR SHARE and gives the guard revn.
`fsnap/check-restorable!` now runs on that read, before the backup
snapshot is created, so a branch file is still refused without a
committed backup.

binfile_test.clj and rpc_file_snapshot_test.clj keep the tests both
sides appended.

AI-assisted-by: claude-opus-5-5
Signed-off-by: Álvaro Tejero Cantero <alvorithm@teje.ro>
This commit is contained in:
Álvaro Tejero Cantero 2026-10-28 06:34:39 +01:00
commit 607920fad3
No known key found for this signature in database
23 changed files with 1916 additions and 199 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
.serena/memories/backend/subtleties.md
View File

@ -91,7 +91,13 @@
- File data backends are `legacy-db`, `db`, and `storage`. The storage backend keeps encoded file data in storage bucket `file-data`; the DB row stores metadata with `storage-ref-id` and nil data.
- `fdata/upsert!` touches any storage object referenced by incoming metadata before storing the new row/blob.
- Pointer-map fragments are persisted separately as type `fragment`, and only modified pointer maps are written.
- Pointer-map fragments are persisted separately as type `fragment`, and only modified pointer maps are written. A pointer keeps its id while nothing changes; content (`assoc`/`without`) and metadata (`with-meta`) changes produce a fresh id, so a fragment row is never rewritten after it is written. Re-assoc with an identical value returns the same map in array and hash maps alike, so a save keeps the fragment id of every page it does not change.
- `enable-objects-map` skips unloaded pointer pages: their fragment was already wrapped when it was written, and loading it only to wrap it again costs one page read per untouched page on every save. A page with a plain fragment is wrapped when it is first loaded or edited; a data migration that enables `fdata/objects-map` must rewrite the data itself.
- Snapshots share fragment rows with the live file (they are stored with pointers, not materialized). `file-gc` marks every fragment referenced neither by the current main file nor by an unpurged snapshot; the file is read unrealized and unchanged pages keep their ids via reattach, so a pass over an unchanged file writes no new fragments.
- A save attaches its automatic snapshot before applying pending file migrations: the snapshot keeps the pre-migration pointers and migration set, and restoring it leaves the next read to migrate the file.
- The migration read path (`binfile.common/migrate-file`) captures `fdata/original-pointers` before realizing, reattaches unchanged positions after applying the migrations, and persists the reattached file; it returns the realized file because reads expose plain data. A migration that adds `fdata/objects-map` skips the reattach so the pages get wrapped.
- `fdata/load-pointer` reads rows that a previous `file-gc` pass marked on purpose (explicit `::db/remove-deleted false`): the fragment is only gone once `objects-gc` purges it. The `get-file-fragment` RPC keeps rejecting marked rows.
- Bind the fragment loader through `fdata/with-pointers` (reads), `fdata/with-tracked-pointers` (writes with a loader) or `fdata/with-tracked` (writes with nothing to load yet, e.g. file creation), and `fdata/with-untracked` (validation passes that must track nothing) instead of hand-rolled `binding` forms; `file-snapshots/reduce-snapshots` already binds its loader while walking snapshot content.
- `fdata/realize` combines pointer realization and object-map realization. Use it before operations that need complete in-memory file data instead of pointer placeholders.
- A `file_data` row is one of three classes, told apart by `type`: `main` is the file's current state and carries `id = file_id`; `snapshot` is a point-in-time copy whose `id` is the one its `file_change` row shares; `fragment` is a piece of the pointer-map, referenced from the file's data.
- Their lifecycles differ: `main` and `snapshot` live with the file (dated when it is deleted, undated when it is restored), while a `fragment` carries no date and is collected by `file_gc` once the file stops referencing it. Neither is a session buffer, so do not read a `fragment` as an ephemeral revision.

45
backend/src/app/binfile/common.clj
View File

@ -241,24 +241,30 @@
(defn- migrate-file
[{:keys [::db/conn] :as cfg} {:keys [read-only?]} {:keys [id] :as file}]
(binding [pmap/*load-fn* (partial fdata/load-pointer cfg id)
pmap/*tracked* (pmap/create-tracked)]
(let [libs (delay (get-resolved-file-libraries cfg file))
;; For avoid unnecesary overhead of creating multiple
;; pointers and handly internally with objects map in their
;; worst case (when probably all shapes and all pointers
;; will be readed in any case), we just realize/resolve them
;; before applying the migration to the file.
file (-> (fdata/realize cfg file)
(fmg/migrate-file libs))]
(fdata/with-tracked-pointers cfg id
(let [libs (delay (get-resolved-file-libraries cfg file))
;; Capture the pointer layout before realizing: the migration
;; runs on plain data, and unchanged positions must keep their
;; original fragment ids instead of being re-wrapped with new
;; ones on persist.
original (fdata/original-pointers (:data file))
objects-map-before? (contains? (:features file) "fdata/objects-map")
realized (-> (fdata/realize cfg file)
(fmg/migrate-file libs))
objects-map-added? (and (not objects-map-before?)
(contains? (:features realized) "fdata/objects-map"))]
(if (or read-only? (db/read-only? conn))
file
(do ;; When file is migrated, we break the rule of no
;; perform mutations on get operations and update the
;; file with all migrations applied
realized
(let [file (if objects-map-added?
realized
(fdata/reattach-unchanged original realized))]
;; When the file is migrated, we break the rule of not
;; performing mutations on get operations and update the file
;; with all migrations applied. The caller still receives the
;; realized file: the read contract is plain data.
(update-file! cfg file)
(fmigr/resolve-applied-migrations cfg file))))))
(fmigr/resolve-applied-migrations cfg realized))))))
;; --- Branch files: derived data --------------------------------------
;;
@ -544,7 +550,7 @@
(assert (db/connection? conn) "expected cfg with valid connection")
(when (and (not load-data?)
(or lock-for-share? lock-for-share? skip-locked?))
(or lock-for-share? lock-for-update? skip-locked?))
(throw (IllegalArgumentException. "locking is incompatible when `load-data?` is false")))
(let [sql
@ -1268,7 +1274,12 @@
(let [library-ids (->> (get-file-libraries conn (:id file))
(map :id)
(cons (:id file)))
load-fn #(get-file cfg % :migrate? false)]
;; Fragment rows are file-local and callers bind the loader of
;; the file they work on, so each library realizes its pointers
;; here, with its own id, before anything walks its data.
load-fn (fn [library-id]
(->> (get-file cfg library-id :migrate? false)
(fdata/realize-pointers cfg)))]
(weak/loadable-weak-value-map library-ids load-fn {id file})))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

116
backend/src/app/features/fdata.clj
View File

@ -51,10 +51,19 @@
(update file :data process-objects (partial into {})))
(defn enable-objects-map
"Ensure every page holds an ObjectsMap. Unloaded pointers are left
untouched: the fragment they point to was written by an `encode-file`
that already wrapped its objects, and loading it only to wrap it again
costs one page read per untouched page on every save. A page whose
fragment predates the feature is wrapped when it is first loaded or
edited; a data migration that enables the feature must rewrite the
data itself."
[file & _opts]
(let [update-page
(fn [page]
(update page :objects omap/wrap))
(if (and (pmap/pointer-map? page) (not (pmap/loaded? page)))
page
(update page :objects omap/wrap)))
update-data
(fn [fdata]
@ -264,9 +273,13 @@
(defn load-pointer
"A database loader pointer helper"
[cfg file-id id]
;; Keep the include-marked behavior explicit: `db/get*` only filters
;; rows by `deleted_at` when that column is selected, and a fragment a
;; previous pass marked must still load until `objects-gc` purges it.
(let [fragment (some-> (db/get* cfg :file-data
{:id id :file-id file-id :type "fragment"}
{::sql/columns [:data :backend :id :metadata]})
{::sql/columns [:data :backend :id :metadata]
::db/remove-deleted false})
(update :metadata decode-metadata))]
(l/trc :hint "load pointer"
@ -297,6 +310,40 @@
:type "fragment"
:data content})))))
(defmacro with-pointers
"Bind the fragment loader for `file-id` around `body`. All pointer
derefs must happen inside the body; a pointer derefed outside of it
raises because there is no loader bound."
[cfg file-id & body]
`(binding [pmap/*load-fn* (partial load-pointer ~cfg ~file-id)]
~@body))
(defmacro with-tracked
"Bind a fresh tracked set around `body`, without a fragment loader.
For write paths that create pointers before any file exists to load
from (e.g. file creation): wrapping tracks new pointers for
persistence, while any deref still fails loudly."
[& body]
`(binding [pmap/*tracked* (pmap/create-tracked)]
~@body))
(defmacro with-untracked
"Run `body` with pointer tracking disabled. For validation passes
that must not track anything for persistence: pointers created
inside are not collected, and derefs still go through the bound
loader when there is one."
[& body]
`(binding [pmap/*tracked* nil]
~@body))
(defmacro with-tracked-pointers
"Bind a fresh tracked set plus the fragment loader for `file-id`
around `body`. For write paths that create or modify pointers."
[cfg file-id & body]
`(binding [pmap/*tracked* (pmap/create-tracked)
pmap/*load-fn* (partial load-pointer ~cfg ~file-id)]
~@body))
(defn process-pointers
"Apply a function to all pointers on the file. Usuly used for
dereference the pointer to a plain value before some processing."
@ -311,14 +358,20 @@
(defn realize-pointers
"Process a file and remove all instances of pointers realizing them to
a plain data. Used in operation where is more efficient have the
whole file loaded in memory."
[cfg {:keys [id] :as file}]
(binding [pmap/*load-fn* (partial load-pointer cfg id)]
(update file :data process-pointers deref)))
plain data. Accepts a file map (arity 1) or raw file data with its
file id (arity 2): a snapshot map carries the snapshot id, so always
pass the live file id explicitly."
([cfg {:keys [id] :as file}]
(update file :data #(realize-pointers cfg id %)))
([cfg file-id data]
(with-pointers cfg file-id
(process-pointers data deref))))
(defn get-used-pointer-ids
"Given a file, return all pointer ids used in the data."
"Given a file data map, return all pointer ids used in the data.
This is a plain readout with no liveness meaning of its own: file-gc
unions it over the main file and every unpurged snapshot (see
`app.tasks.file-gc/clean-fragments!` for the actual liveness rule)."
[fdata]
(->> (concat (vals fdata)
(vals (:pages-index fdata)))
@ -345,3 +398,50 @@
(->> file
(realize-pointers cfg)
(realize-objects cfg)))
(defn realize-entry
"Realize a file data entry (a page or the components map) to plain
data for value comparison: deref pointers and convert objects-maps
with the same `into {}` production uses. Requires *load-fn* bound."
[entry]
(let [entry (if (pmap/pointer-map? entry) (deref entry) entry)]
(if (and (map? entry) (contains? entry :objects))
(let [objects (:objects entry)]
(assoc entry :objects (if (omap/objects-map? objects)
(into {} objects)
objects)))
entry)))
(defn original-pointers
"Snapshot the current pointer layout of file data, mapping each
pointer position to its PointerMap. No loading involved."
[fdata]
{:root (into {} (filter (fn [[_ v]] (pmap/pointer-map? v))) fdata)
:pages (into {} (filter (fn [[_ v]] (pmap/pointer-map? v)))
(:pages-index fdata {}))})
(defn reattach-unchanged
"Put back the original fragment pointers wherever the current value
is value-equal to the stored fragment, so unchanged positions keep
their ids and no new fragment rows are persisted for them. `current`
may be a PointerMap (file-gc) or a plain page (the migration read
path); `orig` always comes from `original-pointers`. Anything added,
removed or actually changed keeps the current value. Requires
*load-fn* bound."
[{:keys [root pages]} file]
(letfn [(reattach [current orig]
(if (or (identical? current orig)
(= (realize-entry current) (realize-entry orig)))
orig
current))
(reattach-all [m origs]
(reduce-kv (fn [m k orig]
(if (contains? m k)
(update m k reattach orig)
m))
m origs))]
(update file :data (fn [data]
(cond-> (reattach-all data root)
(contains? data :pages-index)
(update :pages-index reattach-all pages))))))

23
backend/src/app/features/file_snapshots.clj
View File

@ -22,6 +22,7 @@
[app.jobs :as jobs]
[app.storage :as sto]
[app.util.blob :as blob]
[app.util.pointer-map :as pmap]
[cuerdas.core :as str]))
(def sql:snapshots
@ -390,8 +391,13 @@
:snapshot-id (str (:id snapshot)))
;; In the same way, on reseting the file data, we need to restore
;; the applied migrations on the moment of taking the snapshot
(bfc/update-file! cfg file ::bfc/reset-migrations? true)
;; the applied migrations on the moment of taking the snapshot.
;; The snapshot data may hold shared pointer-mapped pages; the
;; loader stays bound while persisting so any page the encode
;; path does load keeps working (`enable-objects-map` skips the
;; unloaded ones).
(fdata/with-pointers cfg file-id
(bfc/update-file! cfg file ::bfc/reset-migrations? true))
;; FIXME: this should be separated functions, we should not have
;; inline sql here.
@ -455,13 +461,20 @@
(defn reduce-snapshots
"Process the file snapshots using efficient reduction; the file
reduction comes with all snapshots, including maked as deleted"
reduction comes with all snapshots, including maked as deleted.
Snapshot data may hold pointer-mapped pages, so the fragment loader
is bound while reducing: consumers that walk page content (media
refs, stats) transparently load fragments, consumers that only read
pointer ids never trigger a load."
[cfg file-id xform f init]
(let [conn (db/get-connection cfg)
load (partial fdata/load-pointer cfg file-id)
xform (comp
(map (partial fdata/resolve-file-data cfg))
(map (partial fdata/decode-file-data cfg))
xform)]
(->> (db/plan conn [sql:get-snapshots file-id] {:fetch-size 1})
(transduce xform f init))))
(binding [pmap/*load-fn* load]
(->> (db/plan conn [sql:get-snapshots file-id] {:fetch-size 1})
(transduce xform f init)))))

3
backend/src/app/rpc/commands/comments.clj
View File

@ -29,7 +29,6 @@
[app.rpc.doc :as-alias doc]
[app.rpc.quotes :as quotes]
[app.rpc.retry :as rtry]
[app.util.pointer-map :as pmap]
[app.util.services :as sv]
[clojure.set :as set]
[cuerdas.core :as str]))
@ -170,7 +169,7 @@
(defn- get-file
"A specialized version of get-file for comments module."
[cfg file-id page-id]
(binding [pmap/*load-fn* (partial feat.fdata/load-pointer cfg file-id)]
(feat.fdata/with-pointers cfg file-id
(let [file (bfc/get-file cfg file-id)
data (get file :data)]
(-> file

11
backend/src/app/rpc/commands/files.clj
View File

@ -436,7 +436,7 @@
(cfeat/check-client-features! (:features params))
(cfeat/check-file-features! (:features file)))
page (binding [pmap/*load-fn* (partial feat.fdata/load-pointer cfg file-id)]
page (feat.fdata/with-pointers cfg file-id
(let [page (dm/get-in file [:data :pages-index resolved-page-id])]
(if (pmap/pointer-map? page)
(deref page)
@ -566,7 +566,7 @@
calculate-from-db
(fn []
(let [file (bfc/get-file cfg id)
result (binding [pmap/*load-fn* (partial feat.fdata/load-pointer cfg id)]
result (feat.fdata/with-pointers cfg id
(calculate-library-summary file))]
(-> file
(assoc :library-summary result)
@ -690,7 +690,7 @@
(defn- get-file-stats
[{:keys [::db/conn] :as cfg} file-id]
(let [file (bfc/get-file cfg file-id)
base (binding [pmap/*load-fn* (partial feat.fdata/load-pointer cfg file-id)]
base (feat.fdata/with-pointers cfg file-id
(cfs/calc-file-stats (:data file)))
lib-cnt (get-file-stats-library-counts conn file-id)]
(-> base
@ -779,7 +779,7 @@
(bfc/check-file-exists cfg file-id)
(check-read-permissions! cfg profile-id file-id)
(let [{:keys [data]} (bfc/get-file cfg file-id)]
(binding [pmap/*load-fn* (partial feat.fdata/load-pointer cfg file-id)]
(feat.fdata/with-pointers cfg file-id
(when-let [tokens-lib (cfo/get-tokens-lib data)]
(ctob/export-dtcg-json tokens-lib (cfo/get-tokens-status data))))))
@ -1025,8 +1025,7 @@
(assert (db/connection-map? cfg)
"expected cfg with valid connection")
(binding [pmap/*load-fn* (partial feat.fdata/load-pointer cfg file-id)
pmap/*tracked* (pmap/create-tracked)]
(feat.fdata/with-tracked-pointers cfg file-id
(let [file (-> (bfc/get-file cfg file-id
:include-deleted? true
:lock-for-update? true)

45
backend/src/app/rpc/commands/files_create.clj
View File

@ -14,6 +14,7 @@
[app.common.types.file :as ctf]
[app.config :as cf]
[app.db :as db]
[app.features.fdata :as fdata]
[app.loggers.audit :as-alias audit]
[app.loggers.webhooks :as-alias webhooks]
[app.rpc :as-alias rpc]
@ -22,7 +23,6 @@
[app.rpc.doc :as-alias doc]
[app.rpc.permissions :as perms]
[app.rpc.quotes :as quotes]
[app.util.pointer-map :as pmap]
[app.util.services :as sv]
[clojure.set :as set]))
@ -44,32 +44,31 @@
(assert (db/connection? conn) "expected a valid connection")
(binding [pmap/*tracked* (pmap/create-tracked)
cfeat/*current* features]
(binding [cfeat/*current* features]
(fdata/with-tracked
(let [file (ctf/make-file {:id id
:project-id project-id
:name name
:revn revn
:is-shared is-shared
:features features
:migrations fmg/available-migrations
:ignore-sync-until ignore-sync-until
:created-at modified-at
:deleted-at deleted-at}
{:create-page create-page
:page-id page-id})]
(let [file (ctf/make-file {:id id
:project-id project-id
:name name
:revn revn
:is-shared is-shared
:features features
:migrations fmg/available-migrations
:ignore-sync-until ignore-sync-until
:created-at modified-at
:deleted-at deleted-at}
{:create-page create-page
:page-id page-id})]
(bfc/insert-file! cfg file)
(bfc/insert-file! cfg file)
(->> (assoc params :file-id (:id file) :role :owner)
(create-file-role! conn))
(->> (assoc params :file-id (:id file) :role :owner)
(create-file-role! conn))
(db/update! conn :project
{:modified-at (ct/now)}
{:id project-id})
(db/update! conn :project
{:modified-at (ct/now)}
{:id project-id})
(bfc/get-file cfg (:id file)))))
(bfc/get-file cfg (:id file))))))
(def ^:private schema:create-file
[:map {:title "create-file" :closed true}

76
backend/src/app/rpc/commands/files_snapshot.clj
View File

@ -13,6 +13,7 @@
[app.common.time :as ct]
[app.db :as db]
[app.db.sql :as-alias sql]
[app.features.fdata :as fdata]
[app.features.file-snapshots :as fsnap]
[app.features.logical-deletion :as ldel]
[app.main :as-alias main]
@ -66,9 +67,14 @@
;; Load current file metadata only (no data decoding) then overlay
;; the snapshot data so the client receives the same shape as a
;; normal get-file response but with historical page/object content.
(let [base-file (bfc/get-file cfg file-id :load-data? false)]
;; Snapshots may hold pointer-mapped pages shared with the live
;; file, so materialize them here: the preview UI applies the
;; response straight into state and cannot resolve pointers.
;; NOTE: the loader binds the live file-id, not the snapshot id.
(let [base-file (bfc/get-file cfg file-id :load-data? false)
data (fdata/realize-pointers cfg file-id (:data snapshot))]
(-> base-file
(assoc :data (:data snapshot))
(assoc :data data)
(assoc :version (:version snapshot))
(assoc :features (:features snapshot))
(assoc :revn (:revn snapshot))
@ -84,10 +90,22 @@
{::doc/added "1.20"
::sm/params schema:create-file-snapshot
::climit/id [[:create-file-snapshot/by-profile ::rpc/profile-id]
[:create-file-snapshot/global]]}
[:create-file-snapshot/global]]
::db/transaction true}
[cfg {:keys [::rpc/profile-id file-id label]}]
(files/check-edition-permissions! cfg profile-id file-id)
(let [file (bfc/get-file cfg file-id :realize? true)
;; NOTE: the file is intentionally NOT realized here: the snapshot
;; shares fragment rows with the live file (same as automatic
;; snapshots) instead of storing a materialized copy. file-gc treats
;; every unpurged snapshot as a liveness root, and readers
;; (get-file-snapshot, restore!, reduce-snapshots) resolve pointers
;; on demand.
;; NOTE: the file is read with FOR SHARE inside this transaction so
;; snapshot creation serializes with a concurrent :file-gc pass
;; (which takes FOR UPDATE + SKIP LOCKED on the same row). Without
;; the lock, a version pinned mid-pass could reference fragment rows
;; the pass is recreating.
(let [file (bfc/get-file cfg file-id :lock-for-share? true)
project (db/get-by-id cfg :project (:project-id file))]
(-> cfg
@ -115,43 +133,55 @@
[:restore-file-snapshot/global]]}
[{:keys [::db/pool ::mbus/msgbus] :as cfg} {:keys [::rpc/profile-id ::rpc/session-id file-id id] :as params}]
;; Check permissions and read current file state (short-lived, outside restore transaction)
;; Check permissions
(files/check-edition-permissions! pool profile-id file-id)
(let [file (bfc/get-file cfg file-id)
;; `fsnap/restore!` refuses a branch file too. The command
;; refuses before it takes the backup snapshot below, which is
;; committed whatever the restore's outcome.
_ (fsnap/check-restorable! file)
team (teams/get-team pool
(let [team (teams/get-team pool
:profile-id profile-id
:file-id file-id)
delay (ldel/get-deletion-delay team)
file-revn (:revn file)]
;; Create backup snapshot of the current state (committed immediately
;; independently of the restore outcome)
(fsnap/create! cfg file
{:profile-id profile-id
:deleted-at (ct/in-future delay)
:created-by "system"})
;; Create backup snapshot of the current state (committed immediately
;; independent of the restore outcome). The read takes FOR SHARE so a
;; concurrent :file-gc pass (which holds FOR UPDATE + SKIP LOCKED on the
;; file row) either finishes first -- and we snapshot the new fragments --
;; or skips the file and retries later. Without the lock, the backup
;; could reference fragments the pass is about to mark as deleted,
;; breaking the backup permanently.
;;
;; The backup read also provides the revn the guard below compares
;; against. An edit committed before this read is captured in the
;; backup and no longer aborts the restore; only edits committed
;; after the backup conflict.
backup-revn
(db/tx-run! cfg
(fn [cfg]
(let [file (bfc/get-file cfg file-id :lock-for-share? true)]
;; `fsnap/restore!` refuses a branch file too. The
;; command refuses before it takes the backup
;; snapshot, which is committed whatever the
;; restore's outcome.
(fsnap/check-restorable! file)
(fsnap/create! cfg file
{:profile-id profile-id
:deleted-at (ct/in-future delay)
:created-by "system"})
(:revn file))))]
;; Restore snapshot inside its own transaction; the revn check
;; ensures no data is lost if the file was edited concurrently
(db/tx-run! cfg
(fn [{:keys [::db/conn] :as cfg}]
(let [current (bfc/get-minimal-file conn file-id {::db/for-update true})]
(when (not= (:revn current) file-revn)
(when (not= (:revn current) backup-revn)
(ex/raise :type :conflict
:code :file-modified
:hint "the file was modified during the restore process, please retry")))
(let [vern (fsnap/restore! cfg file-id id)]
(mbus/pub! msgbus
:topic (:id file)
:topic file-id
:message {:type :file-restored
:session-id session-id
:file-id (:id file)
:file-id file-id
:vern vern})
nil)))))

2
backend/src/app/rpc/commands/files_thumbnails.clj
View File

@ -166,7 +166,7 @@
objects)))]
(binding [pmap/*load-fn* (partial fdata/load-pointer cfg id)]
(fdata/with-pointers cfg id
(let [frame (get-thumbnail-frame data)
frame-id (:id frame)
page-id (or (:page-id frame)

36
backend/src/app/rpc/commands/files_update.clj
View File

@ -36,7 +36,6 @@
[app.rpc.doc :as-alias doc]
[app.rpc.helpers :as rph]
[app.util.blob :as blob]
[app.util.pointer-map :as pmap]
[app.util.services :as sv]
[clojure.set :as set]))
@ -294,8 +293,7 @@
{:keys [profile-id file team features changes session-id skip-validate] :as params}
tpoint]
(binding [pmap/*tracked* (pmap/create-tracked)
pmap/*load-fn* (partial fdata/load-pointer cfg (:id file))]
(fdata/with-tracked-pointers cfg (:id file)
(let [file (assoc file :features
(-> features
@ -518,11 +516,13 @@
(rds/del conn key)))))
(defn- attach-snapshot
"Attach snapshot data to the file. This should be called before the
upcoming file operations are applied to the file."
[cfg migrated? file]
(let [snapshot (if migrated? file (fdata/realize cfg file))]
(assoc file ::snapshot snapshot)))
"Attach snapshot data to the file. Snapshots share fragment rows with
the live file, so the snapshot is kept as-is (with pointers); it is
NOT realized/materialized here. The file-gc liveness set unions main
and snapshots, so shared fragments survive while any of them needs
them."
[file]
(assoc file ::snapshot file))
(defn- update-file-data!
"Perform a file data transformation in with all update context setup.
@ -530,8 +530,9 @@
This function expected not-decoded file and transformation function. Returns
an encoded file.
This function is not responsible of saving the file. It only saves
fdata/pointer-map modified fragments."
This function is not responsible of saving the file. Fragment rows are
persisted later by `persist-file!` (via `bfc/update-file!` inside the
same transaction); nothing is written to `file_data` here."
[cfg {:keys [id] :as file} update-fn & args]
(let [file (update file :data (fn [data]
@ -546,6 +547,11 @@
take-snapshot?
(take-snapshot? file)
;; Attach the snapshot before migrating: a migration can rebuild a
;; page and give its PointerMap a new id with `modified?` set, and a
;; snapshot taken after that would keep the very pointer the save
;; then rewrites, ending up with post-save content.
;;
;; For avoid unnecesary overhead of creating multiple
;; pointers and handly internally with objects map in their
;; worst case (when probably all shapes and all pointers
@ -556,11 +562,11 @@
;; need-migration?
;; (->> (fdata/realize cfg))
need-migration?
(fmg/migrate-file libs)
take-snapshot?
(->> (attach-snapshot cfg need-migration?)))]
(->> (attach-snapshot))
need-migration?
(fmg/migrate-file libs))]
(apply update-fn cfg file args)))
@ -641,7 +647,7 @@
(finally
(record-validation-timing cfg :process-changes-ms "process-changes" (inst-ms (tproc)))))]
(binding [pmap/*tracked* nil]
(fdata/with-untracked
(when (contains? cf/flags :soft-file-validation)
(let [t (ct/tpoint)]
(try

71
backend/src/app/tasks/file_gc.clj
View File

@ -42,14 +42,27 @@
(map :data)
(mapcat cfh/collect-used-media)))
(defn- collect-snapshot-liveness
"Single snapshot scan collecting both fragment pointer ids and media
ids referenced by unpurged snapshots. Runs once per file-gc pass and
feeds clean-file-media! and clean-fragments!, so snapshot blobs are
read and decoded only once instead of once per cleaner."
[cfg file-id]
(let [xf (comp (filter :data)
(map (fn [{:keys [data]}]
{:pointers (feat.fdata/get-used-pointer-ids data)
:media (cfh/collect-used-media data)})))
rf (completing (fn [acc {:keys [pointers media]}]
(-> acc
(update :pointers into pointers)
(update :media into media))))]
(fsnap/reduce-snapshots cfg file-id xf rf {:pointers #{} :media #{}})))
(defn- clean-file-media!
"Performs the garbage collection of file media objects."
[{:keys [::db/conn ::timestamp] :as cfg} {:keys [id] :as file}]
[{:keys [::db/conn ::timestamp] :as cfg} snap-media {:keys [id] :as file}]
(let [used-media
(fsnap/reduce-snapshots cfg id xf:collect-used-media conj #{})
used-media
(into used-media xf:collect-used-media [file])
(into snap-media xf:collect-used-media [file])
used-media
(db/create-array conn "uuid" used-media)
@ -186,8 +199,15 @@
(mapcat feat.fdata/get-used-pointer-ids)))
(defn- clean-fragments!
[{:keys [::db/conn ::timestamp] :as cfg} {:keys [id] :as file}]
(let [used (into #{} xf:collect-pointers [file])
"Mark fragment rows referenced neither by the current main file data
nor by any unpurged snapshot. The file arrives unrealized (see
`get-file`), so `main-used` holds its stored fragment ids; combined
with `reattach-unchanged`, unchanged pages keep their ids and are
never marked. Runs inside the caller transaction, which already
holds FOR UPDATE on the file row."
[{:keys [::db/conn ::timestamp] :as cfg} snap-pointers {:keys [id] :as file}]
(let [main-used (into #{} xf:collect-pointers [file])
used (into main-used snap-pointers)
unused (->> (db/exec! conn [sql:mark-deleted-data-fragments timestamp id
(db/create-array conn "uuid" used)])
(into #{} bfc/xf-map-id))]
@ -201,10 +221,10 @@
file))
(defn- clean-media!
[cfg file]
[cfg {:keys [media]} file]
(let [file (->> file
(clean-deleted-components! cfg)
(clean-file-media! cfg)
(clean-file-media! cfg media)
(clean-file-thumbnails! cfg)
(clean-file-object-thumbnails! cfg))]
(cfv/validate-file-schema! file)
@ -212,8 +232,12 @@
(defn get-file
[cfg {:keys [file-id revn]}]
;; NOTE: deliberately NOT realized: `process-file!` binds the fragment
;; loader and works on PointerMaps directly, so unchanged pages keep
;; their fragment ids (see `reattach-unchanged`). Realizing here would
;; force every page to be re-persisted under a new id on every pass.
(let [file (bfc/get-file cfg file-id
:realize? true
:realize? false
:skip-locked? true
:lock-for-update? true)]
@ -237,13 +261,21 @@
(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))
;; Every fragment load goes through `with-pointers`. Each pointer
;; instance loads its content once (`loaded?`), and the replacement
;; instances `clean-file` creates already carry their content, so
;; the pass reads each fragment once without a separate cache.
(feat.fdata/with-pointers cfg file-id
(let [liveness (collect-snapshot-liveness cfg file-id)
original (feat.fdata/original-pointers (:data file))
file (->> file
(bfl/clean-file)
(clean-media! cfg liveness)
(feat.fdata/reattach-unchanged original)
(clean-fragments! cfg (:pointers liveness)))
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))
@ -266,9 +298,12 @@
processed? (process-file! cfg params)]
(when (and processed? (contains? cf/flags :tiered-file-data-storage))
;; Pass only the file id: the offload job ignores
;; any other file-gc param, and forwarding the whole
;; map would silently couple the two jobs.
(jobs/submit cfg
{::jobs/name :offload-file-data
::jobs/params params
::jobs/params {:file-id (:file-id params)}
::jobs/priority 10
::jobs/delay 1000}))
processed?))))

9
backend/src/app/util/pointer_map.clj
View File

@ -133,8 +133,13 @@
(or mdata {}))
(withMeta [_ mdata']
(let [pmap (PointerMap. id mdata' odata (not= mdata mdata') loaded?)]
(some-> *tracked* (swap! assoc id pmap))
(let [changed? (not= mdata mdata')
;; A fragment row never changes after it is written, so a
;; metadata change is a new pointer (fresh id + tracked), like
;; `assoc` does; reusing the id would rewrite the same row.
id' (if changed? (uuid/next) id)
pmap (PointerMap. id' mdata' odata changed? loaded?)]
(some-> *tracked* (swap! assoc id' pmap))
pmap))
Seqable

12
backend/test/backend_tests/binfile_test.clj
View File

@ -2904,6 +2904,18 @@
(:object-id thumb)))
(t/is (some? (:media-id thumb)))))))
(t/deftest get-file-without-data-rejects-locks
;; Locking is incompatible with `load-data? false`: the guard fires
;; before any query, so no DB row is needed. Regression test for the
;; `lock-for-share?`/`lock-for-share?` typo that left `lock-for-update?`
;; unchecked. NOTE: the guard is an unconditional `when`/`throw` in
;; `get-file*` (not an `assert`), so this test is not flag-dependent:
;; it behaves the same with or without `enable-backend-asserts`.
(doseq [opt [:lock-for-share? :lock-for-update? :skip-locked?]]
(t/is (thrown? IllegalArgumentException
(bfc/get-file th/*system* (uuid/random)
:load-data? false opt true)))))
;; -----------------------------------------------------------------------------
;; Branch target protection
;; -----------------------------------------------------------------------------

956
backend/test/backend_tests/file_pointer_snapshot_test.clj Normal file
View File

@ -0,0 +1,956 @@
;; 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.file-pointer-snapshot-test
"Snapshots share fragment rows with the live file (fdata/pointer-map),
so file-gc must keep fragments referenced by any live snapshot."
(:require
[app.binfile.common :as bfc]
[app.common.features :as cfeat]
[app.common.files.changes-builder :as pcb]
[app.common.files.migrations :as fmg]
[app.common.time :as ct]
[app.common.types.objects-map :as omap]
[app.common.types.shape :as cts]
[app.common.uuid :as uuid]
[app.db :as db]
[app.features.fdata :as fdata]
[app.features.file-snapshots :as fsnap]
[app.rpc :as-alias rpc]
[app.util.blob :as blob]
[app.util.pointer-map :as pmap]
[backend-tests.helpers :as th]
[clojure.test :as t]))
(t/use-fixtures :once th/state-init)
(t/use-fixtures :each th/database-reset)
(defn- update-file!
[& {:keys [profile-id file-id changes revn] :or {revn 0}}]
(let [params {::th/type :update-file
::rpc/profile-id profile-id
:id file-id
:session-id (uuid/random)
:revn revn
:vern 0
:features cfeat/supported-features
:changes changes}
out (th/command! params)]
(t/is (nil? (:error out)))
(:result out)))
(defn- fragment-rows
[file-id]
(th/db-query :file-data {:file-id file-id :type "fragment"}))
(defn- live-fragment-ids
[file-id]
(into #{} (map :id) (filter #(nil? (:deleted-at %)) (fragment-rows file-id))))
(defn- add-rect-change
[page-id shape-id]
[{:type :add-obj
:page-id page-id
:id shape-id
:parent-id uuid/zero
:frame-id uuid/zero
:components-v2 true
:obj (cts/setup-shape {:id shape-id
:name "rect"
:frame-id uuid/zero
:parent-id uuid/zero
:type :rect})}])
(defn- add-rect-changes
[page-id n]
(mapv #(first (add-rect-change page-id %)) (repeatedly n uuid/random)))
(defn- page-pointer-ids
[file-id & {:as opts}]
(let [f (apply bfc/get-file th/*system* file-id (mapcat identity opts))]
(into {} (map (fn [[pid p]] [pid (pmap/get-id p)]))
(:pages-index (:data f)))))
(defn- fragment-objects
[file-id fragment-id]
(some-> (th/db-get :file-data {:file-id file-id
:id fragment-id
:type "fragment"})
:data blob/decode :objects))
(defn- snapshots-by-revn
[file-id revn]
(th/db-exec! ["select id, label, revn from file_change
where file_id = ? and label is not null and revn = ?"
file-id revn]))
(t/deftest snapshot-shares-fragments-without-duplicates
(let [profile (th/create-profile* 1)
file (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared false})
file-id (:id file)
before (live-fragment-ids file-id)]
(t/is (pos? (count before)))
(let [f0 (bfc/get-file th/*system* file-id)
snapshot (fsnap/create! th/*system* f0 {:profile-id (:id profile)})
after (live-fragment-ids file-id)]
;; No new fragment rows: the snapshot reuses the live ones.
(t/is (= before after))
(t/is (some? (:id snapshot)))
;; Snapshot pointers are a subset of the live pointers.
(let [main-ids (fdata/get-used-pointer-ids (:data f0))
snap (fsnap/get-snapshot th/*system* file-id (:id snapshot))
snap-ids (fdata/get-used-pointer-ids (:data snap))]
(t/is (pos? (count snap-ids)))
(t/is (every? #(contains? main-ids %) snap-ids))))))
(t/deftest gc-keeps-fragments-referenced-by-live-snapshot
(let [profile (th/create-profile* 1)
file (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared false})
file-id (:id file)
f0 (bfc/get-file th/*system* file-id)
page-id (first (:pages (:data f0)))
snap (fsnap/create! th/*system* f0 {:profile-id (:id profile)})
old-ids (fdata/get-used-pointer-ids (:data f0))]
;; Modify the page: its fragment id changes, the old row is now only
;; referenced by the snapshot.
(update-file! :profile-id (:id profile)
:file-id file-id
:revn 0
:changes (add-rect-change page-id (uuid/random)))
(let [f1 (bfc/get-file th/*system* file-id)
new-ids (fdata/get-used-pointer-ids (:data f1))
orphan (first (remove #(contains? new-ids %) old-ids))]
(t/is (some? orphan))
(t/is (true? (th/run-task! :file-gc {:file-id file-id})))
;; The old fragment is still alive because the snapshot needs it.
(let [rows (fragment-rows file-id)
row (first (filter #(= orphan (:id %)) rows))]
(t/is (some? row))
(t/is (nil? (:deleted-at row))))
;; The snapshot still restores the pre-change content.
(let [snap-data (:data (fsnap/get-snapshot th/*system* file-id (:id snap)))
snap-ids (fdata/get-used-pointer-ids snap-data)]
(t/is (contains? snap-ids orphan))))))
(t/deftest snapshot-release-frees-fragments
;; Full pin-release lifecycle through the real paths: the replaced
;; fragment stays alive while the snapshot exists, and the next
;; file-gc after deleting + purging the snapshot marks it.
;; Note: every update takes an automatic snapshot, so besides the
;; manual one there is also an automatic snapshot of the same state;
;; the release phase deletes all of them.
(let [profile (th/create-profile* 1)
file (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared false})
file-id (:id file)
f0 (bfc/get-file th/*system* file-id)
page-id (first (:pages (:data f0)))]
(update-file! :profile-id (:id profile)
:file-id file-id
:revn 0
:changes (add-rect-change page-id (uuid/random)))
(let [f1 (bfc/get-file th/*system* file-id)
snap (fsnap/create! th/*system* f1 {:profile-id (:id profile)})]
(t/is (uuid? (:id snap)))
(update-file! :profile-id (:id profile)
:file-id file-id
:revn 1
:changes (add-rect-change page-id (uuid/random)))
(let [f2 (bfc/get-file th/*system* file-id)
new-ids (fdata/get-used-pointer-ids (:data f2))
old-ids (fdata/get-used-pointer-ids (:data f1))
orphan (first (remove #(contains? new-ids %) old-ids))]
(t/is (some? orphan))
(t/is (true? (th/run-task! :file-gc {:file-id file-id})))
(t/is (nil? (:deleted-at (first (filter #(= orphan (:id %))
(fragment-rows file-id))))))
;; Every update takes an automatic snapshot and each of them may
;; share the orphan, so release all of them through the real
;; path: delete! submits a :delete-object job per snapshot that
;; marks both its file_change and its file_data rows as deleted.
(doseq [{:keys [id]} (filter #(some? (:label %))
(th/db-query :file-change {:file-id file-id}))]
(fsnap/delete! th/*system* {:id id
:file-id file-id
:deleted-at (ct/minus (ct/now) {:hours 1})}))
(th/run-pending-jobs)
(t/is (pos? (:processed (th/run-task! :objects-gc {}))))
(t/is (true? (th/run-task! :file-gc {:file-id file-id})))
(let [row (first (filter #(= orphan (:id %)) (fragment-rows file-id)))]
(t/is (some? row))
(t/is (some? (:deleted-at row))))))))
(t/deftest file-gc-is-idempotent-on-unchanged-file
;; A file-gc pass over an unchanged file must not create fragment
;; rows nor mark any: unchanged pages keep their ids.
(let [profile (th/create-profile* 1)
file (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared false})
file-id (:id file)
before (live-fragment-ids file-id)]
(t/is (pos? (count before)))
(t/is (true? (th/run-task! :file-gc {:file-id file-id})))
(let [after-first (live-fragment-ids file-id)]
(t/is (= before after-first))
(t/is (true? (th/run-task! :file-gc {:file-id file-id})))
(t/is (= after-first (live-fragment-ids file-id)))
(t/is (every? #(nil? (:deleted-at %)) (fragment-rows file-id))))))
(t/deftest gc-marks-fragments-without-live-reference
(let [profile (th/create-profile* 1)
file (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared false})
file-id (:id file)
f0 (bfc/get-file th/*system* file-id)
page-id (first (:pages (:data f0)))
old-ids (fdata/get-used-pointer-ids (:data f0))]
(update-file! :profile-id (:id profile)
:file-id file-id
:revn 0
:changes (add-rect-change page-id (uuid/random)))
(let [f1 (bfc/get-file th/*system* file-id)
new-ids (fdata/get-used-pointer-ids (:data f1))
orphan (first (remove #(contains? new-ids %) old-ids))]
(t/is (some? orphan))
;; The update above may have left an automatic snapshot sharing the
;; replaced fragment; drop snapshot rows first so the fragment is
;; really unreferenced (same cleanup the rpc-file-test fragment
;; test performs before asserting GC marking).
(th/db-delete! :file-change {:file-id file-id})
(th/db-delete! :file-data {:file-id file-id :type "snapshot"})
(t/is (true? (th/run-task! :file-gc {:file-id file-id})))
(let [row (first (filter #(= orphan (:id %)) (fragment-rows file-id)))]
(t/is (some? row))
(t/is (some? (:deleted-at row)))))))
(t/deftest pointer-context-contract
;; The invariant the whole backend relies on: a pointer can only be
;; derefed while a loader is bound; with-pointers binds the loader
;; for the given file.
(let [pointer (pmap/create (uuid/next) {})]
(t/is (thrown? UnsupportedOperationException (deref pointer)))
(fdata/with-pointers th/*system* (uuid/random)
(try
(deref pointer)
(t/is false "expected a fragment-not-found error")
(catch clojure.lang.ExceptionInfo cause
(t/is (= :fragment-not-found (:code (ex-data cause)))))))))
(t/deftest restore-returns-snapshot-content
;; Snapshot, modify the page so the old fragment is snapshot-only,
;; restore, and compare fully resolved content with the snapshot.
(let [profile (th/create-profile* 1)
file (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared false})
file-id (:id file)
f0 (bfc/get-file th/*system* file-id)
snap (fsnap/create! th/*system* f0 {:profile-id (:id profile)})]
(update-file! :profile-id (:id profile)
:file-id file-id
:revn 0
:changes (add-rect-change
(first (:pages (:data f0)))
(uuid/random)))
(db/tx-run! th/*system*
(fn [cfg] (fsnap/restore! cfg file-id (:id snap))))
(let [snap-data (:data (fsnap/get-snapshot th/*system* file-id (:id snap)))
snap-content (:data (fdata/realize th/*system*
{:id file-id :data snap-data}))
live-content (:data (bfc/get-file th/*system* file-id
:realize? true))]
(t/is (= snap-content live-content)))))
(t/deftest migrating-save-keeps-snapshot-on-pre-save-content
;; A save that triggers a file migration must attach the automatic
;; snapshot before migrating. Otherwise the migration gives the page
;; pointer a fresh id and `modified?`, the save's change `assoc`s on
;; that same pointer (which then keeps its id) and the snapshot ends
;; up naming the fragment the save writes with the post-save content.
(let [profile (th/create-profile* 1)
file (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared false})
file-id (:id file)
page-a (uuid/random)
page-b (uuid/random)
shape-1 (uuid/random)
shape-2 (uuid/random)]
(update-file! :profile-id (:id profile)
:file-id file-id
:revn 0
:changes [{:type :add-page :name "a" :id page-a}
{:type :add-page :name "b" :id page-b}])
(update-file! :profile-id (:id profile)
:file-id file-id
:revn 1
:changes (add-rect-change page-a shape-1))
;; Force a pending migration on the next save: drop one applied
;; migration row so `need-migration?` is true again.
(th/db-delete! :file-migration {:file-id file-id
:name "0031-migrate-stroke-width-token-attr"})
(update-file! :profile-id (:id profile)
:file-id file-id
:revn 2
:changes (add-rect-change page-a shape-2))
(let [snapshot (first (snapshots-by-revn file-id 2))
snap-data (:data (fsnap/get-snapshot th/*system* file-id (:id snapshot)))
snap-id (pmap/get-id (get-in snap-data [:pages-index page-a]))
main-id (pmap/get-id (get-in (:data (bfc/get-file th/*system* file-id))
[:pages-index page-a]))
snap-objs (:objects (blob/decode
(:data (th/db-get :file-data {:file-id file-id
:id snap-id
:type "fragment"}))))]
(t/is (uuid? (:id snapshot)))
;; The snapshot must not share the fragment the save rewrites.
(t/is (not= snap-id main-id))
(t/is (contains? snap-objs shape-1))
(t/is (not (contains? snap-objs shape-2)))
;; Restoring it gives the pre-save page on a fully migrated file.
(let [out (th/command! {::th/type :restore-file-snapshot
::rpc/profile-id (:id profile)
:file-id file-id
:id (:id snapshot)})
restored (bfc/get-file th/*system* file-id :realize? true)
objects (get-in restored [:data :pages-index page-a :objects])]
(t/is (nil? (:error out)))
(t/is (contains? objects shape-1))
(t/is (not (contains? objects shape-2)))
(t/is (not (fmg/need-migration? restored)))))))
(t/deftest offload-keeps-fragment-semantics
;; Every file_data row (main, snapshot, fragments) moves to storage
;; without changing ids, and reads keep working.
(let [profile (th/create-profile* 1)
file (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared false})
file-id (:id file)
f0 (bfc/get-file th/*system* file-id)
snap (fsnap/create! th/*system* f0 {:profile-id (:id profile)})
_ (update-file! :profile-id (:id profile)
:file-id file-id
:revn 0
:changes (add-rect-change
(first (:pages (:data f0)))
(uuid/random)))
before (into {} (map (juxt :id identity))
(th/db-query :file-data {:file-id file-id}))
;; Snapshot rows are born with a future deleted-at (they expire),
;; and offload only moves rows with deleted-at IS NULL.
live-before (into {} (filter (comp nil? :deleted-at val)) before)
main-before (fdata/get-used-pointer-ids
(:data (bfc/get-file th/*system* file-id)))]
(t/is (pos? (count before)))
(t/is (every? #(= "db" (:backend %)) (vals before)))
(let [result (th/run-task! :offload-file-data {:file-id file-id})]
(t/is (zero? (:skipped result)))
(t/is (= (count live-before) (:offloaded result))))
(let [after (into {} (map (juxt :id identity))
(th/db-query :file-data {:file-id file-id}))
live-after (into {} (filter (comp nil? :deleted-at val)) after)]
(t/is (= (set (keys live-before)) (set (keys live-after))))
(t/is (every? #(= "storage" (:backend %)) (vals live-after)))
;; Same pointers after the move, and the shared snapshot loads.
(t/is (= main-before
(fdata/get-used-pointer-ids
(:data (bfc/get-file th/*system* file-id)))))
(t/is (some? (:data (fsnap/get-snapshot th/*system* file-id (:id snap))))))))
(t/deftest gc-reattaches-unchanged-pages-and-marks-orphan
;; No-churn boundary when content changes: modify exactly one page of
;; a two-page file and run file-gc. Unmodified pages must keep their
;; fragment ids (reattach), the replaced fragment must be marked, a
;; follow-up objects-gc must purge only that row, and the live file
;; must still resolve fully.
(let [profile (th/create-profile* 1)
file (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared false})
file-id (:id file)
f0 (bfc/get-file th/*system* file-id)
page-1 (first (:pages (:data f0)))
page-2 (uuid/next)
shape-2 (uuid/random)]
;; Second page so "unchanged" has a witness.
(update-file! :profile-id (:id profile)
:file-id file-id
:revn 0
:changes [{:type :add-page
:name "second"
:id page-2}
{:type :add-obj
:page-id page-2
:id shape-2
:parent-id uuid/zero
:frame-id uuid/zero
:components-v2 true
:obj (cts/setup-shape
{:id shape-2
:name "rect"
:frame-id uuid/zero
:parent-id uuid/zero
:type :rect})}])
(let [f1 (bfc/get-file th/*system* file-id)
pages-1 (:pages-index (:data f1))
id-1-before (pmap/get-id (get pages-1 page-1))
id-2-before (pmap/get-id (get pages-1 page-2))]
(t/is (some? id-1-before))
(t/is (some? id-2-before))
(t/is (not= id-1-before id-2-before))
;; Modify exactly page-1.
(update-file! :profile-id (:id profile)
:file-id file-id
:revn 1
:changes (add-rect-change page-1 (uuid/random)))
(let [f2 (bfc/get-file th/*system* file-id)
pages-2 (:pages-index (:data f2))
id-1-after (pmap/get-id (get pages-2 page-1))
id-2-after (pmap/get-id (get pages-2 page-2))
orphan id-1-before]
(t/is (not= id-1-before id-1-after))
(t/is (= id-2-before id-2-after))
;; Updates take automatic snapshots that would pin the orphan;
;; drop them so it is really unreferenced (same cleanup the
;; gc-marks test performs before asserting marking).
(th/db-delete! :file-change {:file-id file-id})
(th/db-delete! :file-data {:file-id file-id :type "snapshot"})
(t/is (true? (th/run-task! :file-gc {:file-id file-id})))
;; Unchanged page kept its id through the pass.
(let [f3 (bfc/get-file th/*system* file-id)
pages-3 (:pages-index (:data f3))]
(t/is (= id-2-after (pmap/get-id (get pages-3 page-2)))))
;; Orphan marked, nothing else touched.
(let [rows (fragment-rows file-id)
marked (filter #(some? (:deleted-at %)) rows)]
(t/is (= 1 (count marked)))
(t/is (= orphan (:id (first marked)))))
;; objects-gc purges exactly the orphan row.
(t/is (pos? (:processed (th/run-task! :objects-gc {}))))
(let [rows (fragment-rows file-id)]
(t/is (nil? (some #(= orphan (:id %)) rows)))
(t/is (= #{id-1-after id-2-after} (live-fragment-ids file-id))))
;; Live file still resolves fully.
(let [live (:data (bfc/get-file th/*system* file-id :realize? true))]
(t/is (empty? (fdata/get-used-pointer-ids live))))))))
(t/deftest snapshot-preview-resolves-after-offload
;; The preview path must resolve fragments that now live in the
;; storage backend, not just in db.
(let [profile (th/create-profile* 1)
file (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared false})
file-id (:id file)
f0 (bfc/get-file th/*system* file-id)
snap (fsnap/create! th/*system* f0 {:profile-id (:id profile)})]
(t/is (uuid? (:id snap)))
(update-file! :profile-id (:id profile)
:file-id file-id
:revn 0
:changes (add-rect-change
(first (:pages (:data f0)))
(uuid/random)))
(let [result (th/run-task! :offload-file-data {:file-id file-id})]
(t/is (zero? (:skipped result)))
(t/is (pos? (:offloaded result))))
(let [out (th/command! {::th/type :get-file-snapshot
::rpc/profile-id (:id profile)
:file-id file-id
:id (:id snap)
:features cfeat/supported-features})]
(t/is (nil? (:error out)))
(t/is (empty? (fdata/get-used-pointer-ids
(get-in out [:result :data])))))))
(t/deftest with-tracked-tracks-and-fails-loud-without-loader
;; Direct pin of the with-tracked contract: wrapping tracks the new
;; pointer, and a pointer that needs loading raises loudly because
;; no loader is bound. (`wrap` carries its value inline so it
;; derefs fine; `create` with an id starts unloaded, so it must
;; load — and there is nothing to load from.)
(fdata/with-tracked
(let [wrapped (pmap/wrap {:a 1})
unloaded (pmap/create (uuid/next) {})]
(t/is (pmap/pointer-map? wrapped))
(t/is (pmap/pointer-map? unloaded))
(t/is (contains? @pmap/*tracked* (pmap/get-id wrapped)))
(t/is (contains? @pmap/*tracked* (pmap/get-id unloaded)))
(t/is (= {:a 1} @wrapped))
(t/is (thrown? UnsupportedOperationException @unloaded))))) \n
(t/deftest legacy-snapshot-does-not-break-liveness
;; Snapshots written before the feature carry materialized data in
;; file_change.data (backend "legacy-db") instead of a file_data row.
;; file-gc must scan them without failing, and the legacy preview must
;; still resolve. Setup pins the legacy shape: file_change row with
;; data, no file_data snapshot row.
(let [profile (th/create-profile* 1)
file (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared false})
file-id (:id file)
f0 (bfc/get-file th/*system* file-id)
page-id (first (:pages (:data f0)))]
(update-file! :profile-id (:id profile)
:file-id file-id
:revn 0
:changes (add-rect-change page-id (uuid/random)))
;; Drop every snapshot row so only the manual one below exists.
(th/db-delete! :file-change {:file-id file-id})
(th/db-delete! :file-data {:file-id file-id :type "snapshot"})
(let [f1 (bfc/get-file th/*system* file-id)
snap (fsnap/create! th/*system* f1 {:profile-id (:id profile)})
snap-id (:id snap)
realized (:data (fdata/realize th/*system* {:id file-id :data (:data (fsnap/get-snapshot th/*system* file-id snap-id))}))]
;; Convert to the legacy shape: materialize into file_change.data,
;; drop the file_data snapshot row.
(th/db-delete! :file-data {:file-id file-id :type "snapshot"})
(th/db-update! :file-change {:data (blob/encode realized)} {:id snap-id})
;; Pin the legacy shape: data on file_change, no file_data row.
;; (db-get filters rows with deleted_at set, and system snapshots
;; carry a future one, so opt out of that filter explicitly.)
(t/is (nil? (seq (th/db-query :file-data {:file-id file-id :type "snapshot"}))))
(t/is (some? (:data (th/db-get :file-change {:id snap-id} {::db/remove-deleted false})))))
;; file-gc scans the legacy snapshot without failing...
(t/is (true? (th/run-task! :file-gc {:file-id file-id})))
;; ...the live file still resolves fully...
(let [live (:data (bfc/get-file th/*system* file-id :realize? true))]
(t/is (empty? (fdata/get-used-pointer-ids live))))
;; ...and the legacy preview resolves with no leftover pointers.
(let [snap-data (:data (fsnap/get-snapshot th/*system* file-id
(->> (th/db-query :file-change {:file-id file-id})
(filter #(some? (:data %)))
(first)
(:id))))]
(t/is (some? snap-data))
(t/is (empty? (fdata/get-used-pointer-ids snap-data))))))
(t/deftest offload-edit-gc-cycle-keeps-liveness
;; Full cycle on one file: offload to cold storage, edit (which brings
;; rows back hot), file-gc. Liveness must stay correct throughout and
;; the file must resolve fully at the end. (R1's fix is what lets
;; metadata-bearing files survive the first step; this file carries no
;; metadata, so the cycle also passes without it.)
(let [profile (th/create-profile* 1)
file (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared false})
file-id (:id file)
f0 (bfc/get-file th/*system* file-id)
page-id (first (:pages (:data f0)))
before (into {} (map (juxt :id identity))
(th/db-query :file-data {:file-id file-id}))]
(t/is (pos? (count before)))
(let [result (th/run-task! :offload-file-data {:file-id file-id})]
(t/is (zero? (:skipped result)))
(t/is (pos? (:offloaded result))))
(update-file! :profile-id (:id profile)
:file-id file-id
:revn 0
:changes (add-rect-change page-id (uuid/random)))
;; The edit wrote hot rows back: some file_data is db-backed again.
(t/is (pos? (count (filter #(= "db" (:backend %))
(th/db-query :file-data {:file-id file-id})))))
(th/db-delete! :file-change {:file-id file-id})
(th/db-delete! :file-data {:file-id file-id :type "snapshot"})
(t/is (true? (th/run-task! :file-gc {:file-id file-id})))
(let [live (:data (bfc/get-file th/*system* file-id :realize? true))]
(t/is (empty? (fdata/get-used-pointer-ids live))))
;; Every referenced fragment is live.
(let [used (fdata/get-used-pointer-ids (:data (bfc/get-file th/*system* file-id)))
live (live-fragment-ids file-id)]
(t/is (pos? (count used)))
(t/is (every? live used)))))
(t/deftest save-keeps-untouched-page-fragments
;; A save must not rewrite the fragments of pages it does not touch,
;; even when the page's :objects map is a hash map (45 shapes), the
;; page itself has more than 8 keys (PersistentHashMap) and the
;; :pages-index is a hash map (9 pages). Re-assoc with an identical
;; value keeps map and pointer identity in array and hash maps alike.
(let [profile (th/create-profile* 1)
file (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared false})
file-id (:id file)
page-a (uuid/random)
others (vec (repeatedly 8 uuid/random))
page-b (first others)
guide (uuid/random)
flow (uuid/random)
thread (uuid/random)]
(update-file! :profile-id (:id profile)
:file-id file-id
:revn 0
:changes (into [{:type :add-page :name "a" :id page-a}]
(map-indexed (fn [i pid]
{:type :add-page
:name (str "p" i)
:id pid})
others)))
(update-file! :profile-id (:id profile)
:file-id file-id
:revn 1
:changes (into [{:type :mod-page
:id page-a
:background "#ffffff"
:background-token "token"
:pixel-grid-color "#000000"
:pixel-grid-opacity 0.5}
{:type :set-plugin-data
:object-type :page
:object-id page-a
:page-id page-a
:namespace "probe"
:key "k"
:value "1"}
{:type :set-guide
:page-id page-a
:id guide
:params {:id guide :axis :x :position 10}}
{:type :set-flow
:page-id page-a
:id flow
:params {:id flow
:name "flow"
:starting-frame uuid/zero}}
{:type :set-comment-thread-position
:page-id page-a
:comment-thread-id thread
:frame-id uuid/zero
:position {:x 10 :y 10}}]
(add-rect-changes page-a 45)))
(let [ids-before (page-pointer-ids file-id)
page (fdata/with-pointers th/*system* file-id
(deref (get-in (:data (bfc/get-file th/*system* file-id))
[:pages-index page-a])))]
;; The page is a hash map and its objects map is a hash map: the
;; scenario the churn suspicion was about.
(t/is (instance? clojure.lang.PersistentHashMap page))
(t/is (= 46 (count (:objects page))))
(update-file! :profile-id (:id profile)
:file-id file-id
:revn 2
:changes (add-rect-change page-b (uuid/random)))
(let [ids-after (page-pointer-ids file-id)]
(t/is (= (get ids-before page-a) (get ids-after page-a)))
(t/is (not= (get ids-before page-b) (get ids-after page-b))))
(update-file! :profile-id (:id profile)
:file-id file-id
:revn 3
:changes (add-rect-change page-b (uuid/random)))
(t/is (= (get ids-before page-a)
(get (page-pointer-ids file-id) page-a))))))
(t/deftest objects-map-flip-leaves-unloaded-pages-until-edited
;; A data-level flip of `fdata/objects-map` does not rewrite pages the
;; save does not load: `enable-objects-map` skips unloaded pointers, so
;; the page keeps its plain fragment until it is edited. The first edit
;; wraps it once and later saves keep the new id.
(let [profile (th/create-profile* 1)
file (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared false})
file-id (:id file)
page-a (uuid/random)
page-b (uuid/random)]
(update-file! :profile-id (:id profile)
:file-id file-id
:revn 0
:changes (into [{:type :add-page :name "a" :id page-a}
{:type :add-page :name "b" :id page-b}]
(add-rect-changes page-a 45)))
;; Simulate a file created with pointer-map only: strip the objects
;; maps, drop the feature and persist through the same encode path.
(db/tx-run! th/*system*
(fn [cfg]
(fdata/with-tracked-pointers cfg file-id
(let [file (bfc/get-file cfg file-id)
file (fdata/disable-objects-map file)]
(bfc/update-file! cfg file)))))
(let [page-plain (get (page-pointer-ids file-id) page-a)]
(t/is (not (omap/objects-map? (fragment-objects file-id page-plain))))
;; Add the feature at data level, the way a migration would.
(th/db-exec! ["update file
set features = array_append(features, 'fdata/objects-map')
where id = ?"
file-id])
;; A save on another page must leave the unloaded page alone.
(update-file! :profile-id (:id profile)
:file-id file-id
:revn 1
:changes (add-rect-change page-b (uuid/random)))
(t/is (= page-plain (get (page-pointer-ids file-id) page-a)))
(t/is (not (omap/objects-map? (fragment-objects file-id page-plain))))
;; The first edit of page A loads it and wraps it once.
(update-file! :profile-id (:id profile)
:file-id file-id
:revn 2
:changes (add-rect-change page-a (uuid/random)))
(let [page-wrapped (get (page-pointer-ids file-id) page-a)]
(t/is (not= page-plain page-wrapped))
(t/is (omap/objects-map? (fragment-objects file-id page-wrapped)))
(update-file! :profile-id (:id profile)
:file-id file-id
:revn 3
:changes (add-rect-change page-b (uuid/random)))
;; Converged: no further rewrite.
(t/is (= page-wrapped (get (page-pointer-ids file-id) page-a)))))))
(t/deftest save-loads-only-edited-page
;; With objects-map enabled, encoding a save must not load the
;; fragments of pages the change does not touch: each fragment was
;; already wrapped when it was written. A three-page file with a
;; one-page edit loads exactly one fragment (the edited page).
(let [profile (th/create-profile* 1)
file (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared false})
file-id (:id file)
f0 (bfc/get-file th/*system* file-id)
page-1 (first (:pages (:data f0)))
page-2 (uuid/random)
page-3 (uuid/random)]
(update-file! :profile-id (:id profile)
:file-id file-id
:revn 0
:changes [{:type :add-page :name "b" :id page-2}
{:type :add-page :name "c" :id page-3}
(first (add-rect-change page-2 (uuid/random)))])
(let [loads (atom 0)
load fdata/load-pointer]
(with-redefs [fdata/load-pointer
(fn [cfg file-id id]
(swap! loads inc)
(load cfg file-id id))]
(update-file! :profile-id (:id profile)
:file-id file-id
:revn 1
:changes (add-rect-change page-2 (uuid/random))))
(t/is (= 1 @loads))
(let [ids (page-pointer-ids file-id)]
(t/is (some? (get ids page-1)))
(t/is (some? (get ids page-3)))))))
(t/deftest restore-does-not-load-shared-pages
;; Restoring a snapshot reuses the shared fragments; encoding the
;; restored file must not load the pages it does not change.
(let [profile (th/create-profile* 1)
file (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared false})
file-id (:id file)
page-1 (first (:pages (:data (bfc/get-file th/*system* file-id))))
page-2 (uuid/random)]
(update-file! :profile-id (:id profile)
:file-id file-id
:revn 0
:changes [{:type :add-page :name "b" :id page-2}
(first (add-rect-change page-2 (uuid/random)))])
(let [f1 (bfc/get-file th/*system* file-id)
snap (fsnap/create! th/*system* f1 {:profile-id (:id profile)})
page-2-id (get (page-pointer-ids file-id) page-2)]
(update-file! :profile-id (:id profile)
:file-id file-id
:revn 1
:changes (add-rect-change page-1 (uuid/random)))
(let [loads (atom 0)
load fdata/load-pointer]
(with-redefs [fdata/load-pointer
(fn [cfg file-id id]
(swap! loads inc)
(load cfg file-id id))]
(db/tx-run! th/*system*
(fn [cfg] (fsnap/restore! cfg file-id (:id snap)))))
(t/is (zero? @loads))
(t/is (= page-2-id (get (page-pointer-ids file-id) page-2)))))))
(t/deftest migration-keeps-unchanged-page-fragments
;; Applying a pending migration on read keeps the fragment ids of the
;; pages the migration does not change; a page it changes gets a new
;; id. The caller still receives realized data, not pointers.
(let [profile (th/create-profile* 1)
file (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared false})
file-id (:id file)
page-a (uuid/random)
page-b (uuid/random)
shape-b (uuid/random)]
(update-file! :profile-id (:id profile)
:file-id file-id
:revn 0
:changes [{:type :add-page :name "a" :id page-a}
{:type :add-page :name "b" :id page-b}
(first (add-rect-change page-a (uuid/random)))
(-> (first (add-rect-change page-b shape-b))
(update :obj assoc :applied-tokens
{:stroke-width "token"}))])
(let [ids-before (page-pointer-ids file-id)]
;; Force the 0031 migration on the next read.
(th/db-delete! :file-migration
{:file-id file-id
:name "0031-migrate-stroke-width-token-attr"})
(let [returned (db/tx-run! th/*system*
(fn [cfg] (bfc/get-file cfg file-id)))]
(t/is (not (pmap/pointer-map? (get-in returned [:data :pages-index page-a]))))
(t/is (not (pmap/pointer-map? (get-in returned [:data :pages-index page-b]))))
(t/is (not (fmg/need-migration? returned)))
(let [tokens (get-in returned [:data :pages-index page-b
:objects shape-b :applied-tokens])]
(t/is (contains? tokens :stroke-width-top))
(t/is (not (contains? tokens :stroke-width)))))
(let [ids-after (page-pointer-ids file-id)]
(t/is (= (get ids-before page-a) (get ids-after page-a)))
(t/is (not= (get ids-before page-b) (get ids-after page-b))))
;; A second read neither migrates nor changes ids again.
(let [ids-after (page-pointer-ids file-id)
returned (db/tx-run! th/*system*
(fn [cfg] (bfc/get-file cfg file-id)))]
(t/is (= ids-after (page-pointer-ids file-id)))
(t/is (not (fmg/need-migration? returned)))))))
(t/deftest migration-read-only-keeps-fragments-untouched
;; A read-only migration returns realized data but does not persist:
;; the stored pointers and the pending migration stay as they were.
(let [profile (th/create-profile* 1)
file (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared false})
file-id (:id file)
page-1 (first (:pages (:data (bfc/get-file th/*system* file-id))))]
(update-file! :profile-id (:id profile)
:file-id file-id
:revn 0
:changes (add-rect-change page-1 (uuid/random)))
(th/db-delete! :file-migration
{:file-id file-id
:name "0031-migrate-stroke-width-token-attr"})
(let [ids-before (page-pointer-ids file-id {:migrate? false})
returned (db/tx-run! th/*system*
(fn [cfg] (bfc/get-file cfg file-id
:read-only? true)))]
(t/is (not (pmap/pointer-map? (get-in returned [:data :pages-index page-1]))))
(t/is (empty? (th/db-query :file-migration
{:file-id file-id
:name "0031-migrate-stroke-width-token-attr"})))
(t/is (= ids-before (page-pointer-ids file-id {:migrate? false}))))
;; A normal read migrates, and the unchanged page keeps its id.
(let [ids-before (page-pointer-ids file-id {:migrate? false})]
(db/tx-run! th/*system* (fn [cfg] (bfc/get-file cfg file-id)))
(t/is (= ids-before (page-pointer-ids file-id)))
(t/is (seq (th/db-query :file-migration
{:file-id file-id
:name "0031-migrate-stroke-width-token-attr"}))))))
(t/deftest libraries-load-their-pages-with-their-own-loader
;; Fragment rows are keyed by (file_id, id), and every caller binds the
;; loader of the file it works on. A library's pages must therefore come
;; back from the library loader already readable, or the first deref
;; under the consumer's loader asks the wrong file for the fragment.
(let [profile (th/create-profile* 1)
library (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared true})
file (th/create-file* 2 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared false})
lib-page (uuid/random)]
(th/link-file-to-library* {:file-id (:id file) :library-id (:id library)})
(update-file! :profile-id (:id profile)
:file-id (:id library)
:changes (-> (pcb/empty-changes nil)
(pcb/with-library-data (:data library))
(pcb/add-empty-page lib-page "library page")
(:redo-changes)))
;; Precondition: the library stores the page as a fragment pointer.
(t/is (contains? (page-pointer-ids (:id library)) lib-page))
(let [page (db/tx-run! th/*system*
(fn [cfg]
(fdata/with-pointers cfg (:id file)
(let [consumer (bfc/get-file cfg (:id file))
libs (bfc/get-resolved-file-libraries cfg consumer)]
(-> (get libs (:id library))
(get-in [:data :pages-index lib-page])
(fdata/realize-entry))))))]
(t/is (= lib-page (:id page)))
(t/is (contains? (:objects page) uuid/zero)))))

329
backend/test/backend_tests/rpc_file_snapshot_test.clj
View File

@ -6,6 +6,7 @@
(ns backend-tests.rpc-file-snapshot-test
(:require
[app.binfile.common :as bfc]
[app.common.features :as cfeat]
[app.common.pprint :as pp]
[app.common.thumbnails :as thc]
@ -15,10 +16,13 @@
[app.config :as cf]
[app.db :as db]
[app.db.sql :as sql]
[app.features.fdata :as fdata]
[app.features.file-snapshots :as fsnap]
[app.http :as http]
[app.rpc :as-alias rpc]
[app.storage :as sto]
[backend-tests.helpers :as th]
[clojure.set :as set]
[clojure.test :as t]
[cuerdas.core :as str]))
@ -138,6 +142,156 @@
;; delete 2 snapshots and 2 file data entries
(t/is (= 4 (:processed res)))))))))
(t/deftest snapshot-preview-resolves-fragments
;; Regression test (R1): previewing an automatic snapshot of a
;; pointer-mapped file must return plain data, not pointer
;; placeholders the preview UI cannot render.
(let [profile (th/create-profile* 1)
file (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared false})
file-id (:id file)
page-id (first (get-in file [:data :pages]))
shape-id (uuid/random)]
;; An update at revn 0 takes an automatic (system) snapshot of the
;; pre-change state; with pointer-map that snapshot shares fragments
;; with the live file.
(update-file! :profile-id (:id profile)
:file-id file-id
:revn 0
:changes [{:type :add-obj
:page-id page-id
:id shape-id
:parent-id uuid/zero
:frame-id uuid/zero
:components-v2 true
:obj (cts/setup-shape
{:id shape-id
:name "rect"
:frame-id uuid/zero
:parent-id uuid/zero
:type :rect})}])
;; Single labeled snapshot here, but order explicitly so a
;; future edit adding more snapshots cannot pick the wrong one.
(let [snap-id (->> (th/db-query :file-change {:file-id file-id} {:order-by [:created-at]})
(filter #(some? (:label %)))
(first)
(:id))
_ (t/is (uuid? snap-id))
out (th/command! {::th/type :get-file-snapshot
::rpc/profile-id (:id profile)
:file-id file-id
:id snap-id
:features cfeat/supported-features})]
(t/is (nil? (:error out)))
(let [data (get-in (:result out) [:data])]
(t/is (map? data))
(t/is (empty? (fdata/get-used-pointer-ids data)))))))
(defn- live-fragment-ids
[file-id]
(into #{}
(comp (filter #(nil? (:deleted-at %)))
(map :id))
(th/db-query :file-data {:file-id file-id :type "fragment"})))
(t/deftest user-snapshot-shares-fragments
;; User-pinned versions share fragment rows like automatic snapshots
;; instead of storing a materialized copy.
(let [profile (th/create-profile* 1)
file (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared false})
file-id (:id file)
page-id (first (get-in file [:data :pages]))
before (live-fragment-ids file-id)
out (th/command! {::th/type :create-file-snapshot
::rpc/profile-id (:id profile)
:file-id file-id
:label "v1"})
_ (t/is (nil? (:error out)))
snap-id (:id (:result out))]
;; No new fragment rows: the version reuses the live ones.
(t/is (uuid? snap-id))
(t/is (= before (live-fragment-ids file-id)))
;; The version pointers are a subset of the live pointers.
(let [live (fdata/get-used-pointer-ids
(:data (bfc/get-file th/*system* file-id)))
snap (fdata/get-used-pointer-ids
(:data (fsnap/get-snapshot th/*system* file-id snap-id)))]
(t/is (pos? (count snap)))
(t/is (every? #(contains? live %) snap)))
(let [shape-id (uuid/random)]
;; Modify the file, then restore the version and compare resolved
;; content with the version preview (both materialized).
(update-file! :profile-id (:id profile)
:file-id file-id
:revn 0
:changes [{:type :add-obj
:page-id page-id
:id shape-id
:parent-id uuid/zero
:frame-id uuid/zero
:components-v2 true
:obj (cts/setup-shape
{:id shape-id
:name "rect"
:frame-id uuid/zero
:parent-id uuid/zero
:type :rect})}]))
(let [preview-out (th/command! {::th/type :get-file-snapshot
::rpc/profile-id (:id profile)
:file-id file-id
:id snap-id
:features cfeat/supported-features})
_ (t/is (nil? (:error preview-out)))
preview (:result preview-out)
restore-out (th/command! {::th/type :restore-file-snapshot
::rpc/profile-id (:id profile)
:file-id file-id
:id snap-id})
_ (t/is (nil? (:error restore-out)))
live (:data (bfc/get-file th/*system* file-id :realize? true))
;; The preview resolves pointers but keeps objects-maps
;; encoded; realize them too so both sides are plain data.
preview-data (:data (fdata/realize-objects
nil {:data (:data preview)}))]
(t/is (= preview-data live)))))
(t/deftest user-snapshot-of-file-needing-migration-is-materialized
;; A file with pending migrations cannot share fragments: the
;; migration path realizes the data, so the stored snapshot holds
;; plain maps. This pins the shape so it cannot drift silently.
(let [profile (th/create-profile* 1)
file (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared false})
file-id (:id file)]
(th/db-update! :file {:version (dec (:version file))} {:id file-id})
(let [out (th/command! {::th/type :create-file-snapshot
::rpc/profile-id (:id profile)
:file-id file-id
:label "v1"})
_ (t/is (nil? (:error out)))
snap-id (:id (:result out))
snap (fsnap/get-snapshot th/*system* file-id snap-id)]
(t/is (uuid? snap-id))
(t/is (empty? (fdata/get-used-pointer-ids (:data snap))))
;; ...while preview keeps working on the migrated content.
(let [preview (th/command! {::th/type :get-file-snapshot
::rpc/profile-id (:id profile)
:file-id file-id
:id snap-id
:features cfeat/supported-features})]
(t/is (nil? (:error preview)))
(t/is (map? (get-in preview [:result :data])))))))
(t/deftest snapshots-locking
(let [profile-1 (th/create-profile* 1 {:is-active true})
profile-2 (th/create-profile* 2 {:is-active true})
@ -335,3 +489,178 @@
;; the command refuses before it takes its backup snapshot, which
;; would be committed whatever the restore's outcome
(t/is (empty? (th/db-query :file-change {:file-id branch-id :created-by "system"}))))))
(t/deftest snapshot-creation-serializes-with-file-gc
;; A user snapshot shares fragment rows with the live file, so its
;; creation must serialize with a concurrent :file-gc pass (which
;; takes FOR UPDATE + SKIP LOCKED on the file row): creation holds
;; FOR SHARE, the GC skips locked files instead of racing it.
(let [profile (th/create-profile* 1)
file (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared false})
file-id (:id file)]
(t/testing "gc skips a file locked for share"
(db/tx-run! th/*system*
(fn [cfg]
;; Hold FOR SHARE to commit, like create-file-snapshot does.
(bfc/get-file cfg file-id :lock-for-share? true)
;; The GC uses SKIP LOCKED on a different connection, so it
;; must skip instead of blocking or marking.
(t/is (not (th/run-task! :file-gc {:file-id file-id}))))))
(t/testing "creation cannot slip between gc scan and mark"
;; Deterministic interleaving: pause the GC right after its
;; snapshot scan, then create a snapshot. With the FOR SHARE lock
;; the creation waits at the read and sees post-GC fragment ids;
;; without it, it reads pre-GC ids and pins a fragment the pass
;; is about to mark.
(let [orig-reduce @#'fsnap/reduce-snapshots
orig-create @#'fsnap/create!
scan-started (promise)
release-scan (promise)
reached-insert (promise)
do-create (fn []
(th/command! {::th/type :create-file-snapshot
::rpc/profile-id (:id profile)
:file-id file-id
:label "pinned"}))]
(with-redefs [fsnap/reduce-snapshots
(fn [cfg file-id xform f init]
(deliver scan-started true)
@release-scan
(orig-reduce cfg file-id xform f init))
fsnap/create!
(fn [& args]
(deliver reached-insert true)
(apply orig-create args))]
(let [gc-done (future (th/run-task! :file-gc {:file-id file-id}))]
(t/is (= true (deref scan-started 10000 ::timeout)))
(let [created (future (do-create))]
;; The creation must not reach the insert while the GC
;; pass holds the file row: with FOR SHARE it waits at the
;; read instead of snapshotting pre-GC fragment ids.
(t/is (= ::timeout (deref reached-insert 10000 ::timeout)))
(deliver release-scan true)
(t/is (some? (deref gc-done 30000 ::timeout)))
(let [out (deref created 30000 ::timeout)]
(t/is (not= ::timeout out))
(t/is (nil? (:error out)))
(t/is (uuid? (get-in out [:result :id])))))))))
(t/testing "snapshot taken around gc still resolves"
;; The racing pass marks nothing (the file is unchanged, so
;; reattach keeps every id), therefore there is nothing to purge;
;; the snapshot keeps resolving afterwards.
(t/is (zero? (:processed (th/run-task! :objects-gc {}))))
(t/is (true? (th/run-task! :file-gc {:file-id file-id})))
;; The pinned snapshot (not an arbitrary autosnapshot: those may
;; reference fragments an earlier pass already marked) must keep
;; resolving after another GC cycle.
(let [snap-id (->> (th/db-query :file-change {:file-id file-id} {:order-by [:created-at]})
(filter #(= "pinned" (:label %)))
(first)
(:id))
out (th/command! {::th/type :get-file-snapshot
::rpc/profile-id (:id profile)
:file-id file-id
:id snap-id
:features cfeat/supported-features})]
(t/is (uuid? snap-id))
(t/is (nil? (:error out)))
(t/is (empty? (fdata/get-used-pointer-ids
(get-in out [:result :data]))))))))
(t/deftest restore-backup-serializes-with-file-gc
;; The backup snapshot taken by restore shares fragment rows with
;; the live file, so its creation must serialize with a concurrent
;; :file-gc pass, like ::create-file-snapshot does: with FOR SHARE
;; held by the GC pass, the restore waits at the locked read instead
;; of snapshotting pre-GC fragment ids that the pass is about to
;; mark as deleted.
(let [profile (th/create-profile* 1)
file (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared false})
file-id (:id file)
page-id (first (get-in file [:data :pages]))
shape-id (uuid/random)
snap-id (:id (:result (th/command! {::th/type :create-file-snapshot
::rpc/profile-id (:id profile)
:file-id file-id
:label "v1"})))]
(t/is (uuid? snap-id))
(update-file! :profile-id (:id profile)
:file-id file-id
:revn 0
:changes [{:type :add-obj
:page-id page-id
:id shape-id
:parent-id uuid/zero
:frame-id uuid/zero
:components-v2 true
:obj (cts/setup-shape
{:id shape-id
:name "rect"
:frame-id uuid/zero
:parent-id uuid/zero
:type :rect})}])
(let [orig-reduce @#'fsnap/reduce-snapshots
orig-create @#'fsnap/create!
scan-started (promise)
release-scan (promise)
reached-insert (promise)
do-restore (fn []
(th/command! {::th/type :restore-file-snapshot
::rpc/profile-id (:id profile)
:file-id file-id
:id snap-id}))]
(with-redefs [fsnap/reduce-snapshots
(fn [cfg file-id xform f init]
(deliver scan-started true)
@release-scan
(orig-reduce cfg file-id xform f init))
fsnap/create!
(fn [& args]
(deliver reached-insert true)
(apply orig-create args))]
(let [gc-done (future (th/run-task! :file-gc {:file-id file-id}))]
(t/is (= true (deref scan-started 10000 ::timeout)))
(let [restored (future (do-restore))]
(t/is (= ::timeout (deref reached-insert 10000 ::timeout)))
(deliver release-scan true)
(t/is (some? (deref gc-done 30000 ::timeout)))
(let [out (deref restored 30000 ::timeout)]
(t/is (not= ::timeout out))
(t/is (nil? (:error out))))))))
(let [backup-ids (->> (th/db-query :file-change {:file-id file-id})
(map (juxt :id :label))
(filter (fn [[_ label]]
(and (string? label)
(str/starts-with? label "snapshot-"))))
(map first)
(set))
backup-ids (set/intersection
backup-ids
(into #{}
(map :id)
(th/db-query :file-data {:file-id file-id
:type "snapshot"})))
live (into #{}
(map :id)
(filter #(nil? (:deleted-at %))
(th/db-query :file-data {:file-id file-id
:type "fragment"})))]
(t/is (= 1 (count backup-ids)))
(doseq [backup-id backup-ids
:let [snap (fsnap/get-snapshot th/*system* file-id backup-id)]]
(t/is (every? live (fdata/get-used-pointer-ids (:data snap))))
(let [out (th/command! {::th/type :get-file-snapshot
::rpc/profile-id (:id profile)
:file-id file-id
:id backup-id
:features cfeat/supported-features})]
(t/is (nil? (:error out)))
(t/is (empty? (fdata/get-used-pointer-ids
(get-in out [:result :data])))))))))

147
backend/test/backend_tests/rpc_file_test.clj
View File

@ -158,8 +158,9 @@
(t/is (true? (th/run-task! :file-gc {:file-id (:id file) :revn (:revn file)})))
;; Check the number of fragments before adding the page
;; (no churn: the preventive GC above reuses the single id).
(let [rows (th/db-query :file-data {:file-id (:id file) :type "fragment"})]
(t/is (= 2 (count rows))))
(t/is (= 1 (count rows))))
;; Add page
(update-file!
@ -173,20 +174,29 @@
:id page-id}])
;; Check the number of fragments before adding the page
;; (add-page adds exactly one fragment; the existing page keeps
;; its id).
(let [rows (th/db-query :file-data {:file-id (:id file) :type "fragment"})]
(t/is (= 3 (count rows))))
(t/is (= 2 (count rows))))
;; Snapshots share fragment rows with the live file; drop them so
;; this GC-mechanics test asserts only on unreferenced fragments
;; (snapshot retention itself is covered in file-pointer-snapshot-test).
(th/db-delete! :file-change {:file-id (:id file)})
(th/db-delete! :file-data {:file-id (:id file) :type "snapshot"})
;; The file-gc should mark for remove unused fragments
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
;; Check the number of fragments
;; Check the number of fragments (no churn: unchanged pages keep
;; their ids, so nothing is marked and nothing new is persisted).
(let [rows (th/db-query :file-data {:file-id (:id file) :type "fragment"})]
(t/is (= 5 (count rows)))
(t/is (= 3 (count (filterv :deleted-at rows)))))
(t/is (= 2 (count rows)))
(t/is (= 0 (count (filterv :deleted-at rows)))))
;; The objects-gc should remove unused fragments
;; The objects-gc has nothing to remove.
(let [res (th/run-task! :objects-gc {})]
(t/is (= 3 (:processed res))))
(t/is (= 0 (:processed res))))
;; Check the number of fragments
(let [rows (th/db-query :file-data {:file-id (:id file) :type "fragment"})]
@ -216,12 +226,18 @@
(let [rows (th/db-query :file-data {:file-id (:id file) :type "fragment"})]
(t/is (= 3 (count rows))))
;; Same snapshot cleanup as above: isolate GC mechanics from
;; snapshot retention.
(th/db-delete! :file-change {:file-id (:id file)})
(th/db-delete! :file-data {:file-id (:id file) :type "snapshot"})
;; The file-gc should mark for remove unused fragments
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
;; The objects-gc should remove unused fragments
;; Only the replaced page fragment is marked; the live pages keep
;; their ids instead of being re-persisted.
(let [res (th/run-task! :objects-gc {})]
(t/is (= 3 (:processed res))))
(t/is (= 1 (:processed res))))
;; Check the number of fragments;
(let [rows (th/db-query :file-data {:file-id (:id file)
@ -241,14 +257,15 @@
;; snapshots previously deleted.
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
;; Check the number of fragments;
;; Check the number of fragments; without churn the two live
;; pages simply stay where they are (was 4 with 2 re-persisted).
(let [rows (th/db-query :file-data {:file-id (:id file) :type "fragment"})]
;; (pp/pprint rows)
(t/is (= 4 (count rows)))
(t/is (= 2 (count rows)))
(t/is (= 2 (count (remove :deleted-at rows)))))
(let [res (th/run-task! :objects-gc {})]
(t/is (= 2 (:processed res))))
(t/is (= 0 (:processed res))))
(let [rows (th/db-query :file-data {:file-id (:id file) :type "fragment"})]
(t/is (= 2 (count rows))))))
@ -339,8 +356,10 @@
(t/is (ct/inst? (:deleted-at row2))))
(let [res (th/run-task! :objects-gc {})]
;; delete 2 fragments and 1 media object
(t/is (= 3 (:processed res))))
;; 1 (was 2): no churn orphans anymore, only the unused media
;; row is purged. The replaced page fragment stays pinned by
;; the automatic snapshot.
(t/is (= 1 (:processed res))))
;; check file media objects
(let [rows (th/db-query :file-media-object {:file-id (:id file)})]
@ -366,10 +385,11 @@
;; as deleted.
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
;; This only clears fragments, the file media objects still referenced because
;; snapshots are preserved
;; The deleted shape's fragment is pinned by the automatic
;; snapshot taken before the deletion, and its media is still
;; referenced there too: nothing is marked, nothing to purge.
(let [res (th/run-task! :objects-gc {})]
(t/is (= 2 (:processed res))))
(t/is (= 0 (:processed res))))
;; Delete all snapshots
(th/db-exec! ["update file_data set deleted_at = now() where file_id = ? and type = 'snapshot'" (:id file)])
@ -384,9 +404,11 @@
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
(let [res (th/run-task! :objects-gc {})]
;; 3 (was 4): the two orphaned page fragments plus the media
;; row, all unreferenced now that the snapshots are purged.
;; this will remove the file media objects marked as deleted
;; on prev file-gc
(t/is (= 2 (:processed res))))
(t/is (= 3 (:processed res))))
;; Now that file-gc have deleted the file-media-object usage,
;; lets execute the touched-gc task, we should see that two of
@ -510,12 +532,15 @@
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
(let [res (th/run-task! :objects-gc {})]
(t/is (= 2 (:processed res))))
;; 0 (was 2, then 1): no churn orphans and every replaced page
;; fragment stays pinned by an automatic snapshot.
(t/is (= 0 (:processed res))))
(let [rows (th/db-query :file-data {:file-id (:id file)
:type "fragment"
:deleted-at nil})]
(t/is (= (count rows) 1)))
;; 2 live (was 1): the snapshot-pinned fragment survives.
(t/is (= (count rows) 2)))
;; retrieve file and check trimmed attribute
(let [row (th/db-get :file {:id (:id file)})]
@ -553,10 +578,11 @@
;; as deleted.
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
;; This only removes unused fragments, file media are still
;; referenced on snapshots.
;; The deleted shapes' fragments stay pinned by the automatic
;; snapshots taken before the deletion, and the media is still
;; referenced there too: nothing is marked, nothing to purge.
(let [res (th/run-task! :objects-gc {})]
(t/is (= 2 (:processed res))))
(t/is (= 0 (:processed res))))
;; Mark all snapshots to be a non-snapshot file change
(th/db-exec! ["update file set has_media_trimmed = false where id = ?" (:id file)])
@ -567,7 +593,10 @@
;; "expired/deleted"
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
(let [res (th/run-task! :objects-gc {})]
(t/is (= 6 (:processed res))))
;; 7 (was 6, then 8): the two orphaned page fragments plus the
;; five media rows, all unreferenced once the snapshot file_data
;; rows are gone. No churn duplicates are created anymore.
(t/is (= 7 (:processed res))))
(let [rows (th/db-query :file-data {:file-id (:id file)
:type "fragment"
@ -716,9 +745,11 @@
;; Now that file-gc have marked for deletion the object
;; thumbnail lets execute the objects-gc task which remove
;; the rows and mark as touched the storage object rows
;; the rows and mark as touched the storage object rows.
;; 1 (was 5, then 3): without churn there are no orphaned
;; fragment rows to purge, only the deleted thumbnail row.
(let [res (th/run-task! :objects-gc {})]
(t/is (= 5 (:processed res))))
(t/is (= 1 (:processed res))))
;; Now that objects-gc have deleted the object thumbnail lets
;; execute the touched-gc task
@ -749,7 +780,9 @@
(let [res (th/run-task! :objects-gc {})]
;; (pp/pprint res)
(t/is (= 3 (:processed res))))
;; 1 (was 3, then 2): without churn there are no fragment
;; orphans; only the deleted thumbnail row is purged.
(t/is (= 1 (:processed res))))
;; We still have th storage objects in the table
(let [rows (th/db-query :storage-object {:deleted-at nil})]
@ -1387,7 +1420,10 @@
(t/is (= 1 (count (remove :deleted-at rows)))))
(let [res (th/run-task! :objects-gc {})]
(t/is (= 4 (:processed res))))
;; 1 (was 4, then 3): no fragment churn anymore — unchanged
;; pages keep their ids, so only the deleted object-thumbnail
;; row itself is purged.
(t/is (= 1 (:processed res))))
(let [rows (th/db-query :file-tagged-object-thumbnail {:file-id (:id file)})]
;; (app.common.pprint/pprint rows)
@ -1510,7 +1546,9 @@
(t/is (= 1 (count (remove (comp some? :deleted-at) rows)))))
(let [res (th/run-task! :objects-gc {})]
(t/is (= 2 (:processed res))))
;; 1 (was 2): without churn there is no re-persisted fragment
;; orphan; only the superseded thumbnail row is purged.
(t/is (= 1 (:processed res))))
(let [rows (th/db-query :file-thumbnail {:file-id (:id file)})]
(t/is (= 1 (count rows)))))))
@ -1530,8 +1568,9 @@
;; Preventive objects-gc
(let [result (th/run-task! :objects-gc {})]
;; deletes the fragment created by file-gc
(t/is (= 1 (:processed result))))
;; nothing to delete: without churn the preventive file-gc above
;; marked and created nothing.
(t/is (= 0 (:processed result))))
;; Check the number of fragments before adding the page
(let [rows (th/db-query :file-data {:file-id (:id file) :type "fragment"})]
@ -1555,9 +1594,10 @@
(t/is (= 2 (:freeze res)))
(t/is (= 0 (:delete res))))
;; Clean objects after file-gc
;; Clean objects after file-gc: nothing to purge, the single
;; fragment was kept (no churn re-persist) and offloaded as is.
(let [result (th/run-task! :objects-gc {})]
(t/is (= 1 (:processed result))))
(t/is (= 0 (:processed result))))
;; Check the number of fragments before adding the page
(let [rows (th/db-query :file-data {:file-id (:id file) :type "fragment"})]
@ -1607,48 +1647,49 @@
;; The file-gc should mark for remove unused fragments
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
;; The file-gc task, recreates all fragments, so after it we have
;; now the double of fragments, and the old ones are marked as
;; deleted, and the new ones are on DB
(let [[row1 row2 row3 row4 :as rows]
;; The file-gc only marks fragments nothing references: the live
;; pages keep their ids (no churn re-persist), row1 stays alive on
;; cold storage pinned by the automatic snapshot, row2 is the new
;; hot page.
(let [[row1 row2 :as rows]
(th/db-query :file-data
{:file-id (:id file)
:type "fragment"}
{:order-by [:created-at]})]
;; (pp/pprint rows)
(t/is (= 4 (count rows)))
;; No churn: live pages keep their ids, so there are no
;; re-persisted duplicates and nothing is marked. row1 stays on
;; cold storage pinned by the automatic snapshot.
(t/is (= 2 (count rows)))
(t/is (nil? (:data row1)))
(t/is (ct/inst? (:deleted-at row1)))
(t/is (nil? (:deleted-at row1)))
(t/is (= "storage" (:backend row1)))
(t/is (bytes? (:data row2)))
(t/is (= "db" (:backend row2)))
(t/is (ct/inst? (:deleted-at row2)))
(t/is (nil? (:deleted-at row2))))
(t/is (bytes? (:data row3)))
(t/is (= "db" (:backend row3)))
(t/is (nil? (:deleted-at row3)))
(t/is (bytes? (:data row4)))
(t/is (= "db" (:backend row4)))
(t/is (nil? (:deleted-at row4))))
;; The objects-gc should remove the marked to delete fragments
;; The objects-gc has nothing to remove: no fragment was marked.
(let [res (th/run-task! :objects-gc {})]
(t/is (= 2 (:processed res))))
(t/is (= 0 (:processed res))))
(let [rows (th/db-query :file-data {:file-id (:id file) :type "fragment"})]
;; 2 rows (was 3): the snapshot-pinned offloaded fragment plus
;; the single live hot row. No churn duplicates.
(t/is (= 2 (count rows)))
(t/is (every? #(bytes? (:data %)) rows))
(t/is (every? #(= "db" (:backend %)) rows)))
(t/is (= 1 (count (filter #(bytes? (:data %)) rows))))
(t/is (= 1 (count (filter #(= "storage" (:backend %)) rows))))
(t/is (= 1 (count (filter #(= "db" (:backend %)) rows)))))
;; we ensure that once object-gc is passed and marked two storage
;; objects to delete
(let [res (binding [ct/*clock* (ct/fixed-clock (ct/in-future {:hours 3}))]
(th/run-task! :storage-gc-touched {}))]
(t/is (= 0 (:freeze res)))
(t/is (= 2 (:delete res))))
;; 1 (was 2): only one storage object was touched by the purge
;; above, the pinned fragment's object is still referenced.
(t/is (= 1 (:delete res))))
(let [storage (sto/resolve th/*system*)]
(t/is (uuid? (:id @sobject)))

10
backend/test/backend_tests/rpc_file_thumbnails_test.clj
View File

@ -119,8 +119,11 @@
;; thumbnails
(th/run-task! :file-gc {:file-id (:id file)})
;; Only the unused object-thumbnail row is purged: the replaced
;; page fragment stays pinned by the automatic snapshot that shares
;; it, and reattach means file-gc writes no churn fragments.
(let [result (th/run-task! :objects-gc {})]
(t/is (= 3 (:processed result))))
(t/is (= 1 (:processed result))))
;; check if row2 related thumbnail row still exists
(let [[row :as rows] (th/db-query :file-tagged-object-thumbnail
@ -223,8 +226,11 @@
;; thumbnails
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
;; Only the superseded revn thumbnail row is purged: the file
;; itself is unchanged, so it keeps its fragment ids (no-churn)
;; and no fragment row is marked.
(let [result (th/run-task! :objects-gc {})]
(t/is (= 2 (:processed result))))
(t/is (= 1 (:processed result))))
;; check if row1 related thumbnail row still exists
(let [[row :as rows] (th/db-query :file-thumbnail

17
backend/test/backend_tests/util_pointer_map_test.clj
View File

@ -117,5 +117,20 @@
(t/is (not (contains? obj1 :b)))
(t/is (= 1 (get obj1 :a)))
(t/is (= nil (get obj1 :b)))
(t/is (= ::empty (get obj1 :b ::empty)))))))
(t/is (= ::empty (get obj1 :b ::empty))))))
(t/testing "with-meta"
(binding [pmap/*tracked* (atom {})
pmap/*load-fn* (constantly {})]
(let [obj1 (pmap/create uuid/zero {})
obj2 (with-meta obj1 {:foo :bar})
obj3 (with-meta obj1 {})]
;; A metadata change is a new pointer: fresh id and tracked, so
;; the fragment row is never rewritten under the same id.
(t/is (pmap/modified? obj2))
(t/is (not= (pmap/get-id obj1) (pmap/get-id obj2)))
(t/is (contains? @pmap/*tracked* (pmap/get-id obj2)))
;; The same metadata keeps the pointer untouched.
(t/is (not (pmap/modified? obj3)))
(t/is (= (pmap/get-id obj1) (pmap/get-id obj3)))))))

17
frontend/src/app/main/data/viewer.cljs
View File

@ -24,6 +24,7 @@
[app.main.data.fonts :as df]
[app.main.data.helpers :as dsh]
[app.main.features :as features]
[app.main.features.pointer-map :as fpmap]
[app.main.repo :as rp]
[app.main.router :as rt]
[app.render-wasm.api :as wasm.api]
@ -122,6 +123,13 @@
[:share-id {:optional true} ::sm/uuid]
[:pr-id {:optional true} ::sm/uuid]])
(defn resolve-viewer-fragment
"Resolves one pointer-mapped entry of the view-only bundle into a
[key data] pair. Thin wrapper over the shared `fpmap/resolve-pointer`
with share-link scoping; see it for the failure contract."
[file-id share-id entry]
(fpmap/resolve-pointer file-id share-id entry))
(defn- fetch-bundle
[{:keys [file-id share-id pr-id] :as params}]
@ -148,14 +156,7 @@
(uuid? pr-id)
(assoc :pr-id pr-id))
resolve (fn [[key pointer]]
(let [params {:file-id file-id :fragment-id @pointer}
params (cond-> params
(uuid? share-id)
(assoc :share-id share-id))]
(->> (rp/cmd! :get-file-fragment params)
(rx/map :data)
(rx/map #(vector key %)))))]
resolve (partial resolve-viewer-fragment file-id share-id)]
(->> (rp/cmd! :get-view-only-bundle params')
(rx/mapcat

7
frontend/src/app/main/data/workspace.cljs
View File

@ -21,7 +21,6 @@
[app.common.math :as mth]
[app.common.path-names :as cpn]
[app.common.render-wasm.wasm :as wasm-state]
[app.common.transit :as t]
[app.common.types.component :as ctc]
[app.common.types.components-list :as ctkl]
[app.common.types.shape :as cts]
@ -144,11 +143,11 @@
(log/inf :hint "resolve file"
:file-id (str (:id file))
:features (str/join " " (:features file)))
;; fpmap/resolve-file guarantees resolved data or an error; there is
;; no leftover-pointer case to handle here.
(->> (fpmap/resolve-file file)
(rx/map :data)
(rx/map
(fn [data]
(assoc file :data (d/removem (comp t/pointer? val) data))))))
(rx/map #(assoc file :data %))))
(defn- check-libraries-synchronization
[file-id libraries]

47
frontend/src/app/main/features/pointer_map.cljs
View File

@ -7,27 +7,54 @@
(ns app.main.features.pointer-map
"A frontend specific helpers for work with pointer-map feature"
(:require
[app.common.logging :as log]
[app.common.transit :as t]
[app.main.repo :as rp]
[beicon.v2.core :as rx]))
(defn- unresolved-pointers
[m]
(into [] (comp (filter (fn [[_ v]] (t/pointer? v))) (map key)) m))
(defn resolve-pointer
"Resolves a single [key pointer] entry into a [key data] pair against
`get-file-fragment`. A failing fragment rejects with the original
cause (logged with file-id and fragment-id) instead of resolving to
a silently pruned entry. Pass a share-id for share-link scoped
resolution, as the viewer does."
([file-id entry]
(resolve-pointer file-id nil entry))
([file-id share-id [key pointer :as kv]]
(if (t/pointer? pointer)
(let [params (cond-> {:file-id file-id :fragment-id @pointer}
(uuid? share-id)
(assoc :share-id share-id))]
(->> (rp/cmd! :get-file-fragment params)
(rx/map :data)
(rx/map #(vector key %))
(rx/catch (fn [cause]
(log/error :hint "unable to resolve file fragment"
:file-id (str file-id)
:fragment-id (str @pointer)
:cause cause)
(rx/throw cause)))))
(rx/of kv))))
(defn resolve-file
[{:keys [id data] :as file}]
(letfn [(resolve-pointer [[key val :as kv]]
(if (t/pointer? val)
(->> (rp/cmd! :get-file-fragment {:file-id id :fragment-id @val})
(rx/map #(get % :data))
(rx/map #(vector key %)))
(rx/of kv)))
(resolve-pointers [coll]
(letfn [(resolve-pointers [coll]
(->> (rx/from (seq coll))
(rx/merge-map resolve-pointer)
(rx/merge-map (partial resolve-pointer id))
(rx/reduce conj {})))]
(->> (rx/zip (resolve-pointers data)
(resolve-pointers (:pages-index data)))
(rx/take 1)
(rx/map (fn [[data pages-index]]
(let [data (assoc data :pages-index pages-index)]
(let [data (assoc data :pages-index pages-index)
pending (concat (unresolved-pointers data)
(unresolved-pointers pages-index))]
(when (seq pending)
(throw (ex-info "unresolved file fragments after resolve"
{:file-id id :keys pending})))
(assoc file :data data)))))))

126
frontend/test/frontend_tests/data/pointer_map_test.cljs Normal file
View File

@ -0,0 +1,126 @@
;; 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 frontend-tests.data.pointer-map-test
"Unit tests for the fragment resolvers (workspace and viewer): resolved
data comes back whole, and a failing fragment rejects instead of
silently dropping the page."
(:require
[app.common.transit :as tr]
[app.common.uuid :as uuid]
[app.main.data.viewer :as dv]
[app.main.features.pointer-map :as fpmap]
[app.main.repo :as rp]
[beicon.v2.core :as rx]
[cljs.test :as t :include-macros true]
[frontend-tests.helpers.async :as a]
[frontend-tests.helpers.mock :as mock]))
(def ^:private file-id (uuid/custom 10 10))
(def ^:private frag-id (uuid/custom 20 20))
(def ^:private page-id (uuid/custom 30 30))
(def ^:private fragment-content {:objects {}})
(defn- file-with-pointers
[]
{:id file-id
:data {:options {}
:components (tr/->Pointer frag-id {})
:pages-index {page-id (tr/->Pointer frag-id {})}}})
(defn- cmd-stub
[respond]
(mock/stub
(fn
([command] (respond command nil))
([command params] (respond command params)))))
(t/deftest ^:async resolve-file-resolves-all-fragments
(let [seen (atom nil)]
(await
(mock/with-mocks*
{rp/cmd! (cmd-stub (fn [command _params]
(t/is (= :get-file-fragment command))
(rx/of {:data fragment-content})))}
(await (a/observe (fpmap/resolve-file (file-with-pointers))
:on-next #(reset! seen %)))))
(t/is (some? @seen))
(t/is (= fragment-content (get-in @seen [:data :components])))
(t/is (= fragment-content (get-in @seen [:data :pages-index page-id])))))
(t/deftest ^:async resolve-viewer-fragment-rejects-with-original-cause
(let [failure (ex-info "fragment exploded" {})
seen (atom ::none)
caught (atom nil)]
(await
(mock/with-mocks*
{rp/cmd! (cmd-stub (fn [_command _params] (rx/throw failure)))}
(await (a/observe (dv/resolve-viewer-fragment file-id nil [:k (tr/->Pointer frag-id {})])
:on-next #(reset! seen %)
:on-error #(reset! caught %)))))
(t/is (= ::none @seen))
(t/is (= failure @caught))))
(t/deftest ^:async resolve-viewer-fragment-pairs-key-with-data
(let [seen (atom ::none)]
(await
(mock/with-mocks*
{rp/cmd! (cmd-stub (fn [command params]
(t/is (= :get-file-fragment command))
(t/is (= {:file-id file-id :fragment-id frag-id} params))
(rx/of {:data fragment-content})))}
(await (a/observe (dv/resolve-viewer-fragment file-id nil [:k (tr/->Pointer frag-id {})])
:on-next #(reset! seen %)))))
(t/is (= [:k fragment-content] @seen))))
(t/deftest ^:async resolve-viewer-fragment-forwards-share-id
(let [share-id (uuid/custom 40 40)
seen (atom ::none)]
(await
(mock/with-mocks*
{rp/cmd! (cmd-stub (fn [command params]
(t/is (= :get-file-fragment command))
(t/is (= {:file-id file-id :fragment-id frag-id :share-id share-id} params))
(rx/of {:data fragment-content})))}
(await (a/observe (dv/resolve-viewer-fragment file-id share-id [:k (tr/->Pointer frag-id {})])
:on-next #(reset! seen %)))))
(t/is (= [:k fragment-content] @seen))))
(t/deftest ^:async resolve-file-rejects-unresolved-leftover-pointer
;; A resolved fragment whose content is itself a pointer means the
;; data still holds an unresolvable reference after the merge: the
;; stream must reject with the local ex-info (not the transport
;; cause), and deliver nothing.
(let [seen (atom ::none)
caught (atom nil)]
(await
(mock/with-mocks*
{rp/cmd! (cmd-stub (fn [_command _params]
(rx/of {:data (tr/->Pointer frag-id {})})))}
(await (a/observe (fpmap/resolve-file (file-with-pointers))
:on-next #(reset! seen %)
:on-error #(reset! caught %)))))
(t/is (= ::none @seen))
(t/is (some? @caught))
(let [data (ex-data @caught)]
(t/is (= file-id (:file-id data)))
(t/is (seq (:keys data))))))
(t/deftest ^:async resolve-file-rejects-on-fragment-failure
(let [failure (ex-info "fragment exploded" {})
seen (atom ::none)
caught (atom nil)]
(await
(mock/with-mocks*
{rp/cmd! (cmd-stub (fn [_command _params] (rx/throw failure)))}
(await (a/observe (fpmap/resolve-file (file-with-pointers))
:on-next #(reset! seen %)
:on-error #(reset! caught %)))))
;; The page is never delivered half-resolved and the original cause
;; propagates instead of being swallowed.
(t/is (= ::none @seen))
(t/is (= failure @caught))))

2
frontend/test/frontend_tests/runner.cljs
View File

@ -21,6 +21,7 @@
[frontend-tests.data.nitrate-test]
[frontend-tests.data.persistence-retry-test]
[frontend-tests.data.persistence-test]
[frontend-tests.data.pointer-map-test]
[frontend-tests.data.profile-test]
[frontend-tests.data.repo-test]
[frontend-tests.data.store-test]
@ -184,6 +185,7 @@
'frontend-tests.data.nitrate-test
'frontend-tests.data.persistence-retry-test
'frontend-tests.data.persistence-test
'frontend-tests.data.pointer-map-test
'frontend-tests.data.profile-test
'frontend-tests.data.repo-test
'frontend-tests.data.store-test