🐛 Heal corrupt files in file-gc and fix its library loader

Teach the file-gc task to heal files whose stored data fails schema
or semantic validation instead of failing the nightly run: read once
(sanitize, migrate in memory, check the scheduled revn), run the
shared best-effort repair loop, then take the row lock and persist
the snapshot, marking the file trimmed. A new revision orphaned the
current file thumbnail (the list joins on revn), so a run that
changes bytes touches modified-at instead (the ETag covers it) and
no-op runs touch nothing; the change is detected against the decoded
pre-sanitize data, which get-file now returns as :orig-data. The
handler reports a result map with a keyword reason (:cleaned, :gone,
:stale-revn, :unfixable, :error) and the tiered-storage offload
submit runs outside the result handling, so a queue failure after a
good write stays truthful and only logs its own error. The
library-user scan moved out of the write transaction, so long scans
no longer trip idle-in-transaction timeouts.

Repair convergence lives in one shared loop used by file-gc, the
debug endpoint and the srepl helper: validate, apply the computed
repair changes and repeat up to ten times, returning the input
untouched when it throws or does not converge. file-gc revalidates
after the loop and raises :repair-did-not-converge, so a partial
cleanup is never stored as clean: the classifier reports :unfixable,
the file stays unmarked and the scheduler retries it. Validation
skips shapes without :shape-ref (copy roots legitimately carry
none), so the repair converges instead of crashing on the get-shape
precondition; a dedicated repair for copies that genuinely lost
their ref is future work.

Libraries load through the weak-map loader, and that loader was
broken: the threading macro passed :data to update as the map
itself, so every library load threw and the repair loop swallowed
the exception, silently skipping every repair for files with linked
libraries. The pipeline is now explicit: load, realize pointers
(they take [cfg file], so the reversed -> threading was returning
the Integrant system map) and then sanitize. Unconverted types broke
ref resolution (detaching copies) and hid real uses from
instance-of?, so libraries are sanitized on load, user files are
sanitized inside the library-user scan, and the srepl helper and the
debug endpoint sanitize too. Only migrate when migrations pend.

sanitize-file-data now returns the input instance unchanged when
neither the nil-entry drop nor the schema decode repairs anything:
lazy containers (objects-map) keep their identity and file-gc can
tell a real fix from a no-op by comparing with the pre-sanitize
data. The walk still happens on every call, and that cost is
documented on the loader.

Migration 0027 heals stored data durably with the same recipe the
read path applies: schema-decode unconverted types (precompiled
decoders, explicit component-objects pass) plus the legacy-57 nil
page cleanup that reappeared through a write path. clean-file keeps
only its post-decode fixes and documents the single sanitize pass.
Change-level guards reject :add-page without a valid page id
(structured error, not assert, so release CLJS still enforces it)
and conflicting id/page pairs.

Tests pin the contract with production-shaped corruption builders:
file-gc repair and the outcome matrix, loop convergence and give-up
branches, the :shape-ref guard both ways, page guards, sanitize
idempotence and identity (plain and objects-map), the 0027
migration, a remote copy resolved through the loaded library and the
non-convergence report; existing file suites move to the result map
through the run-file-gc! helper.

Closes #12433

Follow-up:
https://github.com/penpot/penpot/issues/12509

AI-assisted-by: muse-spark-1.3-contributor
AI-assisted-by: glm-5.3-flash
This commit is contained in:
Andrey Antukh 2026-10-19 11:27:35 +00:00
parent 021492a577
commit bb76b29fe2
25 changed files with 1979 additions and 155 deletions

View File

@ -29,6 +29,7 @@
- `storage-gc-touched` finds references before it sets `deleted_at`.
- `objects-gc` removes deleted domain rows and touches their storage object IDs. Each proc streams its pending keys with `db/plan` inside a read-only transaction and deletes them in chunks, each chunk in its own transaction with `FOR UPDATE SKIP LOCKED`: a chunk that fails is logged and skipped instead of aborting the run.
- Use `::db/reuse-conn true` with `sto/resolve` inside a database transaction.
- Background bulk writers (e.g. file-gc) intentionally resolve storage without `::db/reuse-conn`: `put-object!` commits in its own transaction and a rolled-back run leaves at most an unreferenced row, which deduplication reuses and storage GC reaps. Joining the main transaction would risk the opposite leak (backend content with no row).
## Deduplication

View File

@ -35,6 +35,7 @@
- The dispatcher selects `new`/`retry` tasks with `FOR UPDATE SKIP LOCKED`, marks them `scheduled`, and publishes Redis payload `[id scheduled-at]`. The runner skips Redis messages whose scheduled timestamp no longer matches DB state.
- Lost `scheduled` tasks are rescheduled after about 5 minutes; `running` tasks older than about 24 hours are marked failed as orphans.
- A task handler that is missing or returns an invalid result currently defaults to completed after warning. Throwing with `ex-data :type ::retry` controls retry behavior; `:strategy ::noop` retries without incrementing retry count.
- The file-gc handler reports a result map `{:cleaned :file-id :reason}` with `:cleaned`, `:gone`, `:stale-revn` (changed or locked since the read), `:unfixable` (data failures: `:validation`/`:data-validation` ex-data; anything raising `:repair-did-not-converge` — a file that is still invalid after repair: the repair loop returns the input unchanged when it cannot converge, and a partial cleanup must never be stored as clean) or `:error` (anything else). A run that changes bytes touches `modified-at` (invalidating the file ETag) without bumping `revn`, and always marks `has-media-trimmed`; neither failure marks the file, so the scheduler retries it.
- Cron jobs lock their `scheduled_task` row with `FOR UPDATE SKIP LOCKED`, disable statement/idle-in-transaction timeouts locally, and reschedule themselves in `finally` unless interrupted. Worker, dispatcher, and cron components do not start when the DB pool is read-only.
## Config and HTTP/session middleware
@ -75,6 +76,9 @@
- `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.
- `fdata/realize` combines pointer realization and object-map realization. Use it before operations that need complete in-memory file data instead of pointer placeholders.
- Realize pointers BEFORE sanitizing/decoding: a schema decode over data holding unresolved PointerMap values throws `UnsupportedOperationException` on first touch (`valAt` without a bound `*load-fn*`). `app.features.fdata/realize-pointers` takes `[cfg file]` (cfg first): it cannot be threaded with `->` from call sites that already hold the file map — the reverse threading returned the Integrant system map as the "loaded library" in `get-resolved-file-libraries`.
- The libraries weak map (`app.common.weak/loadable-weak-value-map`, used by `binfile.common/get-resolved-file-libraries`) pre-registers every key at construction; `valAt` calls `load-fn` only for a registered key whose soft reference is gone, so a missing key returns nil silently with no load attempt. `contains?` checks membership without loading; anything that reads a value loads lazily and caches it in a soft reference.
- `ctf/sanitize-file-data` walks and decodes the whole data on every call — that walk is the unavoidable cost. When the nil-entry drop and the schema decode change nothing, it returns the input instance as is: lazy containers (objects-map) keep their identity, and callers detect a real fix by comparing with the input (file-gc keeps the pre-sanitize `:data` around as `:orig-data` for exactly that).
- 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.
- File snapshots (versions) keep their metadata row in `file_change` and their payload in `file_data` (`type = 'snapshot'`). With the `db` backend `file_change.data` stays NULL: that column is only written by the `legacy-db` backend, plus the rows written before the 2025-07 file storage refactor.

View File

@ -5,7 +5,7 @@
A shape can occupy multiple roles at once:
1. Master/main instance: defines a component and has `:main-instance true` plus `:component-id`.
2. Copy/non-main instance: produced by instantiating a component and carries `:shape-ref` pointing at the master shape. `(ctk/in-component-copy? shape)` is essentially `(some? (:shape-ref shape))`.
2. Copy/non-main instance: produced by instantiating a component and carries `:shape-ref` pointing at the master shape. `(ctk/in-component-copy? shape)` is essentially `(some? (:shape-ref shape))`. A copy that lost its `:shape-ref` is corruption, but `check-component-ref` deliberately ignores ref-less shapes (otherwise repair crashes on the `get-shape` precondition); the dedicated repair is tracked in penpot/penpot#12509.
3. Component root: topmost shape of an instance, marked `:component-root true` and carrying surface attrs such as `:component-id` and `:component-file`.
Variant masters are main instances and component roots. Their descendants may themselves be component copies, so master/copy logic must handle nested instances rather than assuming those roles are exclusive.

View File

@ -21,11 +21,16 @@
- Full referential/semantic validation currently runs only when file features contain `"components/v2"`.
- Validation starts at root plus orphan shapes, then validates component records. `validate-file!` raises `:validation :referential-integrity` with collected details.
- `repair-file` does not mutate data directly; it reduces validation errors into redo changes using `changes-builder`. Callers must apply or persist those changes.
- `cfr/repair-loop` is the shared best-effort loop (file-gc, debug endpoint, srepl): validate, apply computed repair changes and repeat up to 10 times (`nil` counts as default). It never touches `revn`; when it throws (including `AssertionError` on JVM) or does not converge, it returns the input file untouched and the caller decides via a schema check.
- `check-component-ref` deliberately ignores shapes without `:shape-ref` (otherwise repair crashes on the `get-shape` precondition instead of converging). A copy root that genuinely lost its ref is therefore neither reported nor repaired; the dedicated `repair-error` is tracked in penpot/penpot#12509.
- `:missing-slot` fires only for a REAL swap: a copy sub-head whose `shape-ref` is no longer a child of the near main parent. A pure positional mismatch (ref still a sibling elsewhere) is a reorder — valid, realigned by the async component sync; do not "repair" it by assigning swap slots (a slot freezes the child out of normal sync). `fix-missing-swap-slots` (migration 0019) follows the same membership rule.
- `ctf/sanitize-file-data` decodes file data with the schema plus the legacy-57 nil-page cleanup; it is total and idempotent (unknown values pass through so real corruption still fails loudly). It runs on GC/debug/srepl/library reads, never as a substitute for `repair-loop`.
- file-gc never bumps `revn`: when the persisted snapshot differs from the decoded pre-sanitize data it touches `modified-at` (invalidating the file ETag) and always marks `has-media-trimmed`, so thumbnails keep matching the stored revision.
## Migrations
- Prefer optional attrs/default behavior so old files continue working without migration. If absence cannot preserve old behavior, add a migration.
- Migrations are an ordered set mixing legacy version-derived ids and newer named ids. Keep append order stable; `migrate` applies the set difference between available migrations and file migrations.
- `migrate-file` synthesizes legacy migration ids from old numeric versions when `:migrations` is absent, migrates legacy features, and records feature flags created through `cfeat/*new*`.
- When a file had no previous `:migrations`, `migrate-file` marks all migrations as migrated in metadata so callers persist the complete migration set, not only transformations that changed data.
- When a file had no previous `:migrations`, `migrate-file` marks all migrations as migrated in metadata so callers persist the complete migration set, not only transformations that changed data.
- `"0027-repair-unconverted-types-and-nil-pages"` re-applies the legacy-57 nil-page cleanup plus a schema decode, healing unconverted types durably. File-gc calls `fmg/migrate-file` only when `fmg/need-migration?` (same predicate as `bfc/get-file*`); in-memory `sanitize-file-data` always runs first.

View File

@ -133,6 +133,9 @@
(d/update-when :objects d/update-vals clean-shape-post-decode)))
(defn clean-file
"Post-decode shape fixes plus nil cleanup. Does not sanitize: the
single canonical sanitize pass lives in file-gc/get-file, before
migration; this function's only caller is file-gc/repair-file."
[file & {:as _opts}]
(update file :data
(fn [data]

View File

@ -912,11 +912,27 @@
This still requires at least one library at time to be loaded while
access to it is performed, but it improves considerable not having
the need of loading all the libraries at the same time."
[{:keys [::db/conn] :as cfg} {:keys [id] :as file}]
(let [library-ids (->> (get-file-libraries conn (:id file))
[cfg {:keys [id] :as file}]
(let [library-ids (->> (get-file-libraries cfg (:id file))
(map :id)
(cons (:id file)))
load-fn #(get-file cfg % :migrate? false)]
;; Realize pointers on load with each library's own loader
;; (pointers are file-local): values need no ambient *load-fn*
;; binding to be dereferenced. The realize pass walks and
;; materializes pointer content in memory — the accepted
;; cost, since this load is always in-memory.
;; Realize BEFORE sanitizing: an unresolved PointerMap throws
;; on first touch (valAt during the schema decode) because
;; no *load-fn* is bound around the loader itself, and the
;; sanitizer needs to walk the decoded data we hand it.
;; Note: realize-pointers takes [cfg file], so it cannot be
;; threaded with `->` from here.
;; Sanitize like the GC read path does: unconverted types
;; would break ref resolution (and detach copies) downstream,
;; and this load is always in-memory.
load-fn (fn [id]
(let [file (fdata/realize-pointers cfg (get-file cfg id :migrate? false))]
(update file :data ctf/sanitize-file-data)))]
(weak/loadable-weak-value-map library-ids load-fn {id file})))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

View File

@ -20,6 +20,7 @@
[app.common.pprint :as pp]
[app.common.time :as ct]
[app.common.transit :as t]
[app.common.types.file :as ctf]
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
@ -507,8 +508,13 @@
(db/tx-run! (assoc cfg ::db/rollback true)
(fn [cfg]
(let [file (bfc/get-file cfg file-id)
libs (bfc/get-resolved-file-libraries cfg file-id)]
;; Realize before sanitizing, like the libraries
;; loader does: an unresolved PointerMap throws on
;; first touch without a bound *load-fn*.
(let [file (some-> (bfc/get-file cfg file-id :realize? true)
(update :data ctf/sanitize-file-data))
libs (when file
(bfc/get-resolved-file-libraries cfg file))]
(if file
(let [errors (cfv/validate-file file libs)]
{::yres/status 200
@ -534,7 +540,14 @@
repair-file
(fn [file libs _]
(let [errors (cfv/validate-file file libs)]
;; Sanitize like the validate endpoint does: the single
;; pass fixes the production corruption families
;; (unconverted types, nil page entries) before the
;; cfr pass decides and heals. The data is already
;; realized by h/process-file!, so there is no
;; PointerMap risk here.
(let [file (update file :data ctf/sanitize-file-data)
errors (cfv/validate-file file libs)]
(.append output (if (empty? errors)
"NO VALIDATION ERRORS FOUND\n"
(str "VALIDATION ERRORS FOUND:\n"

View File

@ -6,55 +6,22 @@
(ns app.srepl.procs.file-repair
(:require
[app.common.files.changes :as cfc]
[app.common.files.repair :as cfr]
[app.common.files.validate :as cfv]
[app.common.logging :as l]))
[app.common.types.file :as ctf]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; GENERAL PURPOSE REPAIR
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn repair-file
"Internal helper for validate and repair the file. The operation is
applied multiple times untile file is fixed or max iteration counter
is reached (default 10).
"Internal helper for validate and repair the file. Sanitizes first
(the shared loop does not) so unconverted types do not choke
validation, then delegates to the shared `cfr/repair-loop` (the
same loop the file-gc task uses), so convergence rules stay in one
place.
This function should not be used directly, it is used throught the
app.srepl.main/repair-file! helper. In practical terms this function
is private and implementation detail."
[file libs & {:keys [max-iterations] :or {max-iterations 10}}]
(let [validate-and-repair
(fn [file libs iteration]
(when-let [errors (not-empty (cfv/validate-file file libs))]
(l/trc :hint "repairing file"
:file-id (str (:id file))
:iteration iteration
:errors (count errors))
(let [changes (cfr/repair-file file libs errors)]
(-> file
(update :revn inc)
(update :data cfc/process-changes changes)))))
process-file
(fn [file libs]
(loop [file file
iteration 0]
(if (< iteration max-iterations)
(if-let [file (validate-and-repair file libs iteration)]
(recur file (inc iteration))
file)
(do
(l/wrn :hint "max retry num reached on repairing file"
:file-id (str (:id file))
:iteration iteration)
file))))
file'
(process-file file libs)]
(when (not= (:revn file) (:revn file'))
(l/trc :hint "file repaired" :file-id (str (:id file))))
file'))
[file libs & {:keys [max-iterations]}]
(cfr/repair-loop (update file :data ctf/sanitize-file-data) libs :max-iterations max-iterations))

View File

@ -12,7 +12,10 @@
(:require
[app.binfile.cleaner :as bfl]
[app.binfile.common :as bfc]
[app.common.exceptions :as ex]
[app.common.files.helpers :as cfh]
[app.common.files.migrations :as fmg]
[app.common.files.repair :as cfr]
[app.common.files.validate :as cfv]
[app.common.logging :as l]
[app.common.thumbnails :as thc]
@ -22,14 +25,13 @@
[app.common.types.shape-tree :as ctt]
[app.config :as cf]
[app.db :as db]
[app.db.sql :as-alias sql]
[app.features.fdata :as feat.fdata]
[app.features.file-snapshots :as fsnap]
[app.storage :as sto]
[app.worker :as wrk]
[integrant.core :as ig]))
(declare get-file)
(def ^:private sql:mark-file-media-object-deleted
"UPDATE file_media_object
SET deleted_at = ?
@ -41,7 +43,7 @@
(map :data)
(mapcat cfh/collect-used-media)))
(defn- clean-file-media!
(defn- process-file-media
"Performs the garbage collection of file media objects."
[{:keys [::db/conn ::timestamp] :as cfg} {:keys [id] :as file}]
(let [used-media
@ -59,7 +61,7 @@
(doseq [id unused-media]
(l/trc :obj "media-object"
:file-id (str id)
:file-id (str (:id file))
:id (str id)))
file))
@ -70,7 +72,7 @@
WHERE file_id = ? AND object_id != ALL(?::text[])
RETURNING object_id")
(defn- clean-file-object-thumbnails!
(defn- process-file-object-thumbnails
[{:keys [::db/conn ::timestamp]} {:keys [data] :as file}]
(let [file-id (:id file)
using (->> (vals (:pages-index data))
@ -100,7 +102,7 @@
WHERE file_id = ? AND revn < ?
RETURNING revn")
(defn- clean-file-thumbnails!
(defn- process-file-thumbnails
[{:keys [::db/conn ::timestamp]} {:keys [id revn] :as file}]
(let [unused (->> (db/exec! conn [sql:mark-file-thumbnails-deleted timestamp id revn])
(into #{} (map :revn)))]
@ -126,27 +128,46 @@
[components library-id {:keys [data]}]
(filter #(ctf/used-in? data library-id % :component) components))
(defn- clean-deleted-components!
"Performs the garbage collection of unreferenced deleted components."
[{:keys [::db/conn] :as cfg} {:keys [data] :as file}]
(let [file-id (:id file)
(defn- get-library-user-ids
"Materialize the rows of the files using this one as a library with
a plain query (no cursor), so no write transaction needs to stay
open while their file data is loaded."
[cfg library-id]
(db/exec! cfg [sql:get-files-for-library library-id]))
deleted-components
(ctkl/deleted-components-seq data)
(defn- find-used-components
"Compute the set of deleted component ids still in use by library
users. Every user file is loaded on its own connection, outside any
write transaction. Skips the scan entirely when there is nothing
deleted to collect."
[cfg file-id deleted-components]
(if (seq deleted-components)
(let [file-xform (mapcat (partial get-used-components deleted-components file-id))
library-xform (comp
(map :id)
;; Sanitize on load like the read path does:
;; instance-of? compares with =, so text ids
;; would miss real uses and delete live data.
(map #(-> (bfc/get-file cfg % :realize? true :read-only? true)
(update :data ctf/sanitize-file-data)))
file-xform)]
(->> (get-library-user-ids cfg file-id)
(transduce library-xform conj #{})))
#{}))
(defn- process-deleted-components
"Performs the garbage collection of unreferenced deleted components.
Takes the set of component ids still used by library users and the
deleted components, both computed beforehand outside any write
transaction. The revn guard protects against changes to this file,
but not against a library user starting to use a deleted component
between the scan and the write: that race pre-dates this refactor
and is accepted here."
[used-remote deleted-components {:keys [id] :as file}]
(let [file-id id
file-xform
(mapcat (partial get-used-components deleted-components file-id))
library-xform
(comp
(map :id)
(map #(bfc/get-file cfg % :realize? true :read-only? true))
file-xform)
used-remote
(->> (db/plan conn [sql:get-files-for-library file-id] {:fetch-size 1})
(transduce library-xform conj #{}))
used-local
(into #{} file-xform [file])
@ -181,59 +202,159 @@
(comp (map :data)
(mapcat feat.fdata/get-used-pointer-ids)))
(defn- clean-fragments!
(defn- process-fragments
[{:keys [::db/conn ::timestamp]} {:keys [id] :as file}]
(let [used (into #{} xf:collect-pointers [file])
unused (->> (db/exec! conn [sql:mark-deleted-data-fragments timestamp id
(db/create-array conn "uuid" used)])
(into #{} bfc/xf-map-id))]
(doseq [id unused]
(doseq [fragment-id unused]
(l/trc :obj "fragment"
:file-id (str id)
:id (str id)))
:file-id (str (:id file))
:id (str fragment-id)))
file))
(defn- clean-media!
[cfg file]
(defn- process-media
[cfg used-remote deleted-components file]
(let [file (->> file
(clean-deleted-components! cfg)
(clean-file-media! cfg)
(clean-file-thumbnails! cfg)
(clean-file-object-thumbnails! cfg))]
(process-deleted-components used-remote deleted-components)
(process-file-media cfg)
(process-file-thumbnails cfg)
(process-file-object-thumbnails cfg))]
;; Write guard (kept alongside the fast-fail gate in repair-file):
;; the snapshot about to be persisted must be schema-valid, no
;; matter what the repair produced.
(cfv/validate-file-schema! file)
file))
(defn get-file
[cfg {:keys [file-id revn]}]
(let [file (bfc/get-file cfg file-id
:realize? true
:skip-locked? true
:lock-for-update? true)]
(defn- get-file
"Plain read of the file: no row lock, no writes. Sanitizes first so
legacy migrations do not choke on unconverted types, then migrates
in memory and checks the scheduled revn against the stored one.
This sanitize is the single canonical pass on the GC path: repair
and cleaning downstream work on already-sanitized data, so
bfl/clean-file deliberately does not sanitize again. Returns a map
with the migrated file and the (delayed, lazily realized) resolved
libraries, or nil when the file is gone or the revn does not match.
Resolving once here and reusing the map downstream avoids running
the recursive library query twice per file. Migrations apply in
memory on this read and persist with the write transaction
whenever the row lock commits, even on no-change runs that only
store the trimmed mark. Also returns the decoded pre-sanitize
:data as :orig-data, so the write phase can tell a real change
from a no-op."
[cfg {:keys [file-id] :as props}]
(when-let [file (bfc/get-file cfg file-id
:realize? true
:migrate? false
:throw-if-not-exists? false)]
;; We should ensure that the scheduled file and the procesing file
;; has not changed since schedule, for this reason we check the
;; revn from props with the revn from retrieved file from database
(when (or (nil? revn) (= revn (:revn file)))
file)))
;; revn from props with the revn from retrieved file from database.
;; The check runs before sanitizing and migrating, so a stale
;; scheduled revn skips that work instead of discarding it.
;; TODO(2.20): drop the nil-revn tolerance once task props always
;; carry revn (enforced upstream in develop); every caller already
;; passes it through run-file-gc!/repair-file!.
(when (or (nil? (:revn props)) (= (:revn props) (:revn file)))
(let [libs (delay (bfc/get-resolved-file-libraries cfg file))
orig-data (:data file)
;; Migrate only when pending: without diff, migrate ends
;; in a full schema walk plus legacy feature migration.
;; Sanitize above stays unconditional: validation and
;; repair need it in memory.
file (cond-> (update file :data ctf/sanitize-file-data)
(fmg/need-migration? file)
(fmg/migrate-file libs))]
{:file file
:libs libs
:orig-data orig-data}))))
;; FIXME: we should skip files that does not match the revn on the
;; props and add proper schema for this task props
(defn- repair-file
"In-memory repair of a file snapshot: run the semantic repair loop
when validation reports errors and check the schema of the result.
Takes no lock and writes nothing; the write transaction persists
the snapshot later. A file that is still invalid after the repair
(by schema or by semantics) never reaches the write phase: the
schema gate and the no-convergence gate below raise instead, so it
is never marked as cleaned and a human can fix the file by hand.
Returns the repaired file."
[file libs]
;; Libraries resolve lazily through the weak map;
;; each one realizes on load with its own loader,
;; so validation needs no ambient *load-fn*.
(let [file (cfr/repair-loop (bfl/clean-file file) libs)]
;; Fast-fail gate (kept alongside the write guard in
;; process-media): a file that is still schema-invalid after the
;; repair never pays the expensive library-user scan.
(cfv/validate-file-schema! file)
;; No-convergence gate: the repair loop returns the input
;; unchanged when it cannot make the file clean (see
;; cfr/repair-loop), so semantic errors may still remain. A file
;; like that must not be stored as clean: raise with the codes
;; so the handler classifies the run as :unfixable, the file
;; stays unmarked and the scheduler retries it later.
;; Semantic re-validation costs one extra validation pass per
;; run: accepted in exchange for never persisting a partial
;; cleanup as clean.
(let [errors (not-empty (cfv/validate-file file libs))]
(when errors
(l/warn :hint "file still invalid after repair"
:file-id (str (:id file))
:codes (frequencies (mapv :code errors)))
(ex/raise :type :validation
:code :repair-did-not-converge
:hint "file did not converge after repair"
:file-id (:id file)
:details (mapv #(select-keys % [:code :hint]) errors))))
file))
(defn- process-file!
[cfg {:keys [file-id] :as props}]
(if-let [file (get-file cfg props)]
(let [file (->> file
(bfl/clean-file)
(clean-media! cfg)
(clean-fragments! cfg))
file (assoc file :has-media-trimmed true)]
(def ^:private sql:lock-file-revn
"SELECT f.revn FROM file AS f WHERE f.id = ? AND f.deleted_at IS NULL FOR UPDATE OF f SKIP LOCKED")
(defn- lock-file-revn
"Take the row lock and return the current revn, or nil when the row
is locked elsewhere or gone."
[conn id]
(:revn (db/exec-one! conn [sql:lock-file-revn id])))
(defn- process-file
"The write transaction: take the row lock, check nobody modified
the file since it was read, and run the garbage collection on its
snapshot instead of re-reading it. The snapshot arrives already
cleaned from the repair step, so this only collects, marks and
persists. Takes the components still in use by library users and
the deleted components (both as component maps; ids are extracted
inside), both computed beforehand outside any write transaction,
then the repaired file and its data as decoded before sanitize
(:orig-data) to detect a real change: modified-at is only touched
when the persisted snapshot differs, but the trim flag is always
persisted so the scheduler does not retry the file. Never bumps
revn: a new revision here would orphan the current thumbnail row,
which the file list joins on."
[{:keys [::db/conn ::timestamp] :as cfg} used-remote deleted-components {:keys [id revn] :as file} orig-data]
(if (= revn (lock-file-revn conn id))
(let [processed (->> file
(process-media cfg used-remote deleted-components)
(process-fragments cfg))
;; Touch modified-at only on real change: a no-op run still
;; marks the file as trimmed (that is the point of the run)
;; but must not look like a new version to clients holding
;; an ETag.
changed? (not (= orig-data (:data processed)))
file (-> processed
(cond-> changed? (assoc :modified-at timestamp))
(assoc :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))
;; :stale-revn covers both causes: the file changed since the
;; read, or the row is locked elsewhere and SKIP LOCKED skipped
;; it. Either way the scheduler retries the file later.
(l/dbg :hint "skip cleaning, file changed or locked since repair" :file-id (str id))
false)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -248,23 +369,62 @@
(defmethod ig/init-key ::handler
[_ cfg]
(fn [{:keys [props] :as task}]
(try
(-> cfg
(assoc ::db/rollback (:rollback? props))
(db/tx-run! (fn [{:keys [::db/conn] :as cfg}]
(let [cfg (-> cfg
(update ::sto/storage sto/configure conn)
(assoc ::timestamp (ct/now)))
processed? (process-file! cfg props)]
(when (and processed? (contains? cf/flags :tiered-file-data-storage))
(wrk/submit! (-> cfg
(assoc ::wrk/task :offload-file-data)
(assoc ::wrk/params props)
(assoc ::wrk/priority 10)
(assoc ::wrk/delay 1000))))
processed?))))
(catch Throwable cause
(l/err :hint "error on cleaning file"
:file-id (str (:file-id props))
:cause cause)))))
;; Deliberately no sto/configure here: file-data persistence
;; resolves storage without ::db/reuse-conn, so put-object!
;; commits in its own transaction. A rolled-back run can leave
;; an unreferenced storage row, which deduplication reuses and
;; storage gc reaps; this avoids the opposite leak (backend
;; content with no row, which nothing would reap).
(let [cfg (-> cfg
(assoc ::db/rollback (:rollback? props))
(assoc ::timestamp (ct/now)))
result (try
(let [{:keys [file libs orig-data]} (get-file cfg props)
repaired (some-> file
(repair-file @libs))]
(if repaired
(let [deleted-components (ctkl/deleted-components-seq (:data repaired))
used-remote (find-used-components cfg (:id repaired) deleted-components)
cleaned? (db/tx-run! cfg process-file used-remote deleted-components repaired orig-data)]
{:cleaned cleaned? :file-id (:id file)
:reason (if cleaned? :cleaned :stale-revn)})
{:cleaned false :file-id (:file-id props)
;; Existence check only: fetch the identity columns
;; so a big legacy blob is never read for this
;; answer (:deleted-at stays so soft-deleted
;; rows keep filtering out to :gone).
:reason (if (db/get* cfg :file {:id (:file-id props)}
::sql/columns [:id :deleted-at])
:stale-revn
:gone)}))
(catch Throwable cause
;; Data failures (:validation from validate!/report-error,
;; :data-validation from schema checks like the one in
;; repair-file) are unfixable; anything else (DB,
;; storage, asserts) is transient. Neither marks the
;; file, so the scheduler retries the run later.
(let [edata (ex-data cause)
reason (if (or (= :validation (:type edata))
(= :data-validation (:code edata)))
:unfixable
:error)]
(l/err :hint "error on cleaning file"
:file-id (str (:file-id props))
:cause cause)
{:cleaned false :reason reason :file-id (:file-id props)})))]
;; The offload submit runs outside the result try/catch: a queue
;; failure after a successful write must not falsify the
;; cleaning outcome (the file is already marked trimmed, so no
;; retry would recover the dropped offload either way).
(when (and (:cleaned result) (contains? cf/flags :tiered-file-data-storage))
(try
(wrk/submit! (-> cfg
(assoc ::wrk/task :offload-file-data)
(assoc ::wrk/params props)
(assoc ::wrk/priority 10)
(assoc ::wrk/delay 1000)))
(catch Throwable cause
(l/err :hint "error submitting file-gc offload"
:file-id (str (:file-id props))
:cause cause))))
result)))

View File

@ -580,6 +580,13 @@
[& params]
(apply db/get* *pool* params))
(defn run-file-gc!
"Run the file-gc task the way the scheduler does: props always carry
the current revn, so the read-time freshness check has a baseline."
[file-id]
(run-task! :file-gc {:file-id file-id
:revn (:revn (db-get :file {:id file-id}))}))
(defn sleep
[ms-or-duration]
(Thread/sleep (inst-ms (ct/duration ms-or-duration))))

View File

@ -0,0 +1,915 @@
;; 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.rpc-file-gc-repair-test
"Regression tests for file-gc on files whose stored data fails schema
validation (see https://github.com/penpot/penpot/issues/12433)."
(:require
[app.binfile.common :as bfc]
[app.common.features :as cfeat]
[app.common.files.repair :as cfr]
[app.common.files.validate :as cfv]
[app.common.logging :as l]
[app.common.test-helpers.files :as thf]
[app.common.time :as ct]
[app.common.types.components-list :as ctkl]
[app.common.types.shape :as cts]
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
[app.rpc :as-alias rpc]
[app.srepl.procs.file-repair :as procs-repair]
[app.tasks.file-gc :as file-gc]
[app.worker :as wrk]
[backend-tests.helpers :as th]
[clojure.test :as t]))
(t/use-fixtures :once th/state-init)
(t/use-fixtures :each th/database-reset)
(defn- wait-for-log
"First captured log record matching pred, waiting up to the
deadline because logging is asynchronous."
[records pred]
(let [deadline (+ (System/currentTimeMillis) 5000)]
(loop []
(if-let [record (first (filter pred @records))]
record
(when (< (System/currentTimeMillis) deadline)
(Thread/sleep 10)
(recur))))))
(defn- error-with-hint
"Log record predicate: an error log with the given hint."
[hint]
(fn [record]
(let [props (:app.common.logging/props record)]
(and (= :error (:app.common.logging/level record))
(= hint (get props :hint))))))
(defn- apply-file-changes
[& {: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- read-file
[file-id]
(db/run! th/*system*
(fn [cfg]
(bfc/get-file cfg file-id :realize? true))))
(defn- persist-file
[file]
(db/tx-run! th/*system*
(fn [cfg]
(bfc/update-file! cfg file))))
(defn- repair-file!
"Run the read and repair phases the way the task does: plain read
with the current revn as baseline, then in-memory repair on the
once-resolved libraries."
[file-id]
(let [props {:file-id file-id
:revn (:revn (th/db-get :file {:id file-id}))}
{:keys [file libs]} (#'file-gc/get-file th/*system* props)]
(some-> file
(#'file-gc/repair-file @libs))))
(defn- run-process-file!
"Run the write phase alone on a repaired snapshot, mirroring the
handler: timestamp set once, expensive scan outside the write
transaction. Takes the snapshot's pre-sanitize data to decide the
modified-at touch, like the handler does. The default only fits
abort paths (no write happens there): anyone testing the write
passes the pre-change data explicitly."
[file & [orig-data]]
(let [cfg (assoc th/*system* :app.tasks.file-gc/timestamp (ct/now))
deleted-components (ctkl/deleted-components-seq (:data file))
used-remote (#'file-gc/find-used-components cfg (:id file) deleted-components)
orig-data (or orig-data (:data file))]
(db/tx-run! cfg #'file-gc/process-file used-remote deleted-components file orig-data)))
(defn- backdate-modified-at!
"Push a file's modified-at far into the past so a later touch is
deterministic: same-millisecond comparisons would be flaky."
[file-id]
(th/db-update! :file {:modified-at (ct/minus (ct/now) {:days 30})} {:id file-id}))
(defn- corrupt-with-nil-page
"Mirrors production files where the `:pages` vector holds nil and
`:pages-index` holds a nil key (see legacy-57, already applied on
those files, so the nils came back through a write path)."
[data]
(-> data
(update :pages conj nil)
(assoc-in [:pages-index nil] {:id nil :name "ghost" :objects {}})))
(defn- setup-file-with-rect
[profile file]
(let [page-id (first (:pages (:data file)))
shape-id (uuid/next)]
(apply-file-changes
:profile-id (:id profile)
:file-id (:id file)
: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})}])
(:id file)))
(defn- instantiate-component
"Adds a copy of the library component to the given file."
[profile file library-id component-id]
(let [page-id (first (:pages (:data file)))
shape-id (uuid/next)]
(apply-file-changes
:profile-id (:id profile)
:file-id (:id file)
: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 "Board"
:frame-id uuid/zero
:parent-id uuid/zero
:type :frame
:main-instance false
:component-root true
:component-file library-id
:component-id component-id})}])
shape-id))
(defn- add-library-component
"Adds a component (with its main instance) to the library file.
Returns the map with the main shape id and the component id."
[profile library component-name]
(let [lib-page-id (first (get-in library [:data :pages]))
shape-id (uuid/next)
component-id (uuid/next)]
(apply-file-changes
:profile-id (:id profile)
:file-id (:id library)
:changes [{:type :add-obj
:page-id lib-page-id
:id shape-id
:parent-id uuid/zero
:frame-id uuid/zero
:components-v2 true
:obj (cts/setup-shape
{:id shape-id
:name "Board"
:frame-id uuid/zero
:parent-id uuid/zero
:type :frame
:main-instance true
:component-root true
:component-file (:id library)
:component-id component-id})}
{:type :add-component
:path ""
:name component-name
:main-instance-id shape-id
:main-instance-page lib-page-id
:id component-id
:anotation nil}])
{:shape-id shape-id :component-id component-id :page-id lib-page-id}))
(t/deftest file-gc-cleans-library-used-by-several-files
(let [profile (th/create-profile* 1)
library (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared true})
users (mapv (fn [i]
(th/create-file* i {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared false}))
[2 3 4])
_ (doseq [user users]
(th/link-file-to-library*
{:file-id (:id user)
:library-id (:id library)}))
used (add-library-component profile library "Used")
unused (add-library-component profile library "Unused")]
;; Only the used component is instantiated in the user files.
(doseq [user users]
(instantiate-component profile user (:id library) (:component-id used)))
;; Delete both components (and their mains) from the library.
(doseq [{:keys [component-id page-id shape-id]} [used unused]]
(apply-file-changes
:profile-id (:id profile)
:file-id (:id library)
:changes [{:type :del-component :id component-id}
{:type :del-obj :page-id page-id :id shape-id
:ignore-touched true}]))
;; The scan over library users must not hold a write transaction
;; open (it used to hold a db/plan cursor while loading every
;; user file, tripping idle-in-transaction timeouts in prod).
(t/testing "file-gc cleans a library used by several files"
(t/is (true? (:cleaned (th/run-file-gc! (:id library)))))
(let [components (get-in (read-file (:id library)) [:data :components])]
(t/is (contains? components (:component-id used))
"component still used by library users is preserved")
(t/is (not (contains? components (:component-id unused)))
"component used nowhere is deleted"))
(t/is (true? (:has-media-trimmed (th/db-get :file {:id (:id library)})))))))
(t/deftest file-gc-repairs-unconverted-schema-types-before-cleaning
(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 (setup-file-with-rect profile file)]
;; Corrupt the stored data the way production files look today and
;; persist it through the real (non-validating) write path.
(-> (read-file file-id)
(update :data thf/corrupt-shape-types)
(persist-file))
;; Pin the failure cause: the persisted file is schema-invalid.
(t/is (thrown-with-msg? clojure.lang.ExceptionInfo #"invalid file data"
(cfv/validate-file-schema! (read-file file-id))))
;; The file reads fine (no migration pending) but must fail at
;; clean-media validation until the repair is implemented.
(backdate-modified-at! file-id)
(t/testing "file-gc repairs schema-invalid types and completes"
(let [revn-before (:revn (th/db-get :file {:id file-id}))
modified-before (:modified-at (th/db-get :file {:id file-id}))]
(t/is (true? (:cleaned (th/run-file-gc! file-id))))
(t/is (= revn-before (:revn (th/db-get :file {:id file-id})))
"curing data does not mint a new version")
(t/is (ct/is-after? (:modified-at (th/db-get :file {:id file-id})) modified-before)
"the cure touches modified-at so the ETag invalidates")
(t/is (some? (cfv/validate-file-schema! (read-file file-id)))
"the healed data was still persisted")
(t/is (true? (:has-media-trimmed (th/db-get :file {:id file-id}))))))))
(t/deftest file-gc-repairs-nil-pages-that-fail-at-migration
(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 (setup-file-with-rect profile file)]
(-> (read-file file-id)
(update :data corrupt-with-nil-page)
(persist-file))
;; Force the read-time migration check by dropping the applied
;; migrations, mirroring production files that fail inside
;; get-file/migrate-file before cleaning ever starts.
(th/db-delete! :file-migration {:file-id file-id})
;; Since the 0027 migration heals nil pages, the read now
;; succeeds where it used to throw invalid file data.
(backdate-modified-at! file-id)
(t/testing "file-gc repairs nil pages and completes"
(let [revn-before (:revn (th/db-get :file {:id file-id}))
modified-before (:modified-at (th/db-get :file {:id file-id}))]
(t/is (true? (:cleaned (th/run-file-gc! file-id))))
(t/is (= revn-before (:revn (th/db-get :file {:id file-id})))
"curing data does not mint a new version")
(t/is (ct/is-after? (:modified-at (th/db-get :file {:id file-id})) modified-before)
"the cure touches modified-at so the ETag invalidates")
(t/is (some? (cfv/validate-file-schema! (read-file file-id)))
"the healed data was still persisted")
(t/is (true? (:has-media-trimmed (th/db-get :file {:id file-id}))))))))
(t/deftest file-gc-leaves-pristine-file-at-same-revn
;; A pristine file has nothing to repair or collect: the run marks
;; it trimmed without minting a new version.
(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 (setup-file-with-rect profile file)]
(let [revn-before (:revn (th/db-get :file {:id file-id}))
modified-before (:modified-at (th/db-get :file {:id file-id}))
result (th/run-file-gc! file-id)]
(t/is (true? (:cleaned result)))
(t/is (= :cleaned (:reason result)))
(t/is (= revn-before (:revn (th/db-get :file {:id file-id})))
"a no-op GC run does not mint a new version")
(t/is (= modified-before (:modified-at (th/db-get :file {:id file-id})))
"a no-op GC run touches nothing")
(t/is (true? (:has-media-trimmed (th/db-get :file {:id file-id})))
"the file is marked as trimmed"))))
(defn- corrupt-with-unknown-type
"Corruption no migration can heal: an unknown shape type. The file
must keep failing loudly instead of being silently rewritten."
[data page-id shape-id]
(assoc-in data [:pages-index page-id :objects shape-id :type] "triangle"))
(t/deftest file-gc-read-does-not-persist-without-repair
;; White-box: read and repair return the sanitized snapshot but
;; write nothing when the repair loop finds no errors; only the
;; write phase persists.
(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 (setup-file-with-rect profile file)
file (read-file file-id)
page-id (first (:pages (:data file)))
shape-id (first (remove #{uuid/zero}
(filter uuid? (keys (get-in file [:data :pages-index page-id :objects])))))]
(t/is (some? shape-id) "a non-root shape exists")
(-> (read-file file-id)
(update :data thf/corrupt-shape-types)
(persist-file))
(let [revn-before (:revn (th/db-get :file {:id file-id}))
repaired (repair-file! file-id)]
(t/is (some? repaired) "read and repair return the snapshot")
(t/testing "read and repair persist nothing"
(t/is (= revn-before (:revn (th/db-get :file {:id file-id})))
"the stored revn is untouched")
;; Stored keys keep the corrupted forms (strings in
;; pages-index, keywords in objects): decode does not
;; normalize them, sanitize does the value coercion.
(t/is (= "rect" (get-in (read-file file-id)
[:data :pages-index (str page-id) :objects (keyword (str shape-id)) :type]))
"the stored data keeps the unconverted type")
(let [shapes (vals (get-in repaired [:data :pages-index page-id :objects]))
rect (first (filter #(= "rect" (:name %)) shapes))]
(t/is (some? rect) "the snapshot keeps the shape")
(t/is (= :rect (:type rect))
"the returned snapshot is sanitized"))))))
(t/deftest file-gc-gives-up-cleanly-on-unfixable-file
(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 (setup-file-with-rect profile file)
file (read-file file-id)
page-id (first (:pages (:data file)))
shape-id (first (remove #{uuid/zero}
(filter uuid? (keys (get-in file [:data :pages-index page-id :objects])))))]
(t/is (some? shape-id) "a non-root shape exists")
(-> (read-file file-id)
(update :data #(corrupt-with-unknown-type % page-id shape-id))
(persist-file))
;; Force the read-time migration check: the single read path
;; cannot fix an unknown type.
(th/db-delete! :file-migration {:file-id file-id})
(let [revn-before (:revn (th/db-get :file {:id file-id}))
records (atom [])
_ (add-watch l/log-record ::capture
(fn [_ _ _ record] (swap! records conj record)))]
(try
(let [result (th/run-file-gc! file-id)
;; Keep the watch installed while waiting: log emission
;; is asynchronous, removing it right after run-task!
;; would drop the record before it arrives.
cleaning (wait-for-log records (error-with-hint "error on cleaning file"))]
;; The repair failure propagates to the outer handler catch:
;; loud in Loki, never half-persisted. No phased wrapper
;; anymore: the raw cause reaches the log with its stack
;; trace. The handler reports the outcome instead of nil so
;; the cause travels with the result.
(t/testing "file-gc gives up cleanly on unfixable files"
(t/is (false? (:cleaned result)))
(t/is (= :unfixable (:reason result))
"the cause travels with the result")
(t/is (= file-id (:file-id result)))
(t/is (false? (:has-media-trimmed (th/db-get :file {:id file-id})))
"file is not marked as trimmed")
(t/is (= revn-before (:revn (th/db-get :file {:id file-id})))
"no half transaction was persisted")
(t/is (some? cleaning)
"the failure is reported")))
(finally
(remove-watch l/log-record ::capture))))))
(defn- corrupt-with-broken-child
"Semantic breakage that repair-file heals: a dangling child id on the
root shape. Validation reports :child-not-found and the repair drops
the id, so the file is clean afterwards."
[data page-id]
(update-in data [:pages-index page-id :objects uuid/zero :shapes] conj (uuid/next)))
(t/deftest file-gc-write-aborts-when-file-changed
;; White-box: the handler always reads and writes back to back, so
;; the revn-abort is only isolable by calling run-process-file!
;; directly.
(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 (setup-file-with-rect profile file)
page-id (first (:pages (:data (read-file file-id))))]
(-> (read-file file-id)
(update :data #(corrupt-with-broken-child % page-id))
(persist-file))
(let [repaired (repair-file! file-id)]
(t/is (some? repaired) "read and repair return the file")
;; Concurrent write after the read, based on the stored revn:
;; the snapshot still carries it untouched.
(let [stored-revn (:revn (th/db-get :file {:id file-id}))]
;; Concurrent write after the read: bump revn through the real RPC path.
(apply-file-changes
:profile-id (:id profile)
:file-id file-id
:revn stored-revn
:changes [{:type :mod-page :id page-id :name "bumped"}])
(let [revn-after-bump (:revn (th/db-get :file {:id file-id}))
result (run-process-file! repaired)]
(t/testing "the write aborts on stale revn without writing"
(t/is (false? result))
(t/is (false? (:has-media-trimmed (th/db-get :file {:id file-id})))
"the file is not marked as trimmed")
(t/is (= revn-after-bump (:revn (th/db-get :file {:id file-id})))
"the write persisted nothing")
(t/is (> revn-after-bump stored-revn)
"the concurrent bump is still there")))))))
(t/deftest file-gc-write-skips-when-file-deleted
;; White-box like the stale-revn test: delete the file after the
;; read and call run-process-file! directly with its snapshot. The
;; light row lock sees the deleted row and the write skips without
;; writing.
(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 (setup-file-with-rect profile file)]
(let [repaired (repair-file! file-id)]
(t/is (some? repaired) "read and repair return the file")
(th/db-update! :file {:deleted-at (ct/now)} {:id file-id})
(let [result (run-process-file! repaired)
row (th/db-get :file {:id file-id} {::db/remove-deleted false})]
(t/testing "the write skips a file deleted after the read without writing"
(t/is (false? result))
(t/is (some? (:deleted-at row)) "still deleted")
(t/is (false? (:has-media-trimmed row))
"the file is not marked as trimmed"))))))
(t/deftest file-gc-write-persists-the-repair
;; White-box: read and repair work in memory and write nothing;
;; only the write phase persists. Direct phase calls isolate each
;; side, the handler always runs them together.
(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 (setup-file-with-rect profile file)
file (read-file file-id)
page-id (first (:pages (:data file)))]
(let [corrupted (-> (read-file file-id)
(update :data #(corrupt-with-broken-child % page-id)))]
(persist-file corrupted)
(let [stored-before (th/db-get :file {:id file-id})
repaired (repair-file! file-id)]
(t/is (some? repaired) "read and repair return the snapshot")
(t/testing "read and repair persist nothing"
(t/is (= (:revn stored-before) (:revn (th/db-get :file {:id file-id})))
"the stored revn is untouched")
(t/is (nil? (cfv/validate-file repaired {}))
"the snapshot validates clean"))
(backdate-modified-at! file-id)
(t/testing "the write persists the repair"
(t/is (true? (run-process-file! repaired (:data corrupted))))
(let [row-after-write (th/db-get :file {:id file-id})]
(t/is (= (:revn stored-before) (:revn row-after-write))
"a GC write never mints a new version")
(t/is (ct/is-after? (:modified-at row-after-write) (:modified-at stored-before))
"persisting changed data touches modified-at")
(t/is (nil? (cfv/validate-file (read-file file-id) {}))
"the persisted file validates clean")
(t/is (true? (:has-media-trimmed row-after-write))
"the file is marked as trimmed")))))))
(t/deftest file-gc-cleans-without-revn-in-props
;; Pins the nil-revn tolerance in get-file (TODO(2.20)): props without
;; revn still clean. No bump at all anymore: the run only touches
;; modified-at when the persisted snapshot differs (change-on-clean).
;; If the tolerance is ever dropped, this test fails and must change
;; together with the behavior.
(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 (setup-file-with-rect profile file)
page-id (first (:pages (:data (read-file file-id))))]
(-> (read-file file-id)
(update :data #(corrupt-with-broken-child % page-id))
(persist-file))
(backdate-modified-at! file-id)
(let [revn-before (:revn (th/db-get :file {:id file-id}))
modified-before (:modified-at (th/db-get :file {:id file-id}))
result (th/run-task! :file-gc {:file-id file-id})]
(t/is (true? (:cleaned result))
"the file is cleaned without revn in props")
(t/is (= revn-before (:revn (th/db-get :file {:id file-id})))
"a GC write never mints a new version")
(t/is (ct/is-after? (:modified-at (th/db-get :file {:id file-id})) modified-before)
"persisting changed data touches modified-at")
(t/is (true? (:has-media-trimmed (th/db-get :file {:id file-id})))
"the file is marked as trimmed"))))
(t/deftest file-gc-skips-soft-deleted-file-without-error
;; A file soft-deleted between scheduling and running is a normal
;; race: the read returns nil through the plain path and the handler
;; reports {:cleaned false :reason :gone}, without logging an ERROR.
(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 (setup-file-with-rect profile file)
revn (:revn (th/db-get :file {:id file-id}))]
(th/db-update! :file {:deleted-at (ct/now)} {:id file-id})
(let [records (atom [])
_ (add-watch l/log-record ::capture
(fn [_ _ _ record] (swap! records conj record)))]
(try
(let [result (th/run-task! :file-gc {:file-id file-id :revn revn})]
;; Log emission is asynchronous: give a late ERROR the
;; chance to arrive before asserting its absence.
(th/sleep 1000)
(let [cleaning-errors (filter (error-with-hint "error on cleaning file") @records)]
(t/testing "a file deleted after scheduling is skipped quietly"
(t/is (false? (:cleaned result))
"the file is reported as not cleaned, not nil")
(t/is (= :gone (:reason result))
"the cause travels with the result")
(t/is (= file-id (:file-id result))
"the file id is echoed back")
(t/is (empty? cleaning-errors)
"no ERROR is logged for this normal race"))))
(finally
(remove-watch l/log-record ::capture))))))
(t/deftest file-gc-skips-when-props-revn-is-stale
;; A file modified between scheduling and running is a normal
;; race: the read-time revn check returns nil and the handler
;; reports {:cleaned false :reason :stale-revn} quietly, leaving
;; the file pending so the scheduler retries it later.
(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 (setup-file-with-rect profile file)
stale-revn (:revn (th/db-get :file {:id file-id}))
page-id (first (:pages (:data (read-file file-id))))]
;; Concurrent write through the real RPC path.
(apply-file-changes
:profile-id (:id profile)
:file-id file-id
:revn stale-revn
:changes [{:type :mod-page :id page-id :name "bumped"}])
(let [result (th/run-task! :file-gc {:file-id file-id :revn stale-revn})]
(t/testing "a file changed after scheduling is skipped quietly"
(t/is (false? (:cleaned result))
"the file is reported as not cleaned")
(t/is (= :stale-revn (:reason result))
"the cause travels with the result")
(t/is (= file-id (:file-id result))
"the file id is echoed back")
(t/is (false? (:has-media-trimmed (th/db-get :file {:id file-id})))
"the file is not marked as trimmed")))))
(t/deftest srepl-repair-delegate-repairs-like-the-shared-loop
;; Regression: procs/repair-file is called by h/process-file! with
;; a positional opts map lacking :max-iterations. It must repair
;; like the shared loop instead of silently returning the input.
(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 (setup-file-with-rect profile file)
page-id (first (:pages (:data (read-file file-id))))
broken (-> (read-file file-id)
(update :data #(corrupt-with-broken-child % page-id)))]
(t/is (some? (seq (cfv/validate-file broken {})))
"the file is broken")
(let [fixed (procs-repair/repair-file broken {} {:rollback? true})]
(t/is (nil? (cfv/validate-file fixed {}))
"the delegate converges like the shared loop"))
(t/testing "the delegate also heals unconverted types once sanitized"
(let [unconverted (-> (read-file file-id)
(update :data thf/corrupt-shape-types))
fixed (procs-repair/repair-file unconverted {})]
(t/is (false? (identical? unconverted fixed))
"sanitize lets the loop converge instead of returning the input")
(t/is (nil? (cfv/validate-file fixed {}))
"the healed snapshot validates clean")))))
(t/deftest file-gc-offload-failure-keeps-truthful-result
;; A submit! failure after a successful write must not falsify the
;; outcome: the file is clean, so the handler reports cleaned and
;; logs the offload error instead of claiming unfixable.
(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 (setup-file-with-rect profile file)]
(let [records (atom [])
_ (add-watch l/log-record ::capture
(fn [_ _ _ record] (swap! records conj record)))]
(try
(let [result (with-redefs [cf/flags (conj cf/flags :tiered-file-data-storage)
wrk/submit! (fn [_] (throw (ex-info "redis down" {})))]
(th/run-file-gc! file-id))
;; Keep the watch installed while waiting: log emission
;; is asynchronous, removing it right after run-file-gc!
;; would drop the record before it arrives.
offload (wait-for-log records (error-with-hint "error submitting file-gc offload"))]
(t/testing "a failed offload keeps the truthful cleaning result"
(t/is (true? (:cleaned result)))
(t/is (= :cleaned (:reason result))
"the result describes the file, not the queue")
(t/is (= file-id (:file-id result)))
(t/is (true? (:has-media-trimmed (th/db-get :file {:id file-id})))
"the cleaning was persisted")
(t/is (some? offload)
"the offload failure is logged")))
(finally
(remove-watch l/log-record ::capture))))))
(t/deftest file-gc-survives-unsanitized-libraries
;; A library with decoder leftovers (text ids, string types) breaks
;; ref resolution; the GC must sanitize libraries on load instead of
;; detaching the copies that point at them.
(let [profile (th/create-profile* 1)
library (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared true})
user (th/create-file* 2 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared false})
_ (th/link-file-to-library*
{:file-id (:id user)
:library-id (:id library)})
used (add-library-component profile library "Used")
shape-id (instantiate-component profile user (:id library) (:component-id used))]
;; The raw add-obj above bypasses component sync, so point the
;; copy at the main root like a real instantiation would.
(let [page-id (first (:pages (:data (read-file (:id user)))))]
(-> (read-file (:id user))
(assoc-in [:data :pages-index page-id :objects shape-id :shape-ref]
(:shape-id used))
(persist-file)))
;; Corrupt the library the way production data looks, then run GC
;; on the user before the library itself is ever cleaned.
(-> (read-file (:id library))
(update :data thf/corrupt-shape-types)
(persist-file))
(let [result (th/run-file-gc! (:id user))]
(t/testing "a copy on a corrupt library survives the GC"
(t/is (true? (:cleaned result)))
(let [page-id (first (:pages (:data (read-file (:id user)))))
copy (get-in (read-file (:id user))
[:data :pages-index page-id :objects shape-id])]
(t/is (some? (:component-id copy))
"the copy keeps its component")
(t/is (some? (:component-file copy))
"the copy keeps its library")
(t/is (some? (:shape-ref copy))
"the copy keeps its master ref"))))))
(t/deftest file-gc-repairs-through-loaded-library
;; The library loads lazily through the weak-map loader when the
;; user file references it. If that load throws, the repair loop
;; swallows the error and keeps the original file: nothing is
;; repaired and the run still looks clean. A linked library with a
;; remote copy must load without errors while a dangling child is
;; repaired, proving validation really ran through the loaded
;; library.
(let [profile (th/create-profile* 1)
library (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared true})
user (th/create-file* 2 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared false})
_ (th/link-file-to-library*
{:file-id (:id user)
:library-id (:id library)})
used (add-library-component profile library "Used")
shape-id (instantiate-component profile user (:id library) (:component-id used))
page-id (first (:pages (:data (read-file (:id user)))))
bogus (uuid/next)]
;; The test env enables every feature it supports on every file;
;; production never enables fdata/pointer-map. Re-persist both
;; files without it so this regression covers the data shape
;; production actually has: plain data, objects-map lazy only.
(doseq [f [library user]]
(-> (read-file (:id f))
(assoc :features (disj (set (:features f)) "fdata/pointer-map"))
(persist-file)))
;; The raw add-obj above bypasses component sync, so point the
;; copy at the main root like a real instantiation would, and
;; add a dangling child id that only validation can heal.
(-> (read-file (:id user))
(assoc-in [:data :pages-index page-id :objects shape-id :shape-ref]
(:shape-id used))
(update-in [:data :pages-index page-id :objects uuid/zero :shapes]
conj bogus)
(persist-file))
(let [result (th/run-file-gc! (:id user))]
(t/testing "validation loads the remote library and repairs locally"
(t/is (true? (:cleaned result)))
(let [data (:data (read-file (:id user)))
copy (get-in data [:pages-index page-id :objects shape-id])
root (get-in data [:pages-index page-id :objects uuid/zero])]
(t/is (some? (:component-id copy))
"the copy keeps its component")
(t/is (some? (:shape-ref copy))
"the copy keeps its master ref")
(t/is (not (contains? (set (:shapes root)) bogus))
"the dangling child was repaired, so validation ran"))))))
(t/deftest file-gc-gives-up-when-repair-does-not-converge
;; A file the repair loop cannot make clean must never be
;; persisted as a clean snapshot. The non-convergence raises, the
;; handler classifies it as :unfixable, nothing is marked and the
;; revn stays put so any manual fix has the original revision to
;; work on.
(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 (setup-file-with-rect profile file)
page-id (first (:pages (:data (read-file file-id))))]
(-> (read-file file-id)
(update :data #(corrupt-with-broken-child % page-id))
(persist-file))
(backdate-modified-at! file-id)
(let [{:keys [revn modified-at]} (th/db-get :file {:id file-id})
result (with-redefs [cfr/repair-file (fn [& _] [])]
(th/run-file-gc! file-id))]
(t/testing "the run reports the file as unfixable"
(t/is (false? (:cleaned result)))
(t/is (= :unfixable (:reason result))
"the cause travels with the result")
(t/is (= file-id (:file-id result))))
(t/testing "nothing is persisted"
(t/is (false? (:has-media-trimmed (th/db-get :file {:id file-id})))
"file is not marked as trimmed")
(t/is (= revn (:revn (th/db-get :file {:id file-id})))
"no revision was persisted")
(t/is (= modified-at (:modified-at (th/db-get :file {:id file-id})))
"no modification touch was persisted")))))
(t/deftest file-gc-scan-counts-unsanitized-copies-as-used
;; Same corruption family on the consuming side: a user file with
;; text ids makes instance-of? miss, so the scan must sanitize
;; before asking who uses a deleted component.
(let [profile (th/create-profile* 1)
library (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared true})
user (th/create-file* 2 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared false})
_ (th/link-file-to-library*
{:file-id (:id user)
:library-id (:id library)})
used (add-library-component profile library "Used")
shape-id (instantiate-component profile user (:id library) (:component-id used))]
;; Delete the component (and its main) from the library.
(apply-file-changes
:profile-id (:id profile)
:file-id (:id library)
:changes [{:type :del-component :id (:component-id used)}
{:type :del-obj :page-id (:page-id used) :id (:shape-id used)
:ignore-touched true}])
;; Corrupt the user the way production data looks, including the
;; component refs as text: instance-of? compares with = so the
;; copy would not count as a use without sanitizing first.
(let [page-id (first (:pages (:data (read-file (:id user)))))
obj-key (keyword (str shape-id))]
(-> (read-file (:id user))
(update :data thf/corrupt-shape-types)
(update-in [:data :pages-index (str page-id) :objects obj-key :component-id] str)
(update-in [:data :pages-index (str page-id) :objects obj-key :component-file] str)
(persist-file)))
(let [result (th/run-file-gc! (:id library))]
(t/testing "a deleted component still used counts as used"
(t/is (true? (:cleaned result)))
(t/is (contains? (get-in (read-file (:id library)) [:data :components])
(:component-id used))
"the component used by the unsanitized copy is preserved")))))
(t/deftest file-gc-scan-loads-users-outside-write-transaction
;; Pins the design rule behind the idle-in-transaction timeouts:
;; every library-user file loads on its own connection, never with
;; the write transaction held open. If the scan moves back inside,
;; the captured cfgs carry ::db/conn and this fails.
(let [profile (th/create-profile* 1)
library (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared true})
users (mapv (fn [i]
(th/create-file* i {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared false}))
[2 3])
_ (doseq [user users]
(th/link-file-to-library*
{:file-id (:id user)
:library-id (:id library)}))
used (add-library-component profile library "Used")]
(doseq [user users]
(instantiate-component profile user (:id library) (:component-id used)))
(doseq [{:keys [component-id page-id shape-id]} [used]]
(apply-file-changes
:profile-id (:id profile)
:file-id (:id library)
:changes [{:type :del-component :id component-id}
{:type :del-obj :page-id page-id :id shape-id
:ignore-touched true}]))
(let [seen (atom [])
orig bfc/get-file]
(with-redefs [bfc/get-file (fn [cfg & args]
(swap! seen conj cfg)
(apply orig cfg args))]
(t/is (true? (:cleaned (th/run-file-gc! (:id library))))))
(t/testing "user files load without a write connection"
(t/is (seq @seen) "the scan loaded files through bfc/get-file")
(t/is (every? #(nil? (::db/conn %)) @seen)
"no load happens inside the write transaction")))))
(t/deftest file-gc-reports-error-on-transient-failure
;; Unexpected failures (DB down, storage hiccup) are not data
;; corruption: they report :error so operators stop reading every
;; unfixable as a broken file. The file stays unmarked either way,
;; so the scheduler retries the run later.
(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 (setup-file-with-rect profile file)]
(let [records (atom [])
_ (add-watch l/log-record ::capture
(fn [_ _ _ record] (swap! records conj record)))]
(try
(let [result (with-redefs [db/tx-run! (fn [& _] (throw (RuntimeException. "db down")))]
(th/run-file-gc! file-id))
logged (wait-for-log records (error-with-hint "error on cleaning file"))]
(t/testing "transient failures report :error"
(t/is (false? (:cleaned result)))
(t/is (= :error (:reason result))
"the cause is not mistaken for corrupt data")
(t/is (= file-id (:file-id result)))
(t/is (false? (:has-media-trimmed (th/db-get :file {:id file-id})))
"the file is not marked as cleaned")
(t/is (some? logged)
"the failure is still loud")))
(finally
(remove-watch l/log-record ::capture))))))

View File

@ -203,7 +203,7 @@
shape-id (uuid/random)]
;; Preventive file-gc
(t/is (true? (th/run-task! :file-gc {:file-id (:id file) :revn (:revn file)})))
(t/is (true? (:cleaned (th/run-task! :file-gc {:file-id (:id file) :revn (:revn file)}))))
;; Check the number of fragments before adding the page
(let [rows (th/db-query :file-data {:file-id (:id file) :type "fragment"})]
@ -225,7 +225,7 @@
(t/is (= 3 (count rows))))
;; The file-gc should mark for remove unused fragments
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
(t/is (true? (:cleaned (th/run-file-gc! (:id file)))))
;; Check the number of fragments
(let [rows (th/db-query :file-data {:file-id (:id file) :type "fragment"})]
@ -265,7 +265,7 @@
(t/is (= 3 (count rows))))
;; The file-gc should mark for remove unused fragments
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
(t/is (true? (:cleaned (th/run-file-gc! (:id file)))))
;; The objects-gc should remove unused fragments
(let [res (th/run-task! :objects-gc {})]
@ -287,7 +287,7 @@
;; The file-gc should remove fragments related to changes
;; snapshots previously deleted.
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
(t/is (true? (:cleaned (th/run-file-gc! (:id file)))))
;; Check the number of fragments;
(let [rows (th/db-query :file-data {:file-id (:id file) :type "fragment"})]
@ -370,7 +370,7 @@
(t/is (= 0 (:delete res))))
;; run the task again
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
(t/is (true? (:cleaned (th/run-file-gc! (:id file)))))
;; retrieve file and check trimmed attribute
(let [row (th/db-get :file {:id (:id file)})]
@ -412,7 +412,7 @@
;; Now, we have deleted the usage of pointers to the
;; file-media-objects, if we paste file-gc, they should be marked
;; as deleted.
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
(t/is (true? (:cleaned (th/run-file-gc! (:id file)))))
;; This only clears fragments, the file media objects still referenced because
;; snapshots are preserved
@ -429,7 +429,7 @@
(t/is (= 4 (:processed res))))
;; Rerun the file-gc and objects-gc
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
(t/is (true? (:cleaned (th/run-file-gc! (:id file)))))
(let [res (th/run-task! :objects-gc {})]
;; this will remove the file media objects marked as deleted
@ -555,7 +555,7 @@
;; run the task again
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
(t/is (true? (:cleaned (th/run-file-gc! (:id file)))))
(let [res (th/run-task! :objects-gc {})]
(t/is (= 2 (:processed res))))
@ -599,7 +599,7 @@
;; Now, we have deleted the usage of pointers to the
;; file-media-objects, if we paste file-gc, they should be marked
;; as deleted.
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
(t/is (true? (:cleaned (th/run-file-gc! (:id file)))))
;; This only removes unused fragments, file media are still
;; referenced on snapshots.
@ -613,7 +613,7 @@
;; Rerun file-gc and objects-gc task for the same file once all snapshots are
;; "expired/deleted"
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
(t/is (true? (:cleaned (th/run-file-gc! (:id file)))))
(let [res (th/run-task! :objects-gc {})]
(t/is (= 6 (:processed res))))
@ -724,7 +724,7 @@
(t/is (= 1 (:freeze res)))
(t/is (= 0 (:delete res))))
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
(t/is (true? (:cleaned (th/run-file-gc! (:id file)))))
;; retrieve file and check trimmed attribute
(let [row (th/db-get :file {:id (:id file)})]
@ -754,7 +754,7 @@
:page-id page-id
:id frame-id-2}])
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
(t/is (true? (:cleaned (th/run-file-gc! (:id file)))))
(let [rows (th/db-query :file-tagged-object-thumbnail {:file-id file-id})]
(t/is (= 2 (count rows)))
@ -789,7 +789,7 @@
:page-id page-id
:id frame-id-1}])
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
(t/is (true? (:cleaned (th/run-file-gc! (:id file)))))
(let [rows (th/db-query :file-tagged-object-thumbnail {:file-id file-id})]
(t/is (= 1 (count rows)))
@ -1379,7 +1379,7 @@
(th/sleep 300)
;; run the task
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
(t/is (true? (:cleaned (th/run-file-gc! (:id file)))))
;; check that object thumbnails are still here
(let [rows (th/db-query :file-tagged-object-thumbnail {:file-id (:id file)})]
@ -1408,7 +1408,7 @@
(t/is (= 2 (count rows))))
;; run the task again
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
(t/is (true? (:cleaned (th/run-file-gc! (:id file)))))
;; check that we have all object thumbnails
(let [rows (th/db-query :file-tagged-object-thumbnail {:file-id (:id file)})]
@ -1471,7 +1471,7 @@
(t/is (= 2 (count rows)))))
(t/testing "gc task"
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
(t/is (true? (:cleaned (th/run-file-gc! (:id file)))))
(let [rows (th/db-query :file-thumbnail {:file-id (:id file)})]
(t/is (= 2 (count rows)))
@ -1494,7 +1494,7 @@
sobject (volatile! nil)]
;; Preventive file-gc
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
(t/is (true? (:cleaned (th/run-file-gc! (:id file)))))
;; Preventive objects-gc
(let [result (th/run-task! :objects-gc {})]
@ -1513,7 +1513,7 @@
;; Run FileGC again, with tiered storage activated
(with-redefs [app.config/flags (conj app.config/flags :tiered-file-data-storage)]
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)}))))
(t/is (true? (:cleaned (th/run-file-gc! (:id file))))))
;; The FileGC task will schedule an inner taskq
(th/run-pending-tasks!)
@ -1573,7 +1573,7 @@
;; The file-gc should mark for remove unused fragments
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
(t/is (true? (:cleaned (th/run-file-gc! (: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
@ -1690,7 +1690,7 @@
:anotation nil}])
;; Run the task again
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
(t/is (true? (:cleaned (th/run-file-gc! (:id file)))))
;; Retrieve file and check trimmed attribute
(let [row (th/db-get :file {:id (:id file)})]
@ -1736,7 +1736,7 @@
(t/is (some? (not-empty (:objects component))))))
;; Re-run the file-gc task
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
(t/is (true? (:cleaned (th/run-file-gc! (:id file)))))
(let [row (th/db-get :file {:id (:id file)})]
(t/is (true? (:has-media-trimmed row))))
@ -1766,7 +1766,7 @@
;; Now, we have deleted the usage of component if we pass file-gc,
;; that component should be deleted
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
(t/is (true? (:cleaned (th/run-file-gc! (:id file)))))
;; Check that component is properly removed
(let [data {::th/type :get-file
@ -1857,8 +1857,8 @@
:component-id c-id})}])
;; Run the file-gc on file and library
(t/is (true? (th/run-task! :file-gc {:file-id (:id file-1)})))
(t/is (true? (th/run-task! :file-gc {:file-id (:id file-2)})))
(t/is (true? (:cleaned (th/run-file-gc! (:id file-1)))))
(t/is (true? (:cleaned (th/run-file-gc! (:id file-2)))))
;; Check that component exists
(let [data {::th/type :get-file
@ -1900,7 +1900,7 @@
(t/is (some? (not-empty (:objects component))))))
;; Re-run the file-gc task
(t/is (true? (th/run-task! :file-gc {:file-id (:id file-1)})))
(t/is (true? (:cleaned (th/run-file-gc! (:id file-1)))))
;; Check that component is still there after file-gc task
(let [data {::th/type :get-file
@ -1931,7 +1931,7 @@
;; Now, we have deleted the usage of component if we pass file-gc,
;; that component should be deleted
(t/is (true? (th/run-task! :file-gc {:file-id (:id file-1)})))
(t/is (true? (:cleaned (th/run-file-gc! (:id file-1)))))
;; Check that component is properly removed
(let [data {::th/type :get-file
@ -2080,8 +2080,8 @@
(t/is (not= (:id fill) (:id fmedia)))))
;; Run the file-gc on file and library
(t/is (true? (th/run-task! :file-gc {:file-id (:id file-1)})))
(t/is (true? (th/run-task! :file-gc {:file-id (:id file-2)})))
(t/is (true? (:cleaned (th/run-file-gc! (:id file-1)))))
(t/is (true? (:cleaned (th/run-file-gc! (:id file-2)))))
;; Now proceed to delete file and absorb it
(let [data {::th/type :delete-file

View File

@ -117,7 +117,7 @@
;; Run the File GC task that should remove unused file object
;; thumbnails
(th/run-task! :file-gc {:file-id (:id file)})
(th/run-file-gc! (:id file))
(let [result (th/run-task! :objects-gc {})]
(t/is (= 3 (:processed result))))
@ -221,7 +221,7 @@
;; Run the File GC task that should remove unused file object
;; thumbnails
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
(t/is (true? (:cleaned (th/run-file-gc! (:id file)))))
(let [result (th/run-task! :objects-gc {})]
(t/is (= 2 (:processed result))))

View File

@ -853,9 +853,24 @@
(when (and id name page)
(ex/raise :type :conflict
:hint "id+name or page should be provided, never both"))
;; The undo of :add-page is :del-page with :id, so a change carrying
;; both with different ids persists one page and undoes another.
(when (and id (:id page) (not= id (:id page)))
(ex/raise :type :conflict
:hint "id and page should agree"
:id id
:page-id (:id page)))
(let [page (if (and (string? name) (uuid? id))
(ctp/make-empty-page {:id id :name name})
page)]
;; A page without a valid id would leave a nil entry in :pages
;; and a nil key in :pages-index (see legacy-57). Fail fast with
;; a structured error instead of assert: asserts are elided in
;; release CLJS builds, and this must hold there too.
(when-not (uuid? (:id page))
(ex/raise :type :validation
:hint "add-page requires a page with a valid :id"
:page-id (:id page)))
(ctpl/add-page data page)))
(defmethod process-change :mod-page

View File

@ -1998,6 +1998,14 @@
(update :pages-index d/update-vals update-container)
(d/update-when :components d/update-vals update-container))))
(defmethod migrate-data "0027-repair-unconverted-types-and-nil-pages"
;; Re-apply the legacy-57 nil page cleanup (nils came back through a
;; write path after it ran) and decode the data with the schema, which
;; converts the unconverted types left by decoders. See
;; ctf/sanitize-file-data.
[data _]
(ctf/sanitize-file-data data))
(def available-migrations
(into (d/ordered-set)
["legacy-2"
@ -2081,4 +2089,5 @@
"0023-repair-token-themes-with-inexistent-sets"
"0024b-fix-stroke-cap-placement"
"0025-repair-empty-text-content"
"0026-fix-svg-raw-shapes-uuids"]))
"0026-fix-svg-raw-shapes-uuids"
"0027-repair-unconverted-types-and-nil-pages"]))

View File

@ -7,8 +7,10 @@
(ns app.common.files.repair
(:require
[app.common.data :as d]
[app.common.files.changes :as cfc]
[app.common.files.changes-builder :as pcb]
[app.common.files.helpers :as cfh]
[app.common.files.validate :as cfv]
[app.common.logging :as log]
[app.common.path-names :as cpn]
[app.common.types.component :as ctk]
@ -801,3 +803,58 @@
(pcb/empty-changes nil)
errors)]
redo-changes))
(defn repair-loop
"Best-effort semantic repair loop over an in-memory file: validate,
apply the computed repair changes and repeat until the file
validates clean or `max-iterations` (default 10) is reached. When
it throws or does not converge, the input file is returned
untouched and the caller owns the decision (file-gc raises with
:repair-did-not-converge so nothing is persisted as clean; the
debug endpoints keep running their own single pass). Never touches
`revn`: the caller decides whether to bump it. file-gc does not:
it only touches :modified-at on real change."
[{:keys [id] :as file} libraries & {:keys [max-iterations]}]
;; NOTE: no `:or` default here on purpose: an explicit nil must
;; behave like a missing key (both come from valid call shapes),
;; and `:or` only covers the missing one. Normalize explicitly.
(let [max-iterations (or max-iterations 10)]
(try
(loop [current file
iteration 0]
(let [errors (not-empty (cfv/validate-file current libraries))]
(cond
(empty? errors)
(do
(when (pos? iteration)
(log/debug :hint "file repaired"
:file-id (str id)
:iterations iteration))
current)
(>= iteration max-iterations)
(do
(log/warn :hint "file still invalid after repair"
:file-id (str id)
:codes (frequencies (map :code errors)))
file)
:else
(let [changes (repair-file current libraries errors)]
(recur (update current :data cfc/process-changes changes)
(inc iteration))))))
(catch #?(:clj Exception :cljs js/Error) cause
(log/warn :hint "error on repairing file, keeping original"
:file-id (str (:id file))
:cause cause)
file)
;; AssertionError is not an Exception: asserts on the repair
;; path (e.g. get-shape with a non-uuid id) must also return
;; the input instead of escaping. CLJS needs no extra clause:
;; js/Error already covers everything thrown there.
#?(:clj
(catch AssertionError cause
(log/warn :hint "error on repairing file, keeping original"
:file-id (str (:id file))
:cause cause)
file)))))

View File

@ -350,12 +350,22 @@
shape file page)))
(defn- check-component-ref
"Validate that the referenced shape exists in the near component."
"Validate that the referenced shape exists in the near component.
A shape without :shape-ref is deliberately ignored here (instance
heads carry none, see get-ref-shape), so there is nothing to check
for it: without this guard the matching repair crashes on the
get-shape precondition instead of converging. Accepted consequence:
a copy root that genuinely lost its :shape-ref is neither reported
nor repaired through validate-file (debug endpoint, srepl, GC); a
dedicated repair-error for that case is tracked in
https://github.com/penpot/penpot/issues/12509."
[shape file page libraries]
(let [library-exists (library-exists? file libraries shape)
ref-shape (when library-exists
(find-ref-shape* file page libraries shape))]
(when (and library-exists (nil? ref-shape))
(when (and library-exists
(some? (:shape-ref shape))
(nil? ref-shape))
(report-error :ref-shape-not-found
(str/ffmt "Referenced shape % not found in near component" (:shape-ref shape))
shape file page))))

View File

@ -206,3 +206,37 @@
Example: (thf/dump-file file :keys [:name :swap-slot-label] :show-refs? false)"
[file & {:keys [] :as params}]
(dump-page (current-page file) params))
;; ----- Corruption builders (mirror production data)
(defn corrupt-shape-types
"Corrupt file data the way production files look when the decoder
left unconverted types: shape `:type` as text, ids as text and
object/page-map keys as text/keyword instead of uuid. Defensive:
only converts values that are still unconverted, so it is safe to
run on already-corrupted data."
[data]
(letfn [(corrupt-shape [shape]
(cond-> shape
(keyword? (:type shape))
(assoc :type (name (:type shape)))
(uuid? (:id shape))
(assoc :id (str (:id shape)))
(uuid? (:parent-id shape))
(update :parent-id str)
(uuid? (:frame-id shape))
(update :frame-id str)))
(corrupt-objects [objects]
(into {}
(map (fn [[id shape]]
[(keyword (str id)) (corrupt-shape shape)]))
objects))
(corrupt-page [[page-id page]]
[(str page-id) (update page :objects corrupt-objects)])]
(-> data
(update :pages (fn [pages] (mapv str pages)))
(update :pages-index (fn [pages-index]
(into {} (map corrupt-page) pages-index))))))

View File

@ -130,6 +130,66 @@
(def check-file-data
(sm/check-fn schema:data :hint "invalid file data"))
(def decode-file-data
"Precompiled json decoder for file data. Compiling the decoder on
every call (via `sm/decode`) costs a schema walk per file; this one
is built once at load time. See `decode-file-metadata` below for
the same pattern."
(sm/decoder schema:data sm/json-transformer))
(def decode-page-objects
"Precompiled json decoder for page `:objects` maps, used for the
explicit component-objects pass in `sanitize-file-data` (the
container schema keeps them opaque, so the top-level decode does
not descend into them)."
(sm/decoder ctp/schema:objects sm/json-transformer))
(defn sanitize-file-data
"Decode file data with the file schema and drop nil page entries,
repairing the two corruption families seen in production: types
left unconverted by decoders (strings or keywords where the schema
expects keywords or uuids) and nil page entries that reappeared
after legacy-57. The schema itself drives the coercions
(`:decode/json` on shape types, json-transformer uuid decoders), so
there is no hand-rolled type table to keep in sync. Component
objects need an explicit pass because the container schema declares
them opaque (`:map`), so the top-level decode does not descend into
them. Total and idempotent: values the schema can coerce are
coerced, even when the result is still invalid (an unknown
shape type still gets keywordized), while genuinely
unknown values are left untouched — so files with real corruption
keep failing loudly instead of being silently rewritten. When
nothing is repaired (neither nil entries nor coercions), the input
itself is returned as is, same instance: lazy containers
(objects-map) keep their identity and callers can tell a real fix
from a no-op by comparing against the input, without re-diffing.
The walk still happens on every call — the decode runs over the
whole data — because that is the only way to name the corruption
families; the no-op case saves the callers the repair bookkeeping,
not the walk. Migration 0027 applies the same recipe when pending
(idempotent, one extra pass per file, then never again)."
[data]
(let [dropped (-> data
(d/update-when :pages #(if (some nil? %)
(into (empty %) (remove nil?) %)
%))
(d/update-when :pages-index #(cond-> % (contains? % nil) (dissoc nil))))
decoded (-> (decode-file-data dropped)
;; The container schema declares :objects opaque (:map), so
;; the top-level decode does not descend into component
;; shapes. Decode them explicitly with the page objects
;; schema, which carries the same shape decoders.
(d/update-when :components (fn [components]
(d/update-vals components
(fn [component]
(d/update-when component :objects
decode-page-objects))))))]
;; Nothing repaired and no nil entries: return the input as is.
;; Same instance keeps lazy containers (objects-map) untouched,
;; avoids fake change-detection stamps, and lets callers find a
;; real fix just by comparing against the input.
(if (= decoded dropped) dropped decoded)))
(def check-file-media
(sm/check-fn schema:media))

View File

@ -24,6 +24,52 @@
(t/use-fixtures :each thi/test-fixture)
(t/deftest repair-loop-explicit-nil-max-iterations
(t/testing "explicit nil :max-iterations behaves like the default"
(let [file (-> (thf/sample-file :file1 :page-label :page1)
(thv/add-variant :variant1 :component1 :root1 :component2 :root2)
(ths/update-shape :root1 :variant-id nil))
errors (cfv/validate-file file {})]
(t/is (some? (seq errors)) "the file is broken")
(let [fixed (cfr/repair-loop file {} :max-iterations nil)]
(t/is (nil? (cfv/validate-file fixed {})) "it converges")))))
(t/deftest repair-loop-gives-up-after-max-iterations
(t/testing "errors that never clear return the input untouched"
(let [file (-> (thf/sample-file :file1 :page-label :page1)
(thv/add-variant :variant1 :component1 :root1 :component2 :root2)
(ths/update-shape :root1 :variant-id nil))]
(with-redefs [cfv/validate-file
(fn [_ _] [{:code :definitely-not-a-real-error}])]
(let [result (cfr/repair-loop file {} :max-iterations 2)]
(t/is (identical? file result)
"no convergence, no partial persist"))))))
(t/deftest repair-loop-keeps-original-on-error
(t/testing "a throwing repair returns the input untouched"
(let [file (-> (thf/sample-file :file1 :page-label :page1)
(thv/add-variant :variant1 :component1 :root1 :component2 :root2)
(ths/update-shape :root1 :variant-id nil))]
(with-redefs [cfr/repair-file
(fn [& _] (throw (ex-info "boom" {})))]
(let [result (cfr/repair-loop file {})]
(t/is (identical? file result)
"the handler decides, the loop never half-persists"))))))
;; AssertionError is a JVM Error, not an Exception, and does not
;; exist in CLJS (where js/Error catches everything): JVM-only.
#?(:clj
(t/deftest repair-loop-keeps-original-on-assertion-error
(t/testing "an assert on the repair path returns the input untouched"
(let [file (-> (thf/sample-file :file1 :page-label :page1)
(thv/add-variant :variant1 :component1 :root1 :component2 :root2)
(ths/update-shape :root1 :variant-id nil))]
(with-redefs [cfr/repair-file
(fn [& _] (throw (AssertionError. "non-uuid id")))]
(let [result (cfr/repair-loop file {})]
(t/is (identical? file result)
"asserts do not escape the loop")))))))
(t/deftest repair-main-instance-not-a-variant
(t/testing "detect and repair a variant component whose root shape is not a variant"
(let [file (-> (thf/sample-file :file1 :page-label :page1)

View File

@ -17,8 +17,10 @@
validated."
(:require
[app.common.files.validate :as cfv]
[app.common.test-helpers.compositions :as tho]
[app.common.test-helpers.files :as thf]
[app.common.test-helpers.ids-map :as thi]
[app.common.test-helpers.shapes :as ths]
[app.common.types.file :as ctf]
[app.common.types.pages-list :as ctpl]
[app.common.types.shape-tree :as ctst]
@ -447,3 +449,40 @@
(t/is (= :validation (:type data)))
(t/is (= :referential-integrity (:code data)))
(t/is (seq (:details data)))))))))
;; ----------------------------------------------------------------
;; 11. check-component-ref – copy roots without :shape-ref
;; ----------------------------------------------------------------
(defn- dissoc-copy-shape-ref
"Remove :shape-ref from the copy root shape. Instance heads
legitimately carry none (see get-ref-shape), so this mirrors the
stored shape instead of crafting corruption."
[file copy-label]
(let [page (thf/current-page file)
copy-id (thi/id copy-label)]
(ctf/update-file-data
file
(fn [file-data]
(ctpl/update-page file-data (:id page)
(fn [p]
(ctst/set-shape p (dissoc (ctst/get-shape p copy-id)
:shape-ref))))))))
(t/deftest validate-copy-without-shape-ref
(t/testing "a copy root without :shape-ref reports no :ref-shape-not-found"
(let [file (-> (thf/sample-file :file1 :page-label :page1)
(tho/add-simple-component-with-copy :component1 :main-root :main-child :copy-root))
file (dissoc-copy-shape-ref file :copy-root)
errors (cfv/validate-file file {})]
(t/is (empty? (filter #(= :ref-shape-not-found (:code %)) errors))
"nothing referenced, nothing to report"))))
(t/deftest validate-copy-with-unknown-shape-ref
(t/testing "a copy root with a dangling :shape-ref still reports :ref-shape-not-found"
(let [file (-> (thf/sample-file :file1 :page-label :page1)
(tho/add-simple-component-with-copy :component1 :main-root :main-child :copy-root))
file (ths/update-shape file :copy-root :shape-ref (uuid/next))
errors (cfv/validate-file file {})]
(t/is (some #(= :ref-shape-not-found (:code %)) errors)
"the guard did not swallow dangling references"))))

View File

@ -0,0 +1,239 @@
;; 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 common-tests.files-migrations-0027-test
"Tests for the 0027 migration
(see https://github.com/penpot/penpot/issues/12433).
Production files fail schema validation with unconverted types
(`:type \"circle\"` instead of `:circle`, ids as text, map keys as
text/keyword instead of uuid) and with nil pages. The file holds
two groups: `decode-coverage-*` are characterization tests pinning
down what the schema `decode` (json-transformer) already fixes on
its own and what still needs targeted repair clauses;
`migration-0027-*` pin the migration behavior itself (converting
unconverted types, dropping nil pages, leaving valid data
untouched, idempotence and running through `migrate`). The first
group asserts observed behavior, the second fixed behavior."
(:require
[app.common.files.migrations :as cfm]
[app.common.schema :as sm]
[app.common.test-helpers.files :as thf]
[app.common.types.file :as ctf]
[app.common.types.shape :as cts]
[app.common.uuid :as uuid]
[clojure.test :as t]))
(defn- make-rect-shape
[shape-id]
(cts/setup-shape {:id shape-id
:name "rect"
:type :rect
:x 0 :y 0 :width 10 :height 10
:parent-id uuid/zero
:frame-id uuid/zero}))
(defn- make-root-shape
[shape-id]
(cts/setup-shape {:id uuid/zero
:name "root"
:type :frame
:parent-id uuid/zero
:frame-id uuid/zero
:shapes [shape-id]}))
(defn- make-data
"Minimal file data with a single page holding a single rect shape."
[page-id shape]
(let [shape-id (:id shape)]
{:pages [page-id]
:pages-index
{page-id {:id page-id
:name "Page 1"
:objects {uuid/zero (make-root-shape shape-id)
shape-id shape}}}}))
(defn- decode-data
[data]
(sm/decode ctf/schema:data data (sm/json-transformer)))
(t/deftest decode-coverage-string-shape-type
(let [page-id (uuid/next)
shape-id (uuid/next)
data (make-data page-id (assoc (make-rect-shape shape-id) :type "rect"))
decoded (decode-data data)]
(t/is (= :rect (get-in decoded [:pages-index page-id :objects shape-id :type]))
"decode converts string shape type to keyword")))
(t/deftest decode-coverage-string-uuid-fields
(let [page-id (uuid/next)
shape-id (uuid/next)
shape (-> (make-rect-shape shape-id)
(assoc :id (str shape-id))
(assoc :parent-id (str uuid/zero))
(assoc :frame-id (str uuid/zero)))
data (make-data page-id shape)
decoded (decode-data data)
shape' (get-in decoded [:pages-index page-id :objects shape-id])]
(t/is (uuid? (:id shape')) "decode converts string shape id to uuid")
(t/is (uuid? (:parent-id shape')) "decode converts string parent id to uuid")
(t/is (uuid? (:frame-id shape')) "decode converts string frame id to uuid")))
(t/deftest decode-coverage-string-page-and-map-keys
(let [page-id (uuid/next)
shape-id (uuid/next)
data (make-data page-id (make-rect-shape shape-id))
data (-> data
(update :pages (fn [pages] (mapv str pages)))
(update :pages-index
(fn [pages-index]
(into {}
(map (fn [[pid page]]
[(str pid)
(update page :objects
(fn [objects]
(into {}
(map (fn [[id shape]]
[(keyword (str id)) shape]))
objects)))]))
pages-index))))
decoded (decode-data data)]
(t/is (= [page-id] (:pages decoded)) "decode converts string page refs to uuid")
(t/is (contains? (:pages-index decoded) page-id) "decode converts string page keys to uuid")
(t/is (contains? (get-in decoded [:pages-index page-id :objects]) shape-id)
"decode converts keyword object keys to uuid")))
(t/deftest decode-coverage-nil-pages
(let [page-id (uuid/next)
shape-id (uuid/next)
data (-> (make-data page-id (make-rect-shape shape-id))
(update :pages conj nil)
(assoc-in [:pages-index nil]
{:id nil :name "ghost" :objects {}}))
decoded (decode-data data)]
(t/is (some nil? (:pages decoded)) "decode leaves nil page entries alone")
(t/is (contains? (:pages-index decoded) nil) "decode leaves nil page keys alone")))
(t/deftest decode-coverage-healthy-file-untouched
(let [page-id (uuid/next)
shape-id (uuid/next)
data (make-data page-id (make-rect-shape shape-id))
_ (ctf/check-file-data (assoc data :id (uuid/next)))
decoded (decode-data data)
shape' (get-in decoded [:pages-index page-id :objects shape-id])]
;; NOTE: no whole-map equality here: decode materializes domain
;; records (Shape, Point, ...), which is the normal in-memory
;; representation (setup-shape builds the same records).
(t/is (= (:type (get-in data [:pages-index page-id :objects shape-id]))
(:type shape'))
"decode preserves shape type")
(t/is (= #{page-id} (set (:pages decoded))) "decode preserves page refs")
(t/is (contains? (:pages-index decoded) page-id) "decode preserves page keys")
(t/is (some? (ctf/check-file-data (assoc decoded :id (uuid/next))))
"decoded healthy data stays valid")))
(defn- valid-shape?
[data page-id shape-id]
(let [shape (get-in data [:pages-index page-id :objects shape-id])]
(and (= :rect (:type shape))
(uuid? (:id shape))
(uuid? (:parent-id shape))
(uuid? (:frame-id shape)))))
(t/deftest migration-0027-converts-unconverted-types-in-pages
(let [page-id (uuid/next)
shape-id (uuid/next)
data (-> (make-data page-id (make-rect-shape shape-id))
(thf/corrupt-shape-types)
(assoc :custom-attr "kept"))
data' (cfm/migrate-data data "0027-repair-unconverted-types-and-nil-pages")
shape (get-in data' [:pages-index page-id :objects shape-id])]
(t/is (valid-shape? data' page-id shape-id) "types and ids converted back")
(t/is (contains? (:pages-index data') page-id) "page key converted back")
(t/is (= [page-id] (:pages data')) "page refs converted back")
(t/is (= "kept" (:custom-attr data')) "unknown keys preserved")
(t/is (some? (ctf/check-file-data (assoc data' :id (uuid/next))))
"migrated data validates")))
(t/deftest migration-0027-converts-unconverted-types-in-components
(let [page-id (uuid/next)
shape-id (uuid/next)
component-id (uuid/next)
data {:pages-index
{page-id {:id page-id
:name "Page 1"
:objects {uuid/zero (make-root-shape page-id)}}}
:components
{(str component-id) {:id (str component-id)
:name "Component"
:objects {shape-id (make-rect-shape shape-id)}}}}
data (-> data
(update-in [:components (str component-id) :objects]
(fn [objects]
(into {}
(map (fn [[id shape]]
[(keyword (str id))
(-> shape
(assoc :type (name (:type shape)))
(assoc :id (str (:id shape))))]))
objects))))
data' (cfm/migrate-data data "0027-repair-unconverted-types-and-nil-pages")
shape (get-in data' [:components component-id :objects shape-id])]
(t/is (= :rect (:type shape)) "component shape type converted")
(t/is (uuid? (:id shape)) "component shape id converted")
(t/is (contains? (:components data') component-id) "component key converted")
(t/is (= component-id (get-in data' [:components component-id :id]))
"component id converted")
(t/is (contains? (get-in data' [:components component-id :objects]) shape-id)
"component object key converted")))
(t/deftest migration-0027-drops-nil-pages
(let [page-id (uuid/next)
shape-id (uuid/next)
data (-> (make-data page-id (make-rect-shape shape-id))
(update :pages conj nil)
(assoc-in [:pages-index nil]
{:id nil :name "ghost" :objects {}}))
data' (cfm/migrate-data data "0027-repair-unconverted-types-and-nil-pages")]
(t/is (not-any? nil? (:pages data')) "nil page refs removed")
(t/is (not (contains? (:pages-index data') nil)) "nil page key removed")
(t/is (some? (ctf/check-file-data (assoc data' :id (uuid/next))))
"migrated data validates")))
(t/deftest migration-0027-leaves-valid-data-untouched
(let [page-id (uuid/next)
shape-id (uuid/next)
data (assoc (make-data page-id (make-rect-shape shape-id))
:id (uuid/next))
data' (cfm/migrate-data data "0027-repair-unconverted-types-and-nil-pages")]
(t/is (some? (ctf/check-file-data data')) "healthy data stays valid")))
(t/deftest migration-0027-is-idempotent
(let [page-id (uuid/next)
shape-id (uuid/next)
data (-> (make-data page-id (make-rect-shape shape-id))
(thf/corrupt-shape-types))
data' (cfm/migrate-data data "0027-repair-unconverted-types-and-nil-pages")
data'' (cfm/migrate-data data' "0027-repair-unconverted-types-and-nil-pages")]
(t/is (= data' data'') "second run is a no-op")))
(t/deftest migration-0027-runs-through-migrate
(let [file-id (uuid/next)
page-id (uuid/next)
shape-id (uuid/next)
data (-> (make-data page-id (make-rect-shape shape-id))
(thf/corrupt-shape-types))
file {:id file-id
:features #{}
:migrations (disj cfm/available-migrations
"0027-repair-unconverted-types-and-nil-pages")
:data data}
file' (cfm/migrate file nil)]
;; migrate itself validates at the end, so returning is passing.
(t/is (contains? (:migrations file') "0027-repair-unconverted-types-and-nil-pages")
"migration marked as applied")
(t/is (valid-shape? (:data file') page-id shape-id)
"migrated file data has converted types")))

View File

@ -0,0 +1,98 @@
;; 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 common-tests.files-pages-test
"Regression tests for the nil-page writer
(see https://github.com/penpot/penpot/issues/12433).
Production files turned up with a nil entry in `:pages` and a nil
key in `:pages-index` (the shape legacy-57 cleans). The writer was
`:add-page` with a page missing a valid `:id`: the change schema
leaves `:page` unchecked (`:any`) and nothing else stopped it, so a
nil page was persisted whenever validation was skipped or soft.
`process-change :add-page` now asserts a valid page id up front,
like `:del-page` already did."
(:require
[app.common.files.validate :as cfv]
[app.common.test-helpers.files :as thf]
[app.common.test-helpers.ids-map :as thi]
[app.common.uuid :as uuid]
[clojure.test :as t]))
(t/use-fixtures :each thi/test-fixture)
(defn- schema-status
[file]
(try
(cfv/validate-file-schema! file)
:valid
(catch #?(:clj Exception :cljs js/Error) e
[:invalid (ex-message e)])))
(t/deftest add-page-without-id-is-rejected
(let [file (thf/sample-file :file)]
(try
(thf/apply-changes file
{:redo-changes [{:type :add-page :page {:name "Ghost"}}]}
:validate? false)
(t/is false "expected exception to be thrown")
(catch #?(:clj clojure.lang.ExceptionInfo :cljs cljs.core.ExceptionInfo) e
(let [data (ex-data e)]
(t/is (= :validation (:type data)))
(t/is (= "add-page requires a page with a valid :id" (ex-message e))))))))
(t/deftest mov-page-with-nil-id-is-rejected-at-change-level
(let [file (thf/sample-file :file)]
(t/is (thrown? #?(:clj Exception :cljs js/Error)
(thf/apply-changes file
{:redo-changes [{:type :mov-page :id nil :index 0}]}
:validate? false))
"mov-page with nil id never reaches the file")))
(t/deftest del-missing-page-is-a-no-op
(let [file (thf/sample-file :file)
file' (thf/apply-changes file
{:redo-changes [{:type :del-page :id (uuid/next)}]}
:validate? false)
data (:data file')]
(t/is (not-any? nil? (:pages data)) "no nil page refs")
(t/is (not (contains? (:pages-index data) nil)) "no nil page keys")
(t/is (= :valid (schema-status file')) "stays schema-valid")))
(t/deftest mov-page-out-of-range-keeps-valid
(let [file (thf/sample-file :file)
page (thf/current-page file)
file' (thf/apply-changes file
{:redo-changes [{:type :mov-page :id (:id page) :index 99}]}
:validate? false)
data (:data file')]
(t/is (not-any? nil? (:pages data)) "no nil page refs")
(t/is (= :valid (schema-status file')) "stays schema-valid")))
(t/deftest add-page-roundtrip-stays-valid
(let [file (thf/sample-file :file)
page-id (uuid/next)
file' (thf/apply-changes file
{:redo-changes [{:type :add-page
:id page-id
:name "Second"}]})]
(t/is (some #(= page-id %) (:pages (:data file'))) "page ref stored")
(t/is (some? (get-in file' [:data :pages-index page-id])) "page stored")
(t/is (= :valid (schema-status file')) "stays schema-valid")))
(t/deftest add-page-with-mismatched-id-is-rejected
(let [file (thf/sample-file :file)]
(try
(thf/apply-changes file
{:redo-changes [{:type :add-page
:id (uuid/next)
:page {:id (uuid/next) :name "Ghost"}}]}
:validate? false)
(t/is false "expected exception to be thrown")
(catch #?(:clj clojure.lang.ExceptionInfo :cljs cljs.core.ExceptionInfo) e
(let [data (ex-data e)]
(t/is (= :conflict (:type data)))
(t/is (= "id and page should agree" (ex-message e))))))))

View File

@ -21,7 +21,10 @@
[common-tests.files-changes-test]
[common-tests.files-migrations-0025-test]
[common-tests.files-migrations-0026-test]
[common-tests.files-migrations-0027-test]
[common-tests.files-migrations-test]
[common-tests.files-pages-test]
[common-tests.files.repair-test]
[common-tests.files.shapes-builder-test]
[common-tests.files.validate-test]
[common-tests.geom-align-test]
@ -77,6 +80,7 @@
[common-tests.types.color-test]
[common-tests.types.components-test]
[common-tests.types.container-test]
[common-tests.types.file-sanitize-test]
[common-tests.types.fill-test]
[common-tests.types.modifiers-test]
[common-tests.types.objects-map-test]
@ -102,7 +106,10 @@
'common-tests.files-changes-test
'common-tests.files-migrations-0025-test
'common-tests.files-migrations-0026-test
'common-tests.files-migrations-0027-test
'common-tests.files-migrations-test
'common-tests.files-pages-test
'common-tests.files.repair-test
'common-tests.files.validate-test
'common-tests.geom-align-test
'common-tests.geom-bounds-layout-nil-test
@ -157,6 +164,7 @@
'common-tests.types.color-test
'common-tests.types.components-test
'common-tests.types.container-test
'common-tests.types.file-sanitize-test
'common-tests.types.fill-test
'common-tests.types.modifiers-test
'common-tests.types.objects-map-test

View File

@ -0,0 +1,118 @@
;; 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 common-tests.types.file-sanitize-test
"Pins the behavior of `ctf/sanitize-file-data`: it coerces the
unconverted types seen in production (strings where the schema
expects keywords or uuids) and drops nil page entries, while
leaving genuinely unknown values untouched so downstream
validation still fails loudly."
(:require
[app.common.test-helpers.files :as thf]
[app.common.types.file :as ctf]
[app.common.types.objects-map :as omap]
[app.common.types.shape :as cts]
[app.common.uuid :as uuid]
[clojure.test :as t]))
(defn- make-rect-shape
[shape-id]
(cts/setup-shape {:id shape-id
:name "rect"
:type :rect
:x 0 :y 0 :width 10 :height 10
:parent-id uuid/zero
:frame-id uuid/zero}))
(defn- make-root-shape
[shape-id]
(cts/setup-shape {:id uuid/zero
:name "root"
:type :frame
:parent-id uuid/zero
:frame-id uuid/zero
:shapes [shape-id]}))
(defn- make-data
"Minimal file data with a single page holding a single rect shape."
[page-id shape]
(let [shape-id (:id shape)]
{:pages [page-id]
:pages-index
{page-id {:id page-id
:name "Page 1"
:objects {uuid/zero (make-root-shape shape-id)
shape-id shape}}}}))
(t/deftest sanitize-coerces-unconverted-types
(let [page-id (uuid/next)
shape-id (uuid/next)
data (thf/corrupt-shape-types
(make-data page-id (make-rect-shape shape-id)))
data' (ctf/sanitize-file-data data)
shape' (get-in data' [:pages-index page-id :objects shape-id])]
(t/is (= [page-id] (:pages data')) "string page refs become uuids")
(t/is (contains? (:pages-index data') page-id) "string page keys become uuids")
(t/is (= :rect (:type shape')) "string shape type becomes a keyword")
(t/is (uuid? (:id shape')) "string shape id becomes a uuid")))
(t/deftest sanitize-drops-nil-pages
(let [page-id (uuid/next)
shape-id (uuid/next)
data (-> (make-data page-id (make-rect-shape shape-id))
(update :pages conj nil)
(assoc-in [:pages-index nil] {:id nil :name "ghost" :objects {}}))
data' (ctf/sanitize-file-data data)]
(t/is (= [page-id] (:pages data')) "nil page entries are dropped")
(t/is (not (contains? (:pages-index data') nil)) "nil page keys are dropped")))
(t/deftest sanitize-leaves-unknown-values-untouched
(let [page-id (uuid/next)
shape-id (uuid/next)
data (make-data page-id
(assoc (make-rect-shape shape-id) :type "triangle"))
data' (ctf/sanitize-file-data data)
shape' (get-in data' [:pages-index page-id :objects shape-id])]
(t/is (= :triangle (:type shape'))
"decode keywordizes the string, but the value stays out of schema")
(t/is (thrown? #?(:clj clojure.lang.ExceptionInfo :cljs cljs.core.ExceptionInfo)
(ctf/check-file-data data'))
"downstream validation still fails loudly")
(t/is (= data' (ctf/sanitize-file-data data'))
"sanitize is idempotent")))
(t/deftest sanitize-returns-same-instance-when-clean
;; Clean data needs no repair: sanitize must return the input as
;; is (same instance) so nothing gets re-materialized nor needs
;; re-diffing downstream to tell change apart from no-op.
(let [page-id (uuid/next)
shape-id (uuid/next)
data (make-data page-id (make-rect-shape shape-id))]
(t/is (identical? data (ctf/sanitize-file-data data)))))
(t/deftest sanitize-keeps-objects-map-when-clean
;; Same contract for a lazy objects-map container: the untouched
;; input comes back with the same instance, so the container stays
;; lazy and objectless entries are never decoded for nothing.
(let [page-id (uuid/next)
shape-id (uuid/next)
objects (omap/wrap {uuid/zero (make-root-shape shape-id)
shape-id (make-rect-shape shape-id)})
data (assoc-in (make-data page-id (make-rect-shape shape-id))
[:pages-index page-id :objects] objects)]
(t/is (identical? objects
(get-in (ctf/sanitize-file-data data)
[:pages-index page-id :objects]))
"the objects-map container survives unchanged")))
(t/deftest sanitize-returns-new-instance-when-repairing
;; Positive control for the identity contract: real corruption
;; yields coerced values and therefore a genuinely new instance.
(let [page-id (uuid/next)
shape-id (uuid/next)
data (thf/corrupt-shape-types
(make-data page-id (make-rect-shape shape-id)))]
(t/is (not (identical? data (ctf/sanitize-file-data data))))))