Merge remote-tracking branch 'origin/staging' into develop

.serena/memories/backend/core.md

@@ -4,7 +4,7 @@ Backend: JVM Clojure; Integrant; PostgreSQL; Redis/Valkey; RPC; HTTP; storage; m
 
 ## Focused memories
 
-- Cross-cutting backend subtleties (RPC, DB, workers, cron, HTTP/sessions, storage, file data): `mem:backend/subtleties`
+- Cross-cutting backend subtleties (RPC, DB, workers, cron, CLIMIT, HTTP/sessions, storage, file data): `mem:backend/subtleties`
 - Storage abstraction, logical buckets, object lifecycle, deduplication, access, and garbage collection: `mem:backend/storage`.
 - Embedded Ladybug graph experiment, projection, incremental sync, console, and risks: `mem:backend/graph-experiment`
 - Session lifetime config, token `:exp`, and idle/absolute GC: `mem:backend/session-expiration`.
@@ -24,6 +24,7 @@ Backend: JVM Clojure; Integrant; PostgreSQL; Redis/Valkey; RPC; HTTP; storage; m
 - `app.worker`: task execution/cron plumbing.
 - `app.main`: Integrant system map and component wiring.
 - `app.config`: `PENPOT_*` env config and feature flags.
+- `app.health`: per-process availability flag; `/readyz` answers 503 while offline. Flipped from `app.srepl.main` (`set-offline` / `set-online`).
 - `app.srepl.*`: development REPL helpers for manual backend operations (data inspection, migration helpers, one-off admin tasks).
 - `app.nitrate`, `app.rpc.commands.nitrate`, and `app.rpc.management.nitrate`: external Nitrate subscription/organization integration, gated by the `:nitrate` feature flag and shared-key HTTP calls.
 
@@ -122,7 +123,7 @@ Fixtures can populate local data for manual testing/perf work. From the backend
 
 * **Type Hinting:** Use explicit JVM type hints (e.g. `^String`, `^long`) in performance-critical paths to avoid reflection overhead.
 * **Batch inserts:** Use `db/insert-many!` for bulk row inserts — generates a single SQL with multiple parameter tuples. Avoid on very large datasets (SQL length / parameter count limits).
-* **Server-side cursors:** Use `db/plan` (fetch-size 1000, forward-only, read-only) or `db/cursor` for large result sets. Never fetch large collections into memory at once.
+* **Server-side cursors:** Use `db/plan` (fetch-size 1000, forward-only, read-only) for large result sets. Never fetch large collections into memory at once. `db/plan` is an `IReduceInit`: `reduce`/`transduce` over it (`sequence` does not work on it), and with `partition-all` the transducer's completing arity is what flushes the last partial chunk. A plan row is a **view over the open result set**, valid only inside the reducing function: read the columns you need right there — buffering rows to read them later (a `partition-all` buffer, a lazy seq) silently yields nil columns. `db/cursor` (manual `DECLARE`/`FETCH`) is a leftover with no callers left.
 * **Transaction discipline:** Use `tx-run!` for writes (opens a transaction), `run!` for reads (single connection, no transaction). Set `:read-only` on `tx-run!` when applicable to let PostgreSQL optimize.
 
 ## Lint and Format

.serena/memories/backend/storage.md

@@ -25,16 +25,16 @@
 - Existing object values can remain readable until physical deletion.
 - `:expired-at` blocks reads after the expiration time.
 - `del-object!` sets `deleted_at` on live rows only (`deleted_at IS NULL`): a repeated call returns `false`. It does not remove backend content.
-- `storage-gc-deleted` removes the database row and backend content after the deletion delay.
+- `storage-gc-deleted` removes the database row and backend content after the deletion delay, streaming the pending rows with `db/plan` inside a read-only transaction and deleting them in chunks of 25, each chunk in its own transaction: a chunk that fails (for example, an object a foreign key still references) is logged and skipped instead of aborting the run. A physical-deletion failure inside a chunk defers its rows one day (`deletion_attempts + 1`) and gives up after 7 attempts, accepting the orphan blob; chunk mappings (`upload_session_chunk`) are removed before the `storage_object` rows (NO ACTION foreign keys).
 - `storage-gc-touched` finds references before it sets `deleted_at`.
-- `objects-gc` removes deleted domain rows and touches their storage object IDs.
+- `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.
 
 ## GC Cost Model
 
 - `sto/touch-object!` is one `UPDATE storage_object SET touched_at`: DB-only, never touches S3/FS backend content.
-- Physical FK cascades are avoided by convention; domain deletion is logical (`deleted_at`) everywhere. GC removes small objects first, then parents, then grandparents (see `deletion-proc-vars` order in `app.tasks.objects-gc`). Per-row delete cost is small and bounded.
-- `objects-gc` sweeps in chunks of 100 (`::chunk-size`, overridable per job params); `storage-gc-deleted` in chunks of 25. Each chunk is one transaction: cursor fetch + single-row deletes/updates + commit.
+- Physical FK cascades are avoided by convention; domain deletion is logical (`deleted_at`) everywhere. GC removes small objects first, then parents, then grandparents (see the call order in `app.tasks.objects-gc/execute-objects-gc`). Per-row delete cost is small and bounded.
+- `objects-gc` sweeps in chunks of 100 (`::chunk-size`, overridable per job params); `storage-gc-deleted` in chunks of 25. The cursor that streams the pending keys runs in a read-only transaction of its own (`db/plan`), and every chunk is deleted in a transaction of its own: the cursor fetch and the deletes are never the same transaction.
 - Consequence: per-chunk cost is DB-only and bounded, so these sweeps cannot outrun the 30-minute jobs lease in practice (would need millions of pending rows in one proc). Per-chunk `heartbeat` where present is belt-and-braces, not load-bearing.
 
 ## Connection Reuse Details

.serena/memories/backend/subtleties.md

@@ -11,6 +11,17 @@
 - Nil RPC bodies become HTTP 204 unless explicit status metadata is present. Stream bodies default to `application/octet-stream` when no content type is set.
 - The upload schema (`media.v/schema:upload`) takes a `:path` from the caller, and a Transit body can tag any string as a `path`, so a command that reads such an upload reads a file the client named. `create-import-binfile-job` avoids that boundary by accepting only a chunked upload (`:upload-id`); the commands that still take a plain file (the legacy `import-binfile`, the media and font uploads) trust it, and the guard belongs where uploads are accepted, not in each command.
 
+## Concurrency limiter (CLIMIT)
+
+- `::climit/id` is either a plain keyword, which gives one shared limiter per process, or the vector form `[[id key-fn]]`, which gives one limiter per key. `climit/wrap` takes the key only from that positional `key-fn` (`climit/get-limits` maps a plain keyword to a single-element vector), so `::climit/key-fn` is metadata that nothing reads: a command declaring `::climit/id :x/by-profile` next to it ends up with a single shared limiter, and the missing key is visible in the `app.rpc.climit` log lines, whose `id` carries no key suffix. That is what happened to `push-audit-events`, the last user of the dead metadata, from `a5c6d78ee5` (2024-01-27, "fix some fundamental bugs on climit module", which moved the key to the vector form without updating it) until it was fixed; nothing declares `::climit/key-fn` any more, so keep using the vector form for anything that must be per profile.
+- A gauge written by whichever limiter of a name ran last cannot show a queue: every per-profile limiter of the name collapses into one series, so a healthy profile writing 0 overwrites the 15 of the one that is queueing (measured in production: 4 of 1441 samples). `penpot_rpc_climit_waiting` replaces it and is accumulated: one counter per name and instance, up when a call starts waiting for a permit, down when it stops, so a call that enters and never leaves keeps the value above zero for ever. `penpot_rpc_climit_rejected_total` counts rejections by name and `reason`: `queue-full` when the error carries `:size`, `timeout` when it carries `:timeout` (both carry `:code :capacity-limit-reached`, so the timeout field is the discriminator). The two gauges that could not tell the truth (`penpot_rpc_climit_queue`, `penpot_rpc_climit_permits`) were deleted, and so was `penpot_http_worker_busy_threads`, which reads 0 on an instance with 72 blocked threads: `penpot_http_worker_pool_size` is the signal for retained threads. A stuck limiter also shows up in `penpot_rpc_climit_timing_count` (the acquired path), which is a counter: compare the same limiter name across instances and the stuck one reads 0 acquisitions while its peer reads thousands. In thread dumps it reads as threads parked in `psm/acquire` whose CPU time does not grow between two dumps, on an instance that is otherwise idle.
+- The waiting counters are a field of the `ConcurrencyLimiter` component (a `ConcurrentHashMap` of name to `AtomicLong`), so they start at zero, die with the component, and the sampler that closes over that map republishes only its own names every 15 s; the sampler stops with the component in `halt-key!`. `impl-invoke` pairs one decrement with one increment through a per-call flag: the flag turns a second call into a no-op and the `finally` guarantees that there is one. The increment sits inside the `try` and the decrement lives only in the acquired callback and the `finally`, so a handler that throws, a rejection and a throwable from the publishing path all leave the count where it was and the thread without the limiter marked as held (a leftover mark would skip that limiter for that key for ever). Concurrent `inc`/`dec` publications of two threads can land out of order and the value can read low for a moment; the republish corrects it.
+- The `app.rpc.climit` log lines carry `queue`, `queue-max`, `permits`, `elapsed`, `code` and `reason`, and their `id` carries the key (`name/<profile or key>`). That is the only place where the profile behind a queue is visible: a pile-up is chased there, on demand, not in the metrics. The `queue` of the line is the calls inside the limiter minus its permits, so it reads 0 for a lone caller that times out: that line goes out at TRACE instead of WARN, and the rejection count has to come from the metric.
+- Nothing in the limiter path has a timeout unless the config sets one, and `psm/acquire` then calls `Semaphore.acquire`, which parks the calling thread forever. A parked thread still counts as in-system for every outer limiter of its chain, so the outermost one (the method's own by-profile limiter) stops granting permits and answers 429 to everything. A limiter without `:queue` gets an unlimited queue and therefore never rejects: its pile-up is silent, with no 429 and no log line except the WARN `enqueued`/`acquired` lines of the keyed id.
+- Deadlock shape between a command's own limits and the root ones (fixed): a command declaring its own limits held `process-image/by-profile` before `root/by-profile`, while a command with no limits of its own takes the roots first and then re-enters with the same keyed limits from inside its handler (`create-file-media-object-from-url`, `upload-photo`) and waits for them holding a root permit. Two calls of one profile then held the same two limiters inverted and parked for good: 69 threads at 0 CPU, an audit limiter with 0 acquisitions in 24h and 100% 429s, on an instance that never served a 204.
+- `climit/wrap` now appends the root limiters after the command's own, so `root/global`/`root/by-profile` end up outermost and every path meets them first; the nested `climit/invoke!` chains carry only the command's own limits and run inside them, which puts both paths in the same order. `impl-invoke` also keeps, per thread, the set of limiters that thread is inside of and runs the handler inline when a call asks for one it already holds, instead of queueing behind itself. That check relies on `pbh/invoke!` running the handler on the calling thread; the mark is removed in a `finally`. Commands declare the by-profile limit before the global one, which makes it the outermost of the pair: keep that declaration order, the reverse one would put two paths back in inverted order. The two nested call sites (`create-file-media-object-from-url`, `upload-photo`) still share `process-image` with the enclosing call instead of getting a limiter of their own, so the comment there about keeping the download out of that limit no longer holds.
+- The shipped `backend/resources/climit.edn` sets a timeout on every limiter, 60s for operations that can be slow and 30s otherwise, with a test that fails when an entry ships without one, and `init-key` logs a WARN for every entry without a timeout. The production file lives outside the repository: mirror it there, and remember that a parked thread only goes away with a restart or a deploy.
+
 ## DB helpers
 
 - Most `app.db` helpers accept a pool, connection, or map containing `::db/pool` / `::db/conn`; preserve that convention in shared code.
@@ -51,8 +62,9 @@
 ## HTTP server self-metrics
 
 - `app.http` enables Undertow connection statistics via the yetti option `:server/statistics` (requires yetti ≥ v11.11, which exposes it; before the patch `ListenerInfo#getConnectorStatistics` returned `nil`).
-- A daemon sampler built on `promesa.exec` (`px/scheduled-executor` plus a self-rescheduling `px/schedule` chain, so a failing sample never cancels the next one; 15 s, started with the server in `ig/init-key` and stopped with `px/shutdown-now` in `halt-key!`) publishes worker and listener state: `penpot_http_worker_queue_size`, `busy_threads`, `pool_size`, `max_pool_size`, `penpot_http_connector_active_connections`, `requests_total`, `errors_total`. Definitions live in `app.main/default-metrics`.
-- The xnio worker MXBean can return transient `-1` (e.g. busy-thread count); negative samples are discarded (gauge keeps its previous value). Undertow exposes absolute request/error totals, so the sampler keeps a watermark atom and publishes deltas; a counter reset (decreasing totals) skips the negative delta and moves the watermark forward.
+- `app.metrics/create-sampler` holds the sampler shape: a single daemon `px/scheduled-executor` thread with a self-rescheduling `px/schedule` chain, so a failing sample never cancels the next one; the owner starts it in `ig/init-key` and stops it with `px/shutdown-now` in its `halt-key!`. Http and CLIMIT both sample every 15 s.
+- `app.http` uses it to publish worker and listener state: `penpot_http_worker_queue_size`, `penpot_http_worker_pool_size`, `penpot_http_worker_max_pool_size`, `penpot_http_connector_active_connections`, `penpot_http_connector_requests_total`, `penpot_http_connector_errors_total`. Definitions live in `app.main/default-metrics`. The xnio busy-thread count is not published: it reads 0 with threads blocked inside a limiter, which is why it was deleted.
+- The xnio worker MXBean can return transient `-1` (e.g. on the queue or the pool size); negative samples are discarded (gauge keeps its previous value). Undertow exposes absolute request/error totals, so the sampler keeps a watermark atom and publishes deltas; a counter reset (decreasing totals) skips the negative delta and moves the watermark forward.
 - The `process_*` families (`process_open_fds`, `process_max_fds`, `process_cpu_seconds_total`, …) come from the prometheus client `StandardExports`, registered by `app.metrics/create-registry`. They read the OS MXBean reflectively and need the `jdk.management` module: on a pruned `jlink` JRE the MXBean is `sun.management.BaseOperatingSystemImpl`, the getters throw `NoSuchMethodException` and `StandardExports#collect` swallows it, so those families silently vanish from `/metrics`. `docker/images/Dockerfile.backend` keeps `jdk.management` in the `--add-modules` list, and `backend-tests.metrics-test` pins the contract.
 
 ## Metrics recording

.serena/memories/backend/testing.md

@@ -29,4 +29,5 @@ JVM `clojure.test` (kaocha runner) under `backend/test/backend_tests/`.
   the defs and `default` inside a test — so a component built from
   `worker-config` can talk to a different Redis key prefix than a cfg the test
   builds itself. The symptom is a component that silently does nothing
-  locally and races in CI (which sets no `PENPOT_TENANT`).
+  locally and races in CI (which sets no `PENPOT_TENANT`).
+- `backend-tests.helpers` has `metrics-stub` (a metrics instance with no collectors, where every `run!` is a no-op), `init-climit` (a concurrency limiter built from an inline config map, with an optional second argument for the metrics instance to publish to) and `with-climit`, the macro that builds one, runs the body and halts it. `init-climit` starts the republisher daemon thread, so a test that builds a limiter without halting it leaks that thread for the rest of the JVM run: use `with-climit`. Log lines are capturable with `add-watch` on `app.common.logging/log-record` (it holds the last record; the watcher sees every one, but only of the levels the logger has enabled: a line the app writes at TRACE never gets there).

.serena/memories/common/uri.md

@@ -0,0 +1,13 @@
+# Common URI helpers
+
+`app.common.uri` wraps `lambdaisland.uri` and re-exports `join`, `parse`, `query-encode`, `percent-encode` and `uri?` with `dm/export`.
+
+## `join` resolves references, it does NOT concatenate paths
+
+- `lambdaisland.uri/join` implements RFC 3986 reference resolution, not path concatenation: a relative reference that does not start with `/` replaces everything after the last `/` of the path it is resolved against. Joining several segments resolves them successively, so each segment replaces the last segment of the previous result.
+- `(join "https://h/" "api/teams/" "<id>" "users/" "<pid>")` returns `https://h/api/teams/users/<pid>`, not `.../api/teams/<id>/users/<pid>`: `"users/"` replaced `"<id>"`. `(apply join base segments)` behaves the same.
+- `ensure-path-slash` normalizes only the BASE to end with `/`; it does not touch the segments, so a base ending in `/` is not enough for a multi-segment append.
+- To append several segments: either join them into a single relative path first (dropping empty segments and collapsing slashes), or make every non-final segment end with `/`, including the dynamic ids. Keep that normalization in the shared URL builder, not in each call site.
+- A segment starting with `/` resolves against the host root and silently drops the base subpath; reject it.
+- Frontend `app.config` normalizes the base (`normalize-uri`) and relies on callers passing trailing-slash segments by convention (`resolve-file-media` joins `"assets/by-file-media-id/"` then `"<id>/thumbnail"`); it does not normalize segments.
+- Backend shared builders are `app.config/join-uri` and `app.config/get-public-uri`. A past refactor moved Nitrate's per-request helper onto them without the segment normalization and broke every multi-segment Nitrate URL that passes `"api/teams/" team-id "users/" profile-id`.

.serena/memories/frontend/dashboard-viewer-subtleties.md

@@ -10,6 +10,7 @@
 
 ## Viewer
 
+- `app.main.ui.ui` parses the viewer's `file-id` query param with `uuid/parse*`, so a missing or malformed id arrives as nil. `viewer-page*` calls `check-file-id!` (same namespace) during render, before mounting `viewer*`: it raises `ex/raise :type :not-found :code :missing-file-id`, which the error boundary turns into the not-found page. Without the guard the `dv/initialize` assertion fails on the nil file-id and the user gets an internal-error page. Test: `frontend-tests.ui.viewer-test/check-file-id-raises-not-found-for-invalid-file-id`.
 - Viewer initialization sets `:current-file-id`, `:current-share-id`, and `:viewer-local`, then fetches the view-only bundle. Comment threads are fetched only for logged-in users.
 - Viewer bundle fetch sends the full supported feature set because anonymous shared viewers may not know team-enabled features.
 - View-only bundles can contain pointer values in `:pages-index` and file data. Viewer resolves those fragments with `:get-file-fragment` before storing the bundle.

.serena/memories/frontend/routing-app-shell-subtleties.md

@@ -3,9 +3,13 @@
 ## Router, app shell, and errors
 
 - Routing uses browser-history query tokens (`?screen=<route-name>&params`, single `/` path), but `on-navigate` rejects navigation if the current origin/path does not match `cf/public-uri`.
+- `app.util.browser-history` (CLJS, not the old `goog.history.Html5History` wrapper) is the only history layer: the token is `location.search`, the URL of a token is `(:path cf/public-uri)` + token, and every change (own `pushState`/`replaceState` or back/forward) lands on the `token-changes` subject the router subscribes to. Nothing about it lives in the store: `rt/initialize-history` is effect-only.
+- `set-token!` and `replace-token!` are deliberately asymmetric. `set-token!` is a total no-op when the token already is the current one (no URL write, no report), so navigating to the screen you are on cannot grow the history stack. `replace-token!` always writes and always reports, because it is how the app corrects the URL in place (legacy `#/…` translation, cleaned share links) and that correction must reach the router even when the token did not change. This matches `Html5History`, which did the same; do not "fix" the asymmetry without deciding what navigates to the current screen.
+- `app.util.dom/replace-history-state!` is the deliberate bypass used by `app.main.ui.dashboard`/`app.main.ui.static` to rewrite the URL **without** routing. Keep using it there instead of `replace-token!`, which would re-enter the router.
 - Route params live entirely in the query map under the reserved `screen` key; duplicate query params can become vectors, so use `rt/get-query-param` when a scalar is required.
 - Legacy `#/…` hash URLs translate client-side to the query format (one-version compat; see `legacy-routes` in `app.main.ui.routes`, TODO(next-version) to delete).
 - Unknown/empty routes trigger an extra `get-profile`/`get-teams` check before redirecting. This avoids invitation and root-route race conditions.
+- The root app has two error layers, and they reset differently. `:exception` in the store renders `static/exception-page*` directly and is cleared by `rt/navigated`; a React render error is caught by `app.main.ui.error-boundary` (`react-error-boundary`), whose error lives in internal React state that only `reset-error-boundary` clears. Because every exit from the error page (the logo, the no-permission dialogs, the SSO dialog, the feedback link) only *navigates*, the boundary is given `:resetKeys [(eb/reset-key route)]` — the screen name — so a navigation counts as a fresh attempt at rendering. Three traps in that `resetKeys` value, all learned the hard way: it must be a real JS array (`#js [...]`), never a ClojureScript vector, because `react-error-boundary` reads `.length` and `.some` and a `PersistentVector` has neither, so `componentDidUpdate` throws `some is not a function`; it must hold the screen name as a *string*, because the library compares entries with `Object.is` and ClojureScript does not intern keywords, so two equal keywords are two objects and a keyword key would read as new on every route rebuilt, resetting the boundary on a param change inside the same screen; and it must be the screen rather than the params, so a param change does not replay the screen that just crashed. Navigating to the *same* screen therefore does not reset, and a reload is the only way out of that case.
 - The root app renders an exception page from `:exception` state before the normal error boundary. `rt/navigated` clears `:exception`.
 - Frontend error handling treats stale cross-build JS chunk failures specially: messages containing `$cljs$cst$` or `$cljs$core$I` plus undefined/null/not-a-function signatures trigger throttled reload.
 - Plugin-originated uncaught errors are identified through the plugin runtime hook and logged rather than turning into the global exception page.

.serena/memories/prod-infra/core.md

@@ -31,8 +31,22 @@ Penpot in production lives with both: horizontal-scale deployments accept "exact
 
 Worker-enabled, writable backends publish unified jobs metrics through the normal Prometheus registry. Counters describe submit, dispatch, terminal outcomes, retries, orphan recovery, rescheduling and total stored job events (unlabelled); histograms separate queue wait, handler execution and total job age. SQL-backed events are recorded after the outer PostgreSQL transaction commits. The `::jobs-metrics/sampler` component publishes backlog by status and the oldest pending-job age every 30 seconds. All labels are bounded operational values; job IDs, profile IDs, params and error text are excluded. Read-only backends do not start the sampler or the workers.
 
+## Draining one instance
+
+Each backend has a per-process availability flag (`app.health`, a global atom). While offline, `/readyz` answers `503 OFFLINE` without querying the database, so the load balancer removes that instance from rotation while requests in flight still finish. Operator surface: `app.srepl.main/set-offline` / `set-online`; a restart comes back online. In-flight worker jobs are safe: jobs claimed as `scheduled` return to `new` after 5 minutes via `sql:reschedule-lost` and another instance picks them up.
+
+## Touching production data
+
+Production runs the deployed toolbox, not the devenv one:
+
+- **No psql meta-commands there.** `scripts/psql` and `\set`, `\if`, `\copy` do not exist in production, so a data script must be **plain SQL**, copy-pasteable into any client.
+- **Start from the ids, not from an inventory.** The ids come from the error or the logs. Unbounded queries over tables with tens of millions of rows (`storage_object`, `file_media_object`) do not finish in a reasonable time; bounded to an id list they are index lookups.
+- **One query per reference column.** Two columns in one `IN (col_a, col_b)` lose the index and scan the whole table; split them.
+- The read-only replica cuts long queries: see `mem:prod-infra/grafana`.
+
 ## See also
 
 - Devenv composition and the ws0-only worker placement: `mem:devenv/core`.
 - Storage backend resolution, dedup, bucket behavior, object lifecycle, and file-data lifecycle: `mem:backend/storage`.
 - Storage operation metrics (S3 API calls, logical ops, dedup, asset requests) and the logical-bucket vs physical-target distinction: `mem:backend/storage` (Metrics section).
+- Grafana (datasource ids and how to use them, main dashboard, panel conventions and gotchas): `mem:prod-infra/grafana`.

.serena/memories/prod-infra/grafana.md

@@ -0,0 +1,42 @@
+# Grafana
+
+Private instance with Penpot metrics and logs. Dashboards are edited through the Grafana API (MCP tools); there is no dashboards-as-code for them.
+
+Keep this memory free of internal names: no host names, no deployed versions, no topology. The datasource ids and the label conventions are the useful technical part.
+
+## Datasources
+
+- Metrics — **Prometheus**, uid `xkRmyFBGk`. PromQL. Metric families: `penpot_*` (RPC, task timings, CLIMIT, HTTP, websocket, storage), `hikaricp_*`, `jvm_*` and `process_*` on the backend (`job="app"`); `pg_*` from the Postgres exporter (`job="postgres"`); `redis_*` from the Redis exporter (`job="redis"`); `node_*` and `container_*` from node-exporter and cAdvisor. Backend histograms are in **milliseconds**.
+- Logs — **Loki**, uid `h3CGKhEMk`. LogQL, and filter by the structured metadata `logger`/`level` (`{job="penpot"} | logger="..." | level="ERROR"`). Signals that only exist as logs: the profile behind a CLIMIT queue (`logger="app.rpc.climit"`, whose `id` carries the key). CLIMIT rejections have their own counters (`penpot_rpc_climit_rejected_total`, by `name` and `reason`), and their `hint="rejected"` line goes out at WARN only when something stays queued, so counting the lines is not counting the rejections.
+- SQL — **Postgres**, uid `y8ea9tfMk`. Panels need `rawQuery: true`, `editorMode: "code"` and `format: "table"`. The `task` table is the only truth about the queue depth. It is a **read-only replica**: it rejects any write, `CREATE TEMP TABLE` included, so queries through it must be plain `SELECT`s. It also cuts long-running queries (the MCP path has a short timeout), so bound them (e.g. a list of ids); an empty answer there is not proof that there is no data.
+- **Postgres (telemetry)**, uid `9YAUuM_Gz`.
+- `$__rate_interval` and `$__interval` are substituted by Grafana; use them instead of fixed windows in graphs.
+
+## Main dashboard
+
+- `Production status`, uid `penpot-production-status`. Sections: general state and deploy, RPC and CLIMIT, PostgreSQL and pool, Redis/msgbus, tasks, JVM/process. Variables `$env` and `$host` (custom), no auto refresh.
+- Per-host investigation dashboards are separate, and the alert rules deeplink into them.
+
+## Conventions
+
+- Filter with `instance=~"$host.$env.<domain>.*"`. To know which instances serve, count the ones reporting JVM metrics; `up{job="app"}` is not reliable (it can report 1 while the endpoint answers an empty body).
+- Layout: a band of number-only panels at the top of each section, wider data panels below, tables tall enough to show every row, legend on the **right** sorted by last value descending (`sortBy: "Last *"`, `sortDesc: true`).
+- Panels comparing used against total need `defaults.min = 0`, else the automatic axis exaggerates the difference.
+- Counters per method or task name read better as `increase(...[1h])` than `rate(...)`, with `decimals: 0`.
+- Cron "did it run" comes from the task metrics, not from the cron registry table (it keeps rows from old versions).
+- Dashboard thresholds must match the alert rule thresholds.
+
+## Gotchas
+
+- PromQL literal dots need `\\.`; simpler to use `[.]` or a plain dot.
+- The panel-level `datasource` must match its targets'. A SQL table declared as Prometheus renders empty even though the query returns rows.
+- Shortening a host in a legend needs a short label in the query: `renameByRegex` renames the field name, but with `legendFormat` set the legend text comes from the datasource.
+  - Prometheus: `label_replace(<expr>, "host", "$1", "instance", "([^.]+)[.][^.]+.*")` plus `legendFormat: "... {{host}}"`.
+  - Loki metric query: `| label_format host="{{ regexReplaceAll "[.][^.]*[.][^.]*[.][^.]*$" .instance "" }}"` plus `legendFormat: "{{host}}"`. Quotes inside the template must be escaped as `\"`, or LogQL closes the string early (`not a valid duration string`).
+- Tables from a Prometheus raw selector carry a `__name__` column; hide it with `organize`.
+- Saving through the API normalizes the dashboard (rows may be flattened, `y` recomputed): submit the native form (rows with `panels: []`, panels top-level, contiguous `y`).
+- Panel images cannot be rendered (no image renderer installed) and there is no browser here: verify a dashboard by running its queries with the variables substituted.
+- Signals that exist only as logs are counted with Loki, and the count is then cross-checked against the nginx access log for the same window and the same status code (`job="frontend"`, e.g. a `429`): two independent sources must agree before a number is trusted.
+- The app writes its own logs at WARN only when something is left queued behind the call and at TRACE otherwise, so production Loki holds just the under-pressure lines: a count of `hint="enqueued"` or `hint="acquired"` is not the number of calls, and neither is a count of `hint="rejected"` lines, because a rejection that leaves the queue empty (a lone caller that times out) is written at TRACE. The rejection counters are the real number.
+- The MCP Prometheus tool can answer empty for every query, `up` included, while the datasource itself is fine: an empty result from it is not proof that a panel has no data, and blaming the datasource for it is wrong. Run PromQL by hand with `grafana_api_request` against `/api/datasources/uid/<uid>/resources/api/v1/query?query=...` (or `POST /api/ds/query`, the path dashboards use), and check when a series is expected but the tool says nothing.
+- **Check `list_dashboard_versions` before writing.** The user edits dashboards by hand and a full-JSON overwrite silently reverts that work; prefer `operations` patches per panel.

CHANGES.md

@@ -120,6 +120,20 @@
 - Delete selected path handles with Backspace or Delete [#11858](https://github.com/penpot/penpot/issues/11858) (PR: [#11896](https://github.com/penpot/penpot/pull/11896))
 - Use the tooltip component in the token pill info [#11886](https://github.com/penpot/penpot/issues/11886) (PR: [#11900](https://github.com/penpot/penpot/pull/11900))
 - Hide the duplicate cursor when alt-dragging a shape that cannot be duplicated (by @0xTHAC0) [#11905](https://github.com/penpot/penpot/issues/11905) (PR: [#11195](https://github.com/penpot/penpot/pull/11195))
+## 2.18.4
+
+### :bug: Bugs fixed
+
+- Fix storage GC deleting nothing when one pending object is still referenced [#12276](https://github.com/penpot/penpot/issues/12276) (PR: [#12269](https://github.com/penpot/penpot/pull/12269))
+- Fix objects GC stopping file deletion when one file still has a child row [#12277](https://github.com/penpot/penpot/issues/12277) (PR: [#12269](https://github.com/penpot/penpot/pull/12269))
+- Fix file restore leaving its storage objects marked for deletion [#12278](https://github.com/penpot/penpot/issues/12278) (PR: [#12269](https://github.com/penpot/penpot/pull/12269))
+- Fix backend workers staying parked forever when nested calls take the same concurrency limits [#12279](https://github.com/penpot/penpot/issues/12279) (PR: [#12269](https://github.com/penpot/penpot/pull/12269))
+- Fix one profile's activity blocking the audit events of every other profile [#12280](https://github.com/penpot/penpot/issues/12280) (PR: [#12269](https://github.com/penpot/penpot/pull/12269))
+
+### :sparkles: New features & Enhancements
+
+- Add a graceful instance drain through the /readyz endpoint [#12281](https://github.com/penpot/penpot/issues/12281) (PR: [#12269](https://github.com/penpot/penpot/pull/12269))
+- Add an accumulated queue gauge to the CLIMIT metrics [#12282](https://github.com/penpot/penpot/issues/12282) (PR: [#12269](https://github.com/penpot/penpot/pull/12269))
 
 ## 2.18.3
 

backend/resources/climit.edn

@@ -1,66 +1,77 @@
 ;; Example climit.edn file
 ;; Required: permits
-;; Optional: queue, ommited means Integer/MAX_VALUE
-;; Optional: timeout, ommited means no timeout
-;; Note: queue and timeout are excluding
-{:update-file/global {:permits 20}
+;; Optional: queue, omitted means Integer/MAX_VALUE (unbounded)
+;; Optional: timeout in milliseconds, omitted means the thread waits for a
+;; permit forever, and a saturated limiter parks it for good. Values below:
+;; 60s for operations that can be slow (file updates, images, fonts, thumbnails,
+;; snapshots, imports) and 30s for the rest.
+;; Note: a queue bounds how many waiters pile up, a timeout bounds how long one
+;; waiter waits. Every entry sets a timeout; the by-profile ones also set a
+;; queue, which is where a pile-up hurts.
+{:update-file/global
+ {:permits 20 :timeout 60000}
  :update-file/by-profile
- {:permits 1 :queue 5}
+ {:permits 1 :queue 5 :timeout 60000}
 
- :process-font/global {:permits 4}
- :process-font/by-profile {:permits 1}
+ :process-font/global
+ {:permits 4 :timeout 60000}
+ :process-font/by-profile
+ {:permits 1 :timeout 60000}
 
- :process-image/global {:permits 8}
- :process-image/by-profile {:permits 1}
+ :process-image/global
+ {:permits 8 :timeout 60000}
+ :process-image/by-profile
+ {:permits 1 :timeout 60000}
 
- :auth/global {:permits 8}
+ :auth/global
+ {:permits 8 :timeout 30000}
 
  :root/global
- {:permits 40}
+ {:permits 40 :timeout 30000}
 
  :root/by-profile
  {:permits 10 :queue 30 :timeout 30000}
 
  :file-thumbnail-ops/global
- {:permits 20}
+ {:permits 20 :timeout 60000}
  :file-thumbnail-ops/by-profile
- {:permits 2}
+ {:permits 2 :timeout 60000}
 
  :submit-audit-events/by-profile
- {:permits 1 :queue 3}
+ {:permits 1 :queue 3 :timeout 30000}
 
  :restore-file-snapshot/global
- {:permits 3}
+ {:permits 3 :timeout 60000}
 
  :restore-file-snapshot/by-profile
  {:permits 1 :queue 2 :timeout 60000}
 
  :create-file-snapshot/global
- {:permits 3}
+ {:permits 3 :timeout 60000}
 
  :create-file-snapshot/by-profile
  {:permits 1 :queue 2 :timeout 60000}
 
  :send-user-feedback/global
- {:permits 4}
+ {:permits 4 :timeout 30000}
 
  :send-user-feedback/by-profile
- {:permits 1 :queue 3}
+ {:permits 1 :queue 3 :timeout 30000}
 
  :import-binfile/global
- {:permits 4}
+ {:permits 4 :timeout 60000}
 
  :import-binfile/by-profile
- {:permits 1 :queue 2}
+ {:permits 1 :queue 2 :timeout 60000}
 
  :create-import-binfile-job/global
- {:permits 4}
+ {:permits 4 :timeout 60000}
 
  :create-import-binfile-job/by-profile
- {:permits 1 :queue 2}
+ {:permits 1 :queue 2 :timeout 60000}
 
  :profile-plugin-ops/global
- {:permits 4}
+ {:permits 4 :timeout 30000}
 
  :profile-plugin-ops/by-profile
- {:permits 1 :queue 2}}
+ {:permits 1 :queue 2 :timeout 30000}}

backend/src/app/config.clj

@@ -215,7 +215,6 @@
     [:audit-log-http-handler-concurrency {:optional true} ::sm/int]
 
     [:default-executor-parallelism {:optional true} ::sm/int] ;; REVIEW
-    [:scheduled-executor-parallelism {:optional true} ::sm/int] ;; REVIEW
     [:worker-default-parallelism {:optional true} ::sm/int]
     [:worker-webhook-parallelism {:optional true} ::sm/int]
     [:worker-cron-parallelism {:optional true} ::sm/int]

backend/src/app/health.clj

@@ -0,0 +1,45 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) KALEIDOS INC Sucursal en España SL
+
+(ns app.health
+  "Instance availability state.
+
+  A single flag tells whether this backend instance is willing to receive
+  traffic. The readiness endpoint (`/readyz`) reports the instance as
+  unavailable while the flag is off, so the load balancer removes it from
+  rotation. Requests already in flight are still served.
+
+  The state is a plain global atom and not an Integrant component because
+  it must also exist on a bare REPL session, which is where the srepl
+  helpers change it."
+  (:require
+   [app.common.logging :as l]))
+
+(defonce state
+  (atom true))
+
+(defn online?
+  "Returns true when this instance is able to receive traffic."
+  []
+  @state)
+
+(defn set-offline
+  "Marks the instance as offline. The `/readyz` endpoint answers 503 until
+  `set-online` is called again.
+
+  Use it to drain the instance from the load balancer before a restart:
+  the load balancer stops sending new requests and the requests in flight
+  finish on their own."
+  []
+  (l/inf :hint "instance set offline" :endpoint "/readyz")
+  (swap! state (constantly false)))
+
+(defn set-online
+  "Marks the instance as online again, so the load balancer sends it
+  traffic."
+  []
+  (l/inf :hint "instance set online" :endpoint "/readyz")
+  (swap! state (constantly true)))

backend/src/app/http.clj

@@ -55,21 +55,19 @@
 
 (defn sample-worker-metrics
   "Publishes the current state of the xnio worker thread pool (the
-  request dispatch queue and its threads) as gauges."
+  request dispatch queue and its threads) as gauges. The pool size is the
+  signal to watch: the busy thread count of this MXBean stays at zero with
+  threads blocked inside a concurrency limiter, so it is not published."
   [metrics ^XnioWorkerMXBean mxbean]
   (let [queue-size (.getWorkerQueueSize mxbean)
-        busy-count (.getBusyWorkerThreadCount mxbean)
         pool-size  (.getWorkerPoolSize mxbean)
         max-size   (.getMaxWorkerPoolSize mxbean)]
 
-    ;; negative values are missing measurements, not zeros: the xnio
-    ;; MXBean may transiently report -1 on the busy thread count.
+    ;; negative values are missing measurements, not zeros: the xnio MXBean
+    ;; may transiently report -1.
     (when (>= queue-size 0)
       (mtx/run! metrics :id :http-worker-queue-size :val queue-size))
 
-    (when (>= busy-count 0)
-      (mtx/run! metrics :id :http-worker-busy-threads :val busy-count))
-
     (when (>= pool-size 0)
       (mtx/run! metrics :id :http-worker-pool-size :val pool-size))
 
@@ -121,26 +119,14 @@
 
 (defn create-metrics-sampler
   "Creates a daemon scheduler that periodically samples the state of
-  the http server and publishes it as metrics. A single thread is used,
-  and an unexpected error on a single sample does NOT cancel the
-  subsequent runs."
+  the http server and publishes it as metrics, in the shape shared by
+  `app.metrics/create-sampler`: a single thread, and an unexpected error
+  on one sample does not cancel the following runs."
   [^Undertow server metrics]
-  (let [state     (atom {:last-requests 0 :last-errors 0})
-        scheduler (px/scheduled-executor
-                   :parallelism 1
-                   :factory (px/thread-factory :prefix "penpot/http-metrics/"
-                                               :daemon true))
-        sample    (fn sample []
-                    (try
-                      (sample-http-metrics metrics state server)
-                      (finally
-                        ;; reschedule even if a single sample fails, so
-                        ;; an unexpected error does not cancel the
-                        ;; following runs.
-                        (px/schedule scheduler metrics-sample-interval-ms sample))))]
-
-    (px/schedule scheduler 0 sample)
-    scheduler))
+  (let [state (atom {:last-requests 0 :last-errors 0})]
+    (mtx/create-sampler metrics-sample-interval-ms
+                        (fn [] (sample-http-metrics metrics state server))
+                        {:name "http-metrics"})))
 
 (defmethod ig/expand-key ::server
   [k v]

backend/src/app/http/debug.clj

@@ -25,6 +25,7 @@
    [app.config :as cf]
    [app.db :as db]
    [app.features.file-migrations :as feat.fmig]
+   [app.health :as health]
    [app.http.session :as session]
    [app.redis :as rds]
    [app.rpc.commands.auth :as auth]
@@ -857,17 +858,23 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (defn health-handler
-  "Mainly a task that performs a health check."
+  "Mainly a task that performs a health check. When the instance is marked
+  as offline (see `app.health`), it reports the instance as unavailable
+  without querying the database, so the load balancer drains it while the
+  requests in flight are still served."
   [{:keys [::db/pool]} _]
-  (try
-    (db/exec-one! pool ["select count(*) as count from server_prop;"])
-    {::yres/status 200
-     ::yres/body "OK"}
-    (catch Throwable cause
-      (l/warn :hint "unable to execute query on health handler"
-              :cause cause)
-      {::yres/status 503
-       ::yres/body "KO"})))
+  (if (health/online?)
+    (try
+      (db/exec-one! pool ["select count(*) as count from server_prop;"])
+      {::yres/status 200
+       ::yres/body "OK"}
+      (catch Throwable cause
+        (l/warn :hint "unable to execute query on health handler"
+                :cause cause)
+        {::yres/status 503
+         ::yres/body "KO"}))
+    {::yres/status 503
+     ::yres/body "OFFLINE"}))
 
 (defn changelog-handler
   [_ _]

backend/src/app/main.clj

@@ -114,17 +114,17 @@
     ::mdef/labels ["name"]
     ::mdef/type :histogram}
 
-   :rpc-climit-queue
-   {::mdef/name "penpot_rpc_climit_queue"
-    ::mdef/help "Current number of queued submissions."
+   :rpc-climit-waiting
+   {::mdef/name "penpot_rpc_climit_waiting"
+    ::mdef/help "Calls of this limiter name waiting for a permit, on this instance."
     ::mdef/labels ["name"]
     ::mdef/type :gauge}
 
-   :rpc-climit-permits
-   {::mdef/name "penpot_rpc_climit_permits"
-    ::mdef/help "Current number of available permits"
-    ::mdef/labels ["name"]
-    ::mdef/type :gauge}
+   :rpc-climit-rejected
+   {::mdef/name "penpot_rpc_climit_rejected_total"
+    ::mdef/help "Calls rejected by this limiter, by name and reason."
+    ::mdef/labels ["name" "reason"]
+    ::mdef/type :counter}
 
    :rpc-climit-timing
    {::mdef/name "penpot_rpc_climit_timing"
@@ -204,11 +204,6 @@
     ::mdef/help "Current number of queued tasks in the http server xnio worker."
     ::mdef/type :gauge}
 
-   :http-worker-busy-threads
-   {::mdef/name "penpot_http_worker_busy_threads"
-    ::mdef/help "Current number of busy threads in the http server xnio worker."
-    ::mdef/type :gauge}
-
    :http-worker-pool-size
    {::mdef/name "penpot_http_worker_pool_size"
     ::mdef/help "Current number of threads in the http server xnio worker pool."

backend/src/app/metrics.clj

@@ -11,7 +11,8 @@
    [app.common.logging :as l]
    [app.common.schema :as sm]
    [app.metrics.definition :as-alias mdef]
-   [integrant.core :as ig])
+   [integrant.core :as ig]
+   [promesa.exec :as px])
   (:import
    io.prometheus.client.CollectorRegistry
    io.prometheus.client.Counter
@@ -203,6 +204,33 @@
         (report-safe-failure! (str "unable to record metric " (pr-str id)) cause)
         nil))))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; SAMPLER
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn create-sampler
+  "Create a daemon scheduler that runs `sample` every `interval-ms`,
+  starting right away. A single thread is used, named after `name`
+  (default `metrics`), and an unexpected error on a single sample does NOT
+  cancel the following runs: the next run is scheduled in a `finally`.
+  The caller owns the returned scheduler and has to shut it down
+  (`px/shutdown-now`) when its component halts."
+  ([interval-ms sample]
+   (create-sampler interval-ms sample {}))
+  ([interval-ms sample {:keys [name] :or {name "metrics"}}]
+   (let [prefix    (str "penpot/" name "/")
+         scheduler (px/scheduled-executor
+                    :parallelism 1
+                    :factory (px/thread-factory :prefix prefix :daemon true))
+         task      (fn task []
+                     (try
+                       (sample)
+                       (finally
+                         (px/schedule scheduler interval-ms task))))]
+
+     (px/schedule scheduler 0 task)
+     scheduler)))
+
 (defn- create-registry
   []
   (let [registry (CollectorRegistry.)]

backend/src/app/migrations.clj

@@ -520,7 +520,10 @@
     :fn (mg/resource "app/migrations/sql/0156-add-storage-object-json-dedup-index.sql")}
 
    {:name "0153-del-orphan-profile-rels-after-team-leave"
-    :fn (mg/resource "app/migrations/sql/0153-del-orphan-profile-rels-after-team-leave.sql")}])
+    :fn (mg/resource "app/migrations/sql/0153-del-orphan-profile-rels-after-team-leave.sql")}
+
+   {:name "0154-del-legacy-file-object-thumbnail-table"
+    :fn (mg/resource "app/migrations/sql/0154-del-legacy-file-object-thumbnail-table.sql")}])
 
 (defn apply-migrations!
   [pool name migrations]

backend/src/app/migrations/sql/0154-del-legacy-file-object-thumbnail-table.sql

@@ -0,0 +1,7 @@
+--- The `file_object_thumbnail` table was replaced by
+--- `file_tagged_object_thumbnail` and nothing references it anymore: no query
+--- in the codebase touches it and it is empty in production.
+---
+--- NOTE: the storage bucket named "file-object-thumbnail" (the one used by
+--- `file_tagged_object_thumbnail`) has nothing to do with this table and stays.
+DROP TABLE IF EXISTS file_object_thumbnail;

backend/src/app/rpc/climit.clj

@@ -21,10 +21,12 @@
    [clojure.set :as set]
    [datoteka.fs :as fs]
    [integrant.core :as ig]
+   [promesa.exec :as px]
    [promesa.exec.bulkhead :as pbh])
   (:import
    clojure.lang.ExceptionInfo
-   java.util.concurrent.atomic.AtomicLong))
+   java.util.concurrent.atomic.AtomicLong
+   java.util.concurrent.ConcurrentHashMap))
 
 (set! *warn-on-reflection* true)
 
@@ -54,6 +56,71 @@
 (def ^:private check-config
   (sm/check-fn schema:config))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; WAITING COUNTER
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(def ^:private waiting-sample-interval-ms 15000)
+
+(defn- create-waiting-counters
+  "Per limiter name, how many calls on this instance are waiting for a
+  permit. Every limiter of a name adds to the same entry, so the value does
+  not depend on which of them ran last the way a sampled gauge does: a
+  request that enters and never leaves stays visible for ever. The map
+  belongs to the component, so its counts die with it instead of surviving
+  into the next system built in the same JVM."
+  []
+  (ConcurrentHashMap.))
+
+(defn- waiting-counter
+  ^AtomicLong
+  [^ConcurrentHashMap counters name]
+  (.computeIfAbsent counters name
+                    (reify java.util.function.Function
+                      (apply [_ _] (AtomicLong. 0)))))
+
+(defn- publish-waiting
+  [metrics name value]
+  (mtx/run! metrics
+            :id :rpc-climit-waiting
+            :val value
+            :labels (into-array String [name])))
+
+(defn- waiting-inc
+  [metrics counters name]
+  (publish-waiting metrics name (.incrementAndGet (waiting-counter counters name))))
+
+(defn- waiting-dec
+  [metrics counters name]
+  (publish-waiting metrics name (.decrementAndGet (waiting-counter counters name))))
+
+(defn- republish-waiting
+  "Publish the waiting count of every name again. A count that stops changing
+  (a limiter whose requests never come back and whose traffic died) has to keep
+  being written, or the series goes stale and the pile-up disappears."
+  [metrics counters]
+  (doseq [[name counter] counters]
+    (publish-waiting metrics name (.get ^AtomicLong counter))))
+
+(defn- create-waiting-sampler
+  "A daemon sampler that republishes the waiting counts of this component."
+  [metrics counters]
+  (mtx/create-sampler waiting-sample-interval-ms
+                      (fn [] (republish-waiting metrics counters))
+                      {:name "climit-metrics"}))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; COMPONENT
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defrecord ConcurrencyLimiter [params cache metrics counters sampler]
+  IConcurrencyLimiter
+  (get-config [_ id]
+    (get params id))
+
+  (invoke [_ config handler]
+    (impl-invoke metrics counters cache config handler)))
+
 (def ^:private schema:climit-params
   [:map
    ::mtx/metrics
@@ -70,19 +137,24 @@
   (when enabled
     (when-let [params (some->> config slurp edn/read-string check-config)]
       (l/inf :hint "initializing concurrency limit" :config (str config))
-      (let [params (reduce-kv (fn [result k v]
-                                (assoc result k (assoc v ::id k)))
-                              params
-                              params)
-            cache  (create-cache cfg)]
+      (let [params   (reduce-kv (fn [result k v]
+                                  (when-not (:timeout v)
+                                    (l/wrn :hint "limiter without timeout, a saturated one parks its threads forever"
+                                           :id k))
+                                  (assoc result k (assoc v ::id k)))
+                                params
+                                params)
+            cache    (create-cache cfg)
+            counters (create-waiting-counters)]
 
-        (reify
-          IConcurrencyLimiter
-          (get-config [_ id]
-            (get params id))
+        (->ConcurrencyLimiter params cache metrics counters
+                              (create-waiting-sampler metrics counters))))))
 
-          (invoke [_ config handler]
-            (impl-invoke metrics cache config handler)))))))
+(defmethod ig/halt-key! ::rpc/climit
+  [_ instance]
+  (when-let [sampler (:sampler instance)]
+    (l/inf :hint "stopping concurrency limit metrics")
+    (px/shutdown-now sampler)))
 
 (defn- id->str
   ([id]
@@ -110,28 +182,15 @@
                   :keepalive "5m")))
 
 (defn- measure
-  [metrics mlabels stats elapsed]
-  (let [mpermits (:max-permits stats)
-        permits  (:permits stats)
-        queue    (:queue stats)
-        queue    (- queue mpermits)
-        queue    (if (neg? queue) 0 queue)]
-
-    (mtx/run! metrics
-              :id :rpc-climit-queue
-              :val queue
-              :labels mlabels)
-
-    (mtx/run! metrics
-              :id :rpc-climit-permits
-              :val permits
-              :labels mlabels)
-
-    (when elapsed
-      (mtx/run! metrics
-                :id :rpc-climit-timing
-                :val (inst-ms elapsed)
-                :labels mlabels))))
+  "Publish the wait time of a call that got its permit, in milliseconds. The
+  queue is not published here: a gauge written by whichever limiter of the name
+  ran last cannot show it, and the `:rpc-climit-waiting` gauge accumulates the
+  entries and the exits instead."
+  [metrics mlabels elapsed]
+  (mtx/run! metrics
+            :id :rpc-climit-timing
+            :val (inst-ms elapsed)
+            :labels mlabels))
 
 (defn- prepare-params-for-debug
   [params]
@@ -140,7 +199,7 @@
       (update-vals str)))
 
 (defn- log
-  [action req-id stats limit-id limit-label limit-params elapsed]
+  [{:keys [id label params permits queue-max]} action req-id stats elapsed code reason]
   (let [mpermits (:max-permits stats)
         queue    (:queue stats)
         queue    (- queue mpermits)
@@ -150,58 +209,109 @@
     (l/log level
            :hint action
            :req req-id
-           :id limit-id
-           :label limit-label
+           :id id
+           :label label
            :queue queue
+           :queue-max queue-max
+           :permits permits
            :elapsed (some-> elapsed ct/format-duration)
-           :params @limit-params)))
+           :code code
+           :reason reason
+           :params @params)))
 
 (def ^:private idseq (AtomicLong. 0))
 
+(def ^:private ^ThreadLocal held-limiters
+  ;; Limiters a thread is inside of, identified by the limiter instance, which
+  ;; already encodes the limit id and its key: the cache is per id+key pair.
+  ;; `pbh/invoke!` runs the handler on the calling thread, so a handler that
+  ;; enters climit again for a limit it holds finds it here. Without this a
+  ;; thread parks forever behind a permit it holds itself.
+  (ThreadLocal/withInitial
+   (reify java.util.function.Supplier
+     (get [_] (java.util.HashSet.)))))
+
 (defn- impl-invoke
-  [metrics cache config handler]
+  [metrics counters cache config handler]
   (let [limit-id     (::id config)
         limit-key    (::key config)
         limit-label  (::label config)
+        limit-name   (id->str limit-id)
         limit-params (delay
                        (prepare-params-for-debug
                         (::params config)))
 
-        mlabels     (into-array String [(id->str limit-id)])
-        limit-id    (id->str limit-id limit-key)
-        limiter     (cache/get cache limit-id (partial create-limiter config))
-        tpoint      (ct/tpoint)
-        req-id      (.incrementAndGet ^AtomicLong idseq)]
-    (try
-      (let [stats (pbh/get-stats limiter)]
-        (measure metrics mlabels stats nil)
-        (log "enqueued" req-id stats limit-id limit-label limit-params nil))
+        mlabels      (into-array String [limit-name])
+        limit-id     (id->str limit-id limit-key)
+        limit        {:id limit-id
+                      :label limit-label
+                      :params limit-params
+                      :permits (or (:permits config) (:concurrency config) 1)
+                      :queue-max (or (:queue config) (:queue-size config))}
+        limiter      (cache/get cache limit-id (partial create-limiter config))
+        held         ^java.util.Set (.get ^ThreadLocal held-limiters)]
 
-      (pbh/invoke! limiter (fn []
-                             (let [elapsed (tpoint)
-                                   stats   (pbh/get-stats limiter)]
-                               (measure metrics mlabels stats elapsed)
-                               (log "acquired" req-id stats limit-id limit-label limit-params elapsed)
-                               (handler))))
+    (if (.contains held limiter)
+      ;; The calling thread already holds this limiter for this key: run the
+      ;; handler inline instead of queueing behind itself.
+      (do
+        (l/trc :hint "reentrant invocation" :id limit-id :label limit-label)
+        (handler))
 
-      (catch ExceptionInfo cause
-        (let [{:keys [type code]} (ex-data cause)]
-          (if (= :bulkhead-error type)
+      (let [tpoint        (ct/tpoint)
+            req-id        (.incrementAndGet ^AtomicLong idseq)
+            waiting       (volatile! true)
+            stop-waiting  (fn []
+                            ;; Exactly one decrement per increment: the flag
+                            ;; makes a second call a no-op and the `finally`
+                            ;; guarantees that there is one.
+                            (when @waiting
+                              (vreset! waiting false)
+                              (waiting-dec metrics counters limit-name)))]
+
+        (.add held limiter)
+
+        (try
+          ;; The increment lives inside the `try`, so a throwable from the
+          ;; publishing path unwinds through the `finally`: the thread drops the
+          ;; mark and the count comes back down instead of staying up for good.
+          (waiting-inc metrics counters limit-name)
+
+          (let [stats (pbh/get-stats limiter)]
+            (log limit "enqueued" req-id stats nil nil nil))
+
+          (pbh/invoke! limiter (fn []
+                                 (stop-waiting)
+                                 (let [elapsed (tpoint)
+                                       stats   (pbh/get-stats limiter)]
+                                   (measure metrics mlabels elapsed)
+                                   (log limit "acquired" req-id stats elapsed nil nil)
+                                   (handler))))
+
+          (catch ExceptionInfo cause
+            (let [{:keys [type code] :as data} (ex-data cause)]
+              (if (= :bulkhead-error type)
+                (let [elapsed (tpoint)
+                      stats   (pbh/get-stats limiter)
+                      reason  (if (some? (:timeout data)) "timeout" "queue-full")]
+                  (mtx/run! metrics
+                            :id :rpc-climit-rejected
+                            :inc 1
+                            :labels (into-array String [limit-name reason]))
+                  (log limit "rejected" req-id stats elapsed code reason)
+                  (ex/raise :type :concurrency-limit
+                            :code code
+                            :hint "concurrency limit reached"
+                            :cause cause))
+                (throw cause))))
+
+          (finally
+            (.remove held limiter)
+            (stop-waiting)
             (let [elapsed (tpoint)
                   stats   (pbh/get-stats limiter)]
-              (log "rejected" req-id stats limit-id limit-label limit-params elapsed)
-              (ex/raise :type :concurrency-limit
-                        :code code
-                        :hint "concurrency limit reached"
-                        :cause cause))
-            (throw cause))))
 
-      (finally
-        (let [elapsed (tpoint)
-              stats (pbh/get-stats limiter)]
-
-          (measure metrics mlabels stats nil)
-          (log "finished" req-id stats limit-id limit-label limit-params elapsed))))))
+              (log limit "finished" req-id stats elapsed nil nil))))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; MIDDLEWARE
@@ -263,7 +373,13 @@
                   (l/wrn :hint "no config found for specified queue" :id (id->str limit-id))
                   handler)))
             handler
-            (concat global-limits (get-limits mdata)))
+            ;; The root limiters go last so they end up outermost: every path
+            ;; meets them before the command's own limits. The nested
+            ;; `climit/invoke!` chains carry only the command's own limits and
+            ;; run inside those of the enclosing call, so this puts both paths
+            ;; in the same order. With the opposite order two calls of the same
+            ;; profile hold the same limiters inverted and park for good.
+            (concat (get-limits mdata) global-limits))
 
     handler))
 

backend/src/app/rpc/commands/audit.clj

@@ -162,8 +162,7 @@
    [:events [:vector schema:frontend-event]]])
 
 (sv/defmethod ::push-audit-events
-  {::climit/id :submit-audit-events/by-profile
-   ::climit/key-fn ::rpc/profile-id
+  {::climit/id [[:submit-audit-events/by-profile ::rpc/profile-id]]
    ::sm/params schema:push-audit-events
    ::audit/skip true
    ::doc/skip true

backend/src/app/rpc/commands/files.clj

@@ -1382,6 +1382,40 @@
   "UPDATE file_tagged_object_thumbnail SET deleted_at = null
     WHERE file_id = ANY(?::uuid[])")
 
+(def ^:private sql:restore-storage-objects
+  "WITH ids AS (SELECT unnest(?::uuid[]) AS file_id)
+
+   UPDATE storage_object
+      SET deleted_at = null
+    WHERE deleted_at IS NOT NULL
+      AND (id IN (SELECT media_id
+                    FROM file_media_object AS fmo
+                    JOIN ids ON (ids.file_id = fmo.file_id)
+                   WHERE fmo.deleted_at IS NULL
+                     AND fmo.media_id IS NOT NULL
+                  UNION
+                  SELECT thumbnail_id
+                    FROM file_media_object AS fmo
+                    JOIN ids ON (ids.file_id = fmo.file_id)
+                   WHERE fmo.deleted_at IS NULL
+                     AND fmo.thumbnail_id IS NOT NULL
+                  UNION
+                  SELECT ft.media_id
+                    FROM file_thumbnail AS ft
+                    JOIN ids ON (ids.file_id = ft.file_id)
+                   WHERE ft.deleted_at IS NULL
+                     AND ft.media_id IS NOT NULL
+                  UNION
+                  SELECT fot.media_id
+                    FROM file_tagged_object_thumbnail AS fot
+                    JOIN ids ON (ids.file_id = fot.file_id)
+                   WHERE fot.deleted_at IS NULL
+                     AND fot.media_id IS NOT NULL)
+           OR id::text IN (SELECT fd.metadata->>'storage-ref-id'
+                             FROM file_data AS fd
+                             JOIN ids ON (ids.file_id = fd.file_id)
+                            WHERE fd.deleted_at IS NULL))")
+
 (defn- restore-files
   [conn file-ids]
   (let [file-ids (db/create-array conn "uuid" file-ids)]
@@ -1390,7 +1424,13 @@
     (db/exec-one! conn [sql:restore-file-changes file-ids])
     (db/exec-one! conn [sql:restore-file-data file-ids])
     (db/exec-one! conn [sql:restore-file-thumbnails file-ids])
-    (db/exec-one! conn [sql:restore-file-tagged-object-thumbnails file-ids])))
+    (db/exec-one! conn [sql:restore-file-tagged-object-thumbnails file-ids])
+
+    ;; NOTE: the storage objects referenced by the rows we just brought back
+    ;; must stop being marked for deletion. The storage GC cannot delete an
+    ;; object that a live row references (those foreign keys are `NO ACTION`),
+    ;; so a marked object that comes back to life is skipped forever otherwise.
+    (db/exec-one! conn [sql:restore-storage-objects file-ids])))
 
 (def ^:private sql:restore-projects
   "UPDATE project SET deleted_at = null WHERE id = ANY(?::uuid[])")

backend/src/app/srepl/main.clj

@@ -25,6 +25,7 @@
    [app.db.sql :as-alias sql]
    [app.features.fdata :as fdata]
    [app.features.file-snapshots :as fsnap]
+   [app.health :as health]
    [app.http.session :as session]
    [app.jobs :as jobs]
    [app.loggers.audit :as audit]
@@ -96,6 +97,30 @@
                       profile (profile/get-profile-by-email conn email)]
                   (#'auth/send-email-verification! cfg profile)))))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; INSTANCE AVAILABILITY
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn set-offline
+  "Take this instance out of the load balancer.
+
+  The `/readyz` endpoint starts answering 503, so the load balancer
+  removes the instance from rotation. Requests already in flight are
+  still served; wait for the load balancer to notice and for the traffic
+  to drop before restarting the process.
+
+  A restarted process comes back online on its own."
+  []
+  (health/set-offline))
+
+(defn set-online
+  "Put this instance back into the load balancer rotation.
+
+  Only needed to undo a `set-offline` without a restart; a restarted
+  process starts online."
+  []
+  (health/set-online))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; PROFILES MANAGEMENT
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -768,6 +793,15 @@
                                            :id team-id})))
     :deleted))
 
+(def ^:private sql:restore-font-file-objects
+  "UPDATE storage_object
+      SET deleted_at = null
+    WHERE deleted_at IS NOT NULL
+      AND id IN (SELECT unnest(array[woff1_file_id, woff2_file_id, otf_file_id, ttf_file_id])
+                   FROM team_font_variant
+                  WHERE team_id = ?::uuid
+                    AND deleted_at IS NULL)")
+
 (defn- restore-team*
   [{:keys [::db/conn] :as cfg} team-id]
   (db/update! conn :team
@@ -778,6 +812,11 @@
               {:deleted-at nil}
               {:team-id team-id})
 
+  ;; Same as in `restore-files`: the font objects of the variants we just
+  ;; brought back must stop being marked for deletion, or the storage GC will
+  ;; skip them forever (those foreign keys are `NO ACTION`).
+  (db/exec-one! conn [sql:restore-font-file-objects team-id])
+
   (doseq [{:keys [id]} (db/query conn :project
                                  {:team-id team-id}
                                  {::sql/columns [:id]})]
@@ -876,45 +915,69 @@
 ;; CASCADE FIXING
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+(defn- submit-deleted-cascade
+  "Replay the deletion cascade of every soft-deleted row of `table`, by
+  submitting one `:delete-object` job per row.
+
+  Reads the rows with a server-side cursor (`db/plan`) instead of materialising
+  the whole table, and enqueues the job instead of running it inline, so it
+  can be used against production in bounded batches. The job is idempotent (it
+  only marks the children with the row's own date), `label` is the row id and
+  `dedupe` drops not-yet-due duplicates.
+
+  Options: `:limit` (max rows read), `:ids` (restrict the run to these row ids)
+  and `:dry-run?` (count without enqueueing). `table` and `object` are internal
+  constants, never operator input.
+
+  Returns `{:found n :submitted m}`.
+
+  Note: the submissions are given the outer `system` (with the pool) on
+  purpose; handing them the read-only transaction cfg would write on it."
+  [system {:keys [table object limit ids dry-run?]}]
+  (let [clauses (cond-> ["deleted_at is not null"]
+                  (seq ids) (conj "id = any(?)"))
+        sql     (str "select id, deleted_at from " table
+                     " where " (str/join " and " clauses)
+                     (when limit (str " limit " (long limit))))]
+
+    (db/tx-run! (assoc system ::db/read-only true)
+                (fn [{:keys [::db/conn]}]
+                  (let [query (cond-> [sql]
+                                (seq ids) (conj (db/create-array conn "uuid" ids)))
+                        found (reduce (fn [total {:keys [id deleted-at]}]
+                                        (when-not dry-run?
+                                          (jobs/submit system
+                                                       {::jobs/name :delete-object
+                                                        ::jobs/params {:object object
+                                                                       :deleted-at deleted-at
+                                                                       :id id}
+                                                        ::jobs/label (str id)
+                                                        ::jobs/dedupe true}))
+                                        (inc total))
+                                      0
+                                      (db/plan conn query))]
+                    {:found found
+                     :submitted (if dry-run? 0 found)})))))
+
 (defn process-deleted-profiles-cascade
-  []
-  (->> (db/exec! sys/system ["select id, deleted_at from profile where deleted_at is not null"])
-       (run! (fn [{:keys [id deleted-at]}]
-               (jobs/invoke (-> sys/system
-                                (assoc ::jobs/name :delete-object)
-                                (assoc ::jobs/params {:object :profile
-                                                      :deleted-at deleted-at
-                                                      :id id})))))))
+  "Replay the deletion cascade of every soft-deleted profile."
+  [& {:as opts}]
+  (submit-deleted-cascade sys/system (merge {:table "profile" :object :profile} opts)))
 
 (defn process-deleted-teams-cascade
-  []
-  (->> (db/exec! sys/system ["select id, deleted_at from team where deleted_at is not null"])
-       (run! (fn [{:keys [id deleted-at]}]
-               (jobs/invoke (-> sys/system
-                                (assoc ::jobs/name :delete-object)
-                                (assoc ::jobs/params {:object :team
-                                                      :deleted-at deleted-at
-                                                      :id id})))))))
+  "Replay the deletion cascade of every soft-deleted team."
+  [& {:as opts}]
+  (submit-deleted-cascade sys/system (merge {:table "team" :object :team} opts)))
 
 (defn process-deleted-projects-cascade
-  []
-  (->> (db/exec! sys/system ["select id, deleted_at from project where deleted_at is not null"])
-       (run! (fn [{:keys [id deleted-at]}]
-               (jobs/invoke (-> sys/system
-                                (assoc ::jobs/name :delete-object)
-                                (assoc ::jobs/params {:object :project
-                                                      :deleted-at deleted-at
-                                                      :id id})))))))
+  "Replay the deletion cascade of every soft-deleted project."
+  [& {:as opts}]
+  (submit-deleted-cascade sys/system (merge {:table "project" :object :project} opts)))
 
 (defn process-deleted-files-cascade
-  []
-  (->> (db/exec! sys/system ["select id, deleted_at from file where deleted_at is not null"])
-       (run! (fn [{:keys [id deleted-at]}]
-               (jobs/invoke (-> sys/system
-                                (assoc ::jobs/name :delete-object)
-                                (assoc ::jobs/params {:object :file
-                                                      :deleted-at deleted-at
-                                                      :id id})))))))
+  "Replay the deletion cascade of every soft-deleted file."
+  [& {:as opts}]
+  (submit-deleted-cascade sys/system (merge {:table "file" :object :file} opts)))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; SSO

backend/src/app/storage/gc_deleted.clj

@@ -30,7 +30,7 @@
   7)
 
 (def ^:private chunk-size
-  "Number of rows to process per transaction."
+  "Pending objects deleted in each transaction."
   25)
 
 (def ^:private sql:lock-sobjects
@@ -95,9 +95,9 @@
 (defn- process-chunk
   "Attempt to delete a chunk of storage objects from a specific backend.
 
-  This function runs inside the caller's transaction (clean-deleted) —
-  it does NOT open its own transaction. The caller is responsible for
-  ensuring the rows are locked via FOR UPDATE SKIP LOCKED before calling.
+  This function runs inside the chunk's own transaction (see
+  `delete-in-bulk`) — it does NOT open its own transaction. The rows are
+  locked via FOR UPDATE SKIP LOCKED before deleting.
 
   Returns the number of successfully deleted objects, or 0 if no rows
   could be locked."
@@ -143,43 +143,70 @@
       (count ok-ids))
     0))
 
+(defn- delete-in-bulk
+  [cfg backend-id ids]
+  ;; Each chunk runs in its own transaction, on its own connection: a chunk
+  ;; that fails (for example, an object that a foreign key still references) is
+  ;; logged and skipped, and it cannot poison the cursor that feeds the rest.
+  (try
+    (db/tx-run! cfg
+                (fn [{:keys [::db/conn ::sto/storage]}]
+                  (process-chunk conn storage backend-id ids)))
+    (catch Throwable cause
+      (l/err :hint "unexpected error on bulk deletion, skipping chunk"
+             :ids ids
+             :cause cause)
+      0)))
+
 (defn- group-by-backend
   [items]
   (d/group-by (comp keyword :backend) :id #{} items))
 
-(def ^:private sql:get-deleted-chunk
+(def ^:private sql:get-deleted-sobjects
   "SELECT id, backend
      FROM storage_object
     WHERE deleted_at IS NOT NULL
       AND deleted_at <= ?
       AND status = 'valid'
-    ORDER BY deleted_at ASC
-    LIMIT ?
-      FOR UPDATE
-     SKIP LOCKED")
+    ORDER BY deleted_at ASC")
 
-(defn- get-deleted-chunk
-  [conn size]
-  (db/exec! conn [sql:get-deleted-chunk (ct/now) size]))
+(defn- pending-row
+  "Takes the columns the GC needs from a `db/plan` row.
+
+  A plan row is a view over the open result set, valid only while the reduction
+  is running, so it cannot be stored for later: this has to happen inside the
+  reducing function."
+  [row]
+  {:id (:id row)
+   :backend (:backend row)})
 
 (defn- clean-deleted
+  "Walks the pending objects with `db/plan`, a server-side cursor that streams
+  the rows instead of materialising them, and deletes them chunk by chunk.
+
+  The rows are read in their own read-only transaction and every chunk of
+  `chunk-size` objects is deleted in its own one (see `delete-in-bulk`), so a
+  chunk that fails is logged and skipped instead of aborting the whole run, and
+  the work of the previous chunks is already committed. A physical-deletion
+  failure inside a chunk defers its rows one day and gives up after
+  `max-attempts` attempts (see `process-chunk`)."
   [cfg]
-  (loop [total 0]
-    (let [deleted (db/tx-run! cfg
-                              (fn [{:keys [::db/conn ::sto/storage]}]
-                                (let [chunk (get-deleted-chunk conn chunk-size)]
-                                  (when (seq chunk)
-                                    (let [by-backend (group-by-backend chunk)]
-                                      (reduce-kv (fn [acc backend-id ids]
-                                                   (+ acc (process-chunk conn storage backend-id ids)))
-                                                 0
-                                                 by-backend))))))]
-      ;; Heartbeat per chunk: each chunk commits on its own, so a long
-      ;; sweep neither loses work on late failure nor outruns the lease.
-      (jobs/heartbeat cfg)
-      (if deleted
-        (recur (+ total deleted))
-        total))))
+  (let [xform (comp (map pending-row)
+                    (partition-all chunk-size)
+                    (mapcat group-by-backend))
+        rf    (fn
+                ([total] total)
+                ([total [backend-id ids]]
+                 (let [deleted (or (delete-in-bulk cfg backend-id ids) 0)]
+                   ;; Beat the job after every chunk: each chunk commits on its
+                   ;; own, so a long sweep neither loses work on a late failure
+                   ;; nor outruns the orphan lease.
+                   (jobs/heartbeat cfg)
+                   (+ total deleted))))]
+    (db/tx-run! (assoc cfg ::db/read-only true)
+                (fn [{:keys [::db/conn]}]
+                  (transduce xform rf 0
+                             (db/plan conn [sql:get-deleted-sobjects (ct/now)]))))))
 
 (declare execute-storage-gc-deleted)
 

backend/src/app/tasks/objects_gc.clj

@@ -18,6 +18,21 @@
    [app.tasks.delete-object :as dobj]
    [integrant.core :as ig]))
 
+;; Each proc below streams its pending keys with `db/plan`, a server-side
+;; cursor, inside a read-only transaction of its own, and deletes them chunk
+;; by chunk, each chunk in a transaction of its own, unrelated to the plan
+;; one. A chunk that fails is rolled back on its own, reported with `l/err`
+;; and skipped, so it takes down its own work and nothing else: the run keeps
+;; going and the next run retries the skipped rows.
+;;
+;; A plan row is a view over the open result set, valid only while the
+;; reduction is running, so the key is read inside the reducing function:
+;; buffering the row itself yields nil columns.
+;;
+;; Every proc beats its job (`jobs/heartbeat`) after each processed chunk,
+;; through the pool and never through the chunk transaction, so a long backlog
+;; in a single proc cannot outrun the orphan lease.
+
 (def ^:private sql:get-upload-sessions
   "SELECT us.id
      FROM upload_session AS us
@@ -30,8 +45,21 @@
                    WHERE p.id = us.profile_id
                      AND p.deleted_at IS NOT NULL
                      AND p.deleted_at <= ?)
-    ORDER BY us.created_at ASC
-    LIMIT ?
+    ORDER BY us.created_at ASC")
+
+(def ^:private sql:lock-upload-sessions
+  "SELECT us.id
+     FROM upload_session AS us
+    WHERE us.id = ANY(?::uuid[])
+      AND ((us.deleted_at IS NOT NULL
+            AND us.deleted_at <= ?)
+        OR (us.deleted_at IS NULL
+            AND us.created_at <= ?)
+        OR EXISTS (SELECT 1
+                     FROM profile AS p
+                    WHERE p.id = us.profile_id
+                      AND p.deleted_at IS NOT NULL
+                      AND p.deleted_at <= ?))
       FOR UPDATE OF us
      SKIP LOCKED")
 
@@ -40,338 +68,628 @@
     WHERE session_id = ?
     RETURNING object_id")
 
-(defn- delete-upload-sessions!
-  "Purges consumed upload sessions (marked by assemble-chunks), stalled
-  sessions (never assembled within max-age) and sessions owned by profiles
-  pending purge. Referenced storage objects are touched so the storage GC
-  reclaims them with its usual delay; chunk mappings are removed before the
-  session row (NO ACTION foreign keys)."
-  [{:keys [::db/conn ::threshold ::chunk-size ::sto/storage] :as cfg}]
-  (let [stalled-threshold (ct/minus threshold {:hours 1})]
-    (->> (db/plan conn [sql:get-upload-sessions threshold stalled-threshold threshold chunk-size]
-                  {:fetch-size 5})
-         (reduce (fn [total {:keys [id]}]
-                   (l/trc :obj "upload-session" :id (str id))
+(defn- delete-upload-sessions-chunk
+  "Purges one chunk of consumed upload sessions (marked by assemble-chunks),
+  stalled sessions (never assembled within max-age) and sessions owned by
+  profiles pending purge. Referenced storage objects are touched so the
+  storage GC reclaims them with its usual delay; chunk mappings are removed
+  before the session row (NO ACTION foreign keys)."
+  [cfg ids]
+  (try
+    (db/tx-run! cfg
+                (fn [{:keys [::db/conn ::threshold ::sto/storage]}]
+                  (let [stalled-threshold (ct/minus threshold {:hours 1})
+                        ids (db/create-array conn "uuid" ids)]
+                    (->> (db/exec! conn [sql:lock-upload-sessions ids threshold stalled-threshold threshold])
+                         (reduce (fn [total {:keys [id]}]
+                                   (l/trc :obj "upload-session" :id (str id))
 
-                   ;; Remove the chunk mappings, marking as touched all
-                   ;; related storage objects in a single round-trip.
-                   (doseq [{:keys [object-id]} (db/exec! conn [sql:delete-session-chunks id])]
-                     (some->> object-id (sto/touch-object! storage)))
+                                   ;; Remove the chunk mappings, marking as touched all
+                                   ;; related storage objects in a single round-trip.
+                                   (doseq [{:keys [object-id]} (db/exec! conn [sql:delete-session-chunks id])]
+                                     (some->> object-id (sto/touch-object! storage)))
 
-                   (let [affected (-> (db/delete! conn :upload-session {:id id})
-                                      (db/get-update-count))]
-                     (+ total affected)))
-                 0))))
+                                   (let [affected (-> (db/delete! conn :upload-session {:id id})
+                                                      (db/get-update-count))]
+                                     (+ total affected)))
+                                 0)))))
+    (catch Throwable cause
+      (l/err :obj "upload-session"
+             :hint "error on chunk deletion, skipping it"
+             :chunk ids
+             :cause cause)
+      0)))
+
+(defn- delete-upload-sessions
+  [{:keys [::threshold ::chunk-size] :as cfg}]
+  (let [stalled-threshold (ct/minus threshold {:hours 1})
+        rf (fn ([total] total)
+             ([total chunk]
+              (let [deleted (delete-upload-sessions-chunk cfg chunk)]
+                (jobs/heartbeat cfg)
+                (+ total deleted))))]
+    (db/tx-run! (assoc cfg ::db/read-only true)
+                (fn [{:keys [::db/conn]}]
+                  (transduce (comp (map :id) (partition-all chunk-size)) rf 0
+                             (db/plan conn [sql:get-upload-sessions threshold stalled-threshold threshold]
+                                      {:fetch-size 5}))))))
 
 (def ^:private sql:get-profiles
-  "SELECT id, photo_id FROM profile
+  "SELECT id FROM profile
     WHERE deleted_at IS NOT NULL
       AND deleted_at <= ?
-    ORDER BY deleted_at ASC
-    LIMIT ?
+    ORDER BY deleted_at ASC")
+
+(def ^:private sql:lock-profiles
+  "SELECT id, photo_id, deleted_at FROM profile
+    WHERE id = ANY(?::uuid[])
+      AND deleted_at IS NOT NULL
+      AND deleted_at <= ?
       FOR UPDATE
      SKIP LOCKED")
 
-(defn- delete-profiles!
-  [{:keys [::db/conn ::timestamp ::threshold ::chunk-size ::sto/storage] :as cfg}]
-  (->> (db/plan conn [sql:get-profiles threshold chunk-size] {:fetch-size 5})
-       (reduce (fn [total {:keys [id photo-id]}]
-                 (l/trc :obj "profile" :id (str id))
+(defn- delete-profiles-chunk
+  [cfg ids]
+  (try
+    (db/tx-run! cfg
+                (fn [{:keys [::db/conn ::threshold ::sto/storage] :as cfg}]
+                  (db/exec-one! conn ["SET LOCAL rules.deletion_protection TO off"])
+                  (let [ids (db/create-array conn "uuid" ids)]
+                    (->> (db/exec! conn [sql:lock-profiles ids threshold])
+                         (reduce (fn [total {:keys [id photo-id deleted-at]}]
+                                   (l/trc :obj "profile" :id (str id))
 
-                 ;; Mark as deleted the storage object
-                 (some->> photo-id (sto/touch-object! storage))
+                                   ;; Mark as deleted the storage object
+                                   (some->> photo-id (sto/touch-object! storage))
 
-                 ;; Cascade soft-delete to owned teams, projects, files, etc.
-                 (dobj/delete-object cfg {:object :profile
-                                          :id id
-                                          :deleted-at timestamp})
+                                   ;; Cascade soft-delete to owned teams, projects, files, etc.
+                                   ;; with the deletion date of the profile, not the
+                                   ;; date of the run.
+                                   (dobj/delete-object cfg {:object :profile
+                                                            :id id
+                                                            :deleted-at deleted-at})
 
-                 (let [affected (-> (db/delete! conn :profile {:id id})
-                                    (db/get-update-count))]
-                   (+ total affected)))
-               0)))
+                                   (let [affected (-> (db/delete! conn :profile {:id id})
+                                                      (db/get-update-count))]
+                                     (+ total affected)))
+                                 0)))))
+    (catch Throwable cause
+      (l/err :obj "profile"
+             :hint "error on chunk deletion, skipping it"
+             :chunk ids
+             :cause cause)
+      0)))
+
+(defn- delete-profiles
+  [{:keys [::threshold ::chunk-size] :as cfg}]
+  (let [rf (fn ([total] total)
+             ([total chunk]
+              (let [deleted (delete-profiles-chunk cfg chunk)]
+                (jobs/heartbeat cfg)
+                (+ total deleted))))]
+    (db/tx-run! (assoc cfg ::db/read-only true)
+                (fn [{:keys [::db/conn]}]
+                  (transduce (comp (map :id) (partition-all chunk-size)) rf 0
+                             (db/plan conn [sql:get-profiles threshold]
+                                      {:fetch-size 5}))))))
 
 (def ^:private sql:get-teams
-  "SELECT deleted_at, id, photo_id FROM team
+  "SELECT id FROM team
     WHERE deleted_at IS NOT NULL
       AND deleted_at <= ?
-    ORDER BY deleted_at ASC
-    LIMIT ?
+    ORDER BY deleted_at ASC")
+
+(def ^:private sql:lock-teams
+  "SELECT deleted_at, id, photo_id FROM team
+    WHERE id = ANY(?::uuid[])
+      AND deleted_at IS NOT NULL
+      AND deleted_at <= ?
       FOR UPDATE
      SKIP LOCKED")
 
-(defn- delete-teams!
-  [{:keys [::db/conn ::threshold ::chunk-size ::sto/storage] :as cfg}]
-  (->> (db/plan conn [sql:get-teams threshold chunk-size] {:fetch-size 5})
-       (reduce (fn [total {:keys [id photo-id deleted-at]}]
-                 (l/trc :obj "team"
-                        :id (str id)
-                        :deleted-at (ct/format-inst deleted-at))
+(defn- delete-teams-chunk
+  [cfg ids]
+  (try
+    (db/tx-run! cfg
+                (fn [{:keys [::db/conn ::threshold ::sto/storage]}]
+                  (db/exec-one! conn ["SET LOCAL rules.deletion_protection TO off"])
+                  (let [ids (db/create-array conn "uuid" ids)]
+                    (->> (db/exec! conn [sql:lock-teams ids threshold])
+                         (reduce (fn [total {:keys [id photo-id deleted-at]}]
+                                   (l/trc :obj "team"
+                                          :id (str id)
+                                          :deleted-at (ct/format-inst deleted-at))
 
-                 ;; Mark as deleted the storage object
-                 (some->> photo-id (sto/touch-object! storage))
+                                   ;; Mark as deleted the storage object
+                                   (some->> photo-id (sto/touch-object! storage))
 
-                 ;; And finally, permanently delete the team.
-                 (let [affected (-> (db/delete! conn :team {:id id})
-                                    (db/get-update-count))]
-                   (+ total affected)))
-               0)))
+                                   ;; And finally, permanently delete the team.
+                                   (let [affected (-> (db/delete! conn :team {:id id})
+                                                      (db/get-update-count))]
+                                     (+ total affected)))
+                                 0)))))
+    (catch Throwable cause
+      (l/err :obj "team"
+             :hint "error on chunk deletion, skipping it"
+             :chunk ids
+             :cause cause)
+      0)))
+
+(defn- delete-teams
+  [{:keys [::threshold ::chunk-size] :as cfg}]
+  (let [rf (fn ([total] total)
+             ([total chunk]
+              (let [deleted (delete-teams-chunk cfg chunk)]
+                (jobs/heartbeat cfg)
+                (+ total deleted))))]
+    (db/tx-run! (assoc cfg ::db/read-only true)
+                (fn [{:keys [::db/conn]}]
+                  (transduce (comp (map :id) (partition-all chunk-size)) rf 0
+                             (db/plan conn [sql:get-teams threshold]
+                                      {:fetch-size 5}))))))
 
 (def ^:private sql:get-fonts
+  "SELECT id FROM team_font_variant
+    WHERE deleted_at IS NOT NULL
+      AND deleted_at <= ?
+    ORDER BY deleted_at ASC")
+
+(def ^:private sql:lock-fonts
   "SELECT id, team_id, deleted_at, woff1_file_id, woff2_file_id, otf_file_id, ttf_file_id
      FROM team_font_variant
-    WHERE deleted_at IS NOT NULL
+    WHERE id = ANY(?::uuid[])
+      AND deleted_at IS NOT NULL
       AND deleted_at <= ?
-    ORDER BY deleted_at ASC
-    LIMIT ?
       FOR UPDATE
      SKIP LOCKED")
 
-(defn- delete-fonts!
-  [{:keys [::db/conn ::threshold ::chunk-size ::sto/storage] :as cfg}]
-  (->> (db/plan conn [sql:get-fonts threshold chunk-size] {:fetch-size 5})
-       (reduce (fn [total {:keys [id team-id deleted-at] :as font}]
-                 (l/trc :obj "font-variant"
-                        :id (str id)
-                        :team-id (str team-id)
-                        :deleted-at (ct/format-inst deleted-at))
+(defn- delete-fonts-chunk
+  [cfg ids]
+  (try
+    (db/tx-run! cfg
+                (fn [{:keys [::db/conn ::threshold ::sto/storage]}]
+                  (db/exec-one! conn ["SET LOCAL rules.deletion_protection TO off"])
+                  (let [ids (db/create-array conn "uuid" ids)]
+                    (->> (db/exec! conn [sql:lock-fonts ids threshold])
+                         (reduce (fn [total {:keys [id team-id deleted-at] :as font}]
+                                   (l/trc :obj "font-variant"
+                                          :id (str id)
+                                          :team-id (str team-id)
+                                          :deleted-at (ct/format-inst deleted-at))
 
-                 ;; Mark as deleted the all related storage objects
-                 (some->> (:woff1-file-id font) (sto/touch-object! storage))
-                 (some->> (:woff2-file-id font) (sto/touch-object! storage))
-                 (some->> (:otf-file-id font)   (sto/touch-object! storage))
-                 (some->> (:ttf-file-id font)   (sto/touch-object! storage))
+                                   ;; Mark as deleted the all related storage objects
+                                   (some->> (:woff1-file-id font) (sto/touch-object! storage))
+                                   (some->> (:woff2-file-id font) (sto/touch-object! storage))
+                                   (some->> (:otf-file-id font)   (sto/touch-object! storage))
+                                   (some->> (:ttf-file-id font)   (sto/touch-object! storage))
 
-                 (let [affected (-> (db/delete! conn :team-font-variant {:id id})
-                                    (db/get-update-count))]
-                   (+ total affected)))
-               0)))
+                                   (let [affected (-> (db/delete! conn :team-font-variant {:id id})
+                                                      (db/get-update-count))]
+                                     (+ total affected)))
+                                 0)))))
+    (catch Throwable cause
+      (l/err :obj "font-variant"
+             :hint "error on chunk deletion, skipping it"
+             :chunk ids
+             :cause cause)
+      0)))
+
+(defn- delete-fonts
+  [{:keys [::threshold ::chunk-size] :as cfg}]
+  (let [rf (fn ([total] total)
+             ([total chunk]
+              (let [deleted (delete-fonts-chunk cfg chunk)]
+                (jobs/heartbeat cfg)
+                (+ total deleted))))]
+    (db/tx-run! (assoc cfg ::db/read-only true)
+                (fn [{:keys [::db/conn]}]
+                  (transduce (comp (map :id) (partition-all chunk-size)) rf 0
+                             (db/plan conn [sql:get-fonts threshold]
+                                      {:fetch-size 5}))))))
 
 (def ^:private sql:get-projects
-  "SELECT id, deleted_at, team_id
-     FROM project
+  "SELECT id FROM project
     WHERE deleted_at IS NOT NULL
       AND deleted_at <= ?
-    ORDER BY deleted_at ASC
-    LIMIT ?
+    ORDER BY deleted_at ASC")
+
+(def ^:private sql:lock-projects
+  "SELECT id, deleted_at, team_id FROM project
+    WHERE id = ANY(?::uuid[])
+      AND deleted_at IS NOT NULL
+      AND deleted_at <= ?
       FOR UPDATE
      SKIP LOCKED")
 
-(defn- delete-projects!
-  [{:keys [::db/conn ::threshold ::chunk-size] :as cfg}]
-  (->> (db/plan conn [sql:get-projects threshold chunk-size] {:fetch-size 5})
-       (reduce (fn [total {:keys [id team-id deleted-at]}]
-                 (l/trc :obj "project"
-                        :id (str id)
-                        :team-id (str team-id)
-                        :deleted-at (ct/format-inst deleted-at))
+(defn- delete-projects-chunk
+  [cfg ids]
+  (try
+    (db/tx-run! cfg
+                (fn [{:keys [::db/conn ::threshold]}]
+                  (db/exec-one! conn ["SET LOCAL rules.deletion_protection TO off"])
+                  (let [ids (db/create-array conn "uuid" ids)]
+                    (->> (db/exec! conn [sql:lock-projects ids threshold])
+                         (reduce (fn [total {:keys [id team-id deleted-at]}]
+                                   (l/trc :obj "project"
+                                          :id (str id)
+                                          :team-id (str team-id)
+                                          :deleted-at (ct/format-inst deleted-at))
 
-                 (let [affected (-> (db/delete! conn :project {:id id})
-                                    (db/get-update-count))]
-                   (+ total affected)))
-               0)))
+                                   (let [affected (-> (db/delete! conn :project {:id id})
+                                                      (db/get-update-count))]
+                                     (+ total affected)))
+                                 0)))))
+    (catch Throwable cause
+      (l/err :obj "project"
+             :hint "error on chunk deletion, skipping it"
+             :chunk ids
+             :cause cause)
+      0)))
+
+(defn- delete-projects
+  [{:keys [::threshold ::chunk-size] :as cfg}]
+  (let [rf (fn ([total] total)
+             ([total chunk]
+              (let [deleted (delete-projects-chunk cfg chunk)]
+                (jobs/heartbeat cfg)
+                (+ total deleted))))]
+    (db/tx-run! (assoc cfg ::db/read-only true)
+                (fn [{:keys [::db/conn]}]
+                  (transduce (comp (map :id) (partition-all chunk-size)) rf 0
+                             (db/plan conn [sql:get-projects threshold]
+                                      {:fetch-size 5}))))))
 
 (def ^:private sql:get-files
-  "SELECT f.id,
-          f.deleted_at,
-          f.project_id
-     FROM file AS f
-    WHERE f.deleted_at IS NOT NULL
-      AND f.deleted_at <= ?
-    ORDER BY f.deleted_at ASC
-    LIMIT ?
+  "SELECT id FROM file
+    WHERE deleted_at IS NOT NULL
+      AND deleted_at <= ?
+    ORDER BY deleted_at ASC")
+
+(def ^:private sql:lock-files
+  "SELECT id, deleted_at, project_id FROM file
+    WHERE id = ANY(?::uuid[])
+      AND deleted_at IS NOT NULL
+      AND deleted_at <= ?
       FOR UPDATE
      SKIP LOCKED")
 
-(defn- delete-files!
-  [{:keys [::db/conn ::threshold ::chunk-size] :as cfg}]
-  (->> (db/plan conn [sql:get-files threshold chunk-size] {:fetch-size 5})
-       (reduce (fn [total {:keys [id deleted-at project-id] :as file}]
-                 (l/trc :obj "file"
-                        :id (str id)
-                        :project-id (str project-id)
-                        :deleted-at (ct/format-inst deleted-at))
+(defn- delete-files-chunk
+  [cfg ids]
+  (try
+    (db/tx-run! cfg
+                (fn [{:keys [::db/conn ::threshold]}]
+                  (db/exec-one! conn ["SET LOCAL rules.deletion_protection TO off"])
+                  (let [ids (db/create-array conn "uuid" ids)]
+                    (->> (db/exec! conn [sql:lock-files ids threshold])
+                         (reduce (fn [total {:keys [id deleted-at project-id]}]
+                                   (l/trc :obj "file"
+                                          :id (str id)
+                                          :project-id (str project-id)
+                                          :deleted-at (ct/format-inst deleted-at))
 
-                 (let [affected (-> (db/delete! conn :file {:id id})
-                                    (db/get-update-count))]
-                   (+ total affected)))
-               0)))
+                                   (let [affected (-> (db/delete! conn :file {:id id})
+                                                      (db/get-update-count))]
+                                     (+ total affected)))
+                                 0)))))
+    (catch Throwable cause
+      (l/err :obj "file"
+             :hint "error on chunk deletion, skipping it"
+             :chunk ids
+             :cause cause)
+      0)))
+
+(defn- delete-files
+  "Deletes the pending files chunk by chunk.
+
+  A file that cannot be deleted (for example, because a child row was left
+  unmarked and its `NO ACTION` foreign key still points at it) aborts the
+  transaction of the whole chunk: the chunk is reported and skipped, and the
+  next run retries its files."
+  [{:keys [::threshold ::chunk-size] :as cfg}]
+  (let [rf (fn ([total] total)
+             ([total chunk]
+              (let [deleted (delete-files-chunk cfg chunk)]
+                (jobs/heartbeat cfg)
+                (+ total deleted))))]
+    (db/tx-run! (assoc cfg ::db/read-only true)
+                (fn [{:keys [::db/conn]}]
+                  (transduce (comp (map :id) (partition-all chunk-size)) rf 0
+                             (db/plan conn [sql:get-files threshold]
+                                      {:fetch-size 5}))))))
 
 (def ^:private sql:get-file-thumbnails
+  "SELECT file_id, revn FROM file_thumbnail
+    WHERE deleted_at IS NOT NULL
+      AND deleted_at <= ?
+    ORDER BY deleted_at ASC")
+
+(def ^:private sql:lock-file-thumbnails
   "SELECT file_id, revn, media_id, deleted_at
      FROM file_thumbnail
-    WHERE deleted_at IS NOT NULL
+    WHERE (file_id, revn) IN (SELECT file_id, revn FROM unnest(?::uuid[], ?::bigint[]) AS u(file_id, revn))
+      AND deleted_at IS NOT NULL
       AND deleted_at <= ?
-    ORDER BY deleted_at ASC
-    LIMIT ?
       FOR UPDATE
      SKIP LOCKED")
 
-(defn delete-file-thumbnails!
-  [{:keys [::db/conn ::threshold ::chunk-size ::sto/storage] :as cfg}]
-  (->> (db/plan conn [sql:get-file-thumbnails threshold chunk-size] {:fetch-size 5})
-       (reduce (fn [total {:keys [file-id revn media-id deleted-at]}]
-                 (l/trc :obj "file-thumbnail"
-                        :file-id (str file-id)
-                        :revn revn
-                        :deleted-at (ct/format-inst deleted-at))
+(defn- delete-file-thumbnails-chunk
+  [cfg rows]
+  (try
+    (db/tx-run! cfg
+                (fn [{:keys [::db/conn ::threshold ::sto/storage]}]
+                  (db/exec-one! conn ["SET LOCAL rules.deletion_protection TO off"])
+                  (let [file-ids (db/create-array conn "uuid" (map :file-id rows))
+                        revns    (db/create-array conn "int8" (map :revn rows))]
+                    (->> (db/exec! conn [sql:lock-file-thumbnails file-ids revns threshold])
+                         (reduce (fn [total {:keys [file-id revn media-id deleted-at]}]
+                                   (l/trc :obj "file-thumbnail"
+                                          :file-id (str file-id)
+                                          :revn revn
+                                          :deleted-at (ct/format-inst deleted-at))
 
-                 ;; Mark as deleted the storage object
-                 (some->> media-id (sto/touch-object! storage))
+                                   ;; Mark as deleted the storage object
+                                   (some->> media-id (sto/touch-object! storage))
 
-                 (let [affected (-> (db/delete! conn :file-thumbnail {:file-id file-id :revn revn})
-                                    (db/get-update-count))]
-                   (+ total affected)))
-               0)))
+                                   (let [affected (-> (db/delete! conn :file-thumbnail {:file-id file-id :revn revn})
+                                                      (db/get-update-count))]
+                                     (+ total affected)))
+                                 0)))))
+    (catch Throwable cause
+      (l/err :obj "file-thumbnail"
+             :hint "error on chunk deletion, skipping it"
+             :chunk rows
+             :cause cause)
+      0)))
+
+(defn- delete-file-thumbnails
+  [{:keys [::threshold ::chunk-size] :as cfg}]
+  (let [rf (fn ([total] total)
+             ([total chunk]
+              (let [deleted (delete-file-thumbnails-chunk cfg chunk)]
+                (jobs/heartbeat cfg)
+                (+ total deleted))))]
+    (db/tx-run! (assoc cfg ::db/read-only true)
+                (fn [{:keys [::db/conn]}]
+                  (transduce (comp (map (fn [row] {:file-id (:file-id row) :revn (:revn row)}))
+                                   (partition-all chunk-size))
+                             rf 0
+                             (db/plan conn [sql:get-file-thumbnails threshold]
+                                      {:fetch-size 5}))))))
 
 (def ^:private sql:get-file-object-thumbnails
+  "SELECT file_id, object_id FROM file_tagged_object_thumbnail
+    WHERE deleted_at IS NOT NULL
+      AND deleted_at <= ?
+    ORDER BY deleted_at ASC")
+
+(def ^:private sql:lock-file-object-thumbnails
   "SELECT file_id, object_id, media_id, deleted_at
      FROM file_tagged_object_thumbnail
-    WHERE deleted_at IS NOT NULL
+    WHERE (file_id, object_id) IN (SELECT file_id, object_id FROM unnest(?::uuid[], ?::text[]) AS u(file_id, object_id))
+      AND deleted_at IS NOT NULL
       AND deleted_at <= ?
-    ORDER BY deleted_at ASC
-    LIMIT ?
       FOR UPDATE
      SKIP LOCKED")
 
-(defn delete-file-object-thumbnails!
-  [{:keys [::db/conn ::threshold ::chunk-size ::sto/storage] :as cfg}]
-  (->> (db/plan conn [sql:get-file-object-thumbnails threshold chunk-size] {:fetch-size 5})
-       (reduce (fn [total {:keys [file-id object-id media-id deleted-at]}]
-                 (l/trc :obj "file-object-thumbnail"
-                        :file-id (str file-id)
-                        :object-id object-id
-                        :deleted-at (ct/format-inst deleted-at))
+(defn- delete-file-object-thumbnails-chunk
+  [cfg rows]
+  (try
+    (db/tx-run! cfg
+                (fn [{:keys [::db/conn ::threshold ::sto/storage]}]
+                  (db/exec-one! conn ["SET LOCAL rules.deletion_protection TO off"])
+                  (let [file-ids   (db/create-array conn "uuid" (map :file-id rows))
+                        object-ids (db/create-array conn "text" (map :object-id rows))]
+                    (->> (db/exec! conn [sql:lock-file-object-thumbnails file-ids object-ids threshold])
+                         (reduce (fn [total {:keys [file-id object-id media-id deleted-at]}]
+                                   (l/trc :obj "file-object-thumbnail"
+                                          :file-id (str file-id)
+                                          :object-id object-id
+                                          :deleted-at (ct/format-inst deleted-at))
 
-                 ;; Mark as deleted the storage object
-                 (some->> media-id (sto/touch-object! storage))
+                                   ;; Mark as deleted the storage object
+                                   (some->> media-id (sto/touch-object! storage))
 
-                 (let [affected (-> (db/delete! conn :file-tagged-object-thumbnail
-                                                {:file-id file-id :object-id object-id})
-                                    (db/get-update-count))]
-                   (+ total affected)))
-               0)))
+                                   (let [affected (-> (db/delete! conn :file-tagged-object-thumbnail
+                                                                  {:file-id file-id :object-id object-id})
+                                                      (db/get-update-count))]
+                                     (+ total affected)))
+                                 0)))))
+    (catch Throwable cause
+      (l/err :obj "file-object-thumbnail"
+             :hint "error on chunk deletion, skipping it"
+             :chunk rows
+             :cause cause)
+      0)))
+
+(defn- delete-file-object-thumbnails
+  [{:keys [::threshold ::chunk-size] :as cfg}]
+  (let [rf (fn ([total] total)
+             ([total chunk]
+              (let [deleted (delete-file-object-thumbnails-chunk cfg chunk)]
+                (jobs/heartbeat cfg)
+                (+ total deleted))))]
+    (db/tx-run! (assoc cfg ::db/read-only true)
+                (fn [{:keys [::db/conn]}]
+                  (transduce (comp (map (fn [row] {:file-id (:file-id row) :object-id (:object-id row)}))
+                                   (partition-all chunk-size))
+                             rf 0
+                             (db/plan conn [sql:get-file-object-thumbnails threshold]
+                                      {:fetch-size 5}))))))
 
 (def ^:private sql:get-file-media-objects
+  "SELECT id FROM file_media_object
+    WHERE deleted_at IS NOT NULL
+      AND deleted_at <= ?
+    ORDER BY deleted_at ASC")
+
+(def ^:private sql:lock-file-media-objects
   "SELECT id, file_id, media_id, thumbnail_id, deleted_at
      FROM file_media_object
-    WHERE deleted_at IS NOT NULL
+    WHERE id = ANY(?::uuid[])
+      AND deleted_at IS NOT NULL
       AND deleted_at <= ?
-    ORDER BY deleted_at ASC
-    LIMIT ?
       FOR UPDATE
      SKIP LOCKED")
 
-(defn- delete-file-media-objects!
-  [{:keys [::db/conn ::threshold ::chunk-size ::sto/storage] :as cfg}]
-  (->> (db/plan conn [sql:get-file-media-objects threshold chunk-size] {:fetch-size 5})
-       (reduce (fn [total {:keys [id file-id deleted-at] :as fmo}]
-                 (l/trc :obj "file-media-object"
-                        :id (str id)
-                        :file-id (str file-id)
-                        :deleted-at (ct/format-inst deleted-at))
+(defn- delete-file-media-objects-chunk
+  [cfg ids]
+  (try
+    (db/tx-run! cfg
+                (fn [{:keys [::db/conn ::threshold ::sto/storage]}]
+                  (db/exec-one! conn ["SET LOCAL rules.deletion_protection TO off"])
+                  (let [ids (db/create-array conn "uuid" ids)]
+                    (->> (db/exec! conn [sql:lock-file-media-objects ids threshold])
+                         (reduce (fn [total {:keys [id file-id deleted-at] :as fmo}]
+                                   (l/trc :obj "file-media-object"
+                                          :id (str id)
+                                          :file-id (str file-id)
+                                          :deleted-at (ct/format-inst deleted-at))
 
-                 ;; Mark as deleted the all related storage objects
-                 (some->> (:media-id fmo) (sto/touch-object! storage))
-                 (some->> (:thumbnail-id fmo) (sto/touch-object! storage))
+                                   ;; Mark as deleted the all related storage objects
+                                   (some->> (:media-id fmo) (sto/touch-object! storage))
+                                   (some->> (:thumbnail-id fmo) (sto/touch-object! storage))
 
-                 (let [affected (-> (db/delete! conn :file-media-object {:id id})
-                                    (db/get-update-count))]
-                   (+ total affected)))
-               0)))
+                                   (let [affected (-> (db/delete! conn :file-media-object {:id id})
+                                                      (db/get-update-count))]
+                                     (+ total affected)))
+                                 0)))))
+    (catch Throwable cause
+      (l/err :obj "file-media-object"
+             :hint "error on chunk deletion, skipping it"
+             :chunk ids
+             :cause cause)
+      0)))
+
+(defn- delete-file-media-objects
+  [{:keys [::threshold ::chunk-size] :as cfg}]
+  (let [rf (fn ([total] total)
+             ([total chunk]
+              (let [deleted (delete-file-media-objects-chunk cfg chunk)]
+                (jobs/heartbeat cfg)
+                (+ total deleted))))]
+    (db/tx-run! (assoc cfg ::db/read-only true)
+                (fn [{:keys [::db/conn]}]
+                  (transduce (comp (map :id) (partition-all chunk-size)) rf 0
+                             (db/plan conn [sql:get-file-media-objects threshold]
+                                      {:fetch-size 5}))))))
 
 (def ^:private sql:get-file-data
+  "SELECT file_id, id FROM file_data
+    WHERE deleted_at IS NOT NULL
+      AND deleted_at <= ?
+    ORDER BY deleted_at ASC")
+
+(def ^:private sql:lock-file-data
   "SELECT file_id, id, type, deleted_at, metadata, backend
      FROM file_data
-    WHERE deleted_at IS NOT NULL
+    WHERE (file_id, id) IN (SELECT file_id, id FROM unnest(?::uuid[], ?::uuid[]) AS u(file_id, id))
+      AND deleted_at IS NOT NULL
       AND deleted_at <= ?
-    ORDER BY deleted_at ASC
-    LIMIT ?
       FOR UPDATE
      SKIP LOCKED")
 
-(defn- delete-file-data!
-  [{:keys [::db/conn ::threshold ::chunk-size] :as cfg}]
-  (->> (db/plan conn [sql:get-file-data threshold chunk-size] {:fetch-size 5})
-       (reduce (fn [total {:keys [file-id id type deleted-at metadata backend]}]
+(defn- delete-file-data-chunk
+  [cfg rows]
+  (try
+    (db/tx-run! cfg
+                (fn [{:keys [::db/conn ::threshold] :as cfg}]
+                  (db/exec-one! conn ["SET LOCAL rules.deletion_protection TO off"])
+                  (let [file-ids (db/create-array conn "uuid" (map :file-id rows))
+                        ids      (db/create-array conn "uuid" (map :id rows))]
+                    (->> (db/exec! conn [sql:lock-file-data file-ids ids threshold])
+                         (reduce (fn [total {:keys [file-id id type deleted-at metadata backend]}]
 
-                 (some->> metadata
-                          (fdata/decode-metadata)
-                          (fdata/process-metadata cfg))
+                                   (some->> metadata
+                                            (fdata/decode-metadata)
+                                            (fdata/process-metadata cfg))
 
-                 (l/trc :obj "file-data"
-                        :id (str id)
-                        :file-id (str file-id)
-                        :type type
-                        :backend backend
-                        :deleted-at (ct/format-inst deleted-at))
+                                   (l/trc :obj "file-data"
+                                          :id (str id)
+                                          :file-id (str file-id)
+                                          :type type
+                                          :backend backend
+                                          :deleted-at (ct/format-inst deleted-at))
 
-                 (let [affected (-> (db/delete! conn :file-data
-                                                {:file-id file-id
-                                                 :id id
-                                                 :type type})
-                                    (db/get-update-count))]
-                   (+ total affected)))
-               0)))
+                                   (let [affected (-> (db/delete! conn :file-data
+                                                                  {:file-id file-id
+                                                                   :id id
+                                                                   :type type})
+                                                      (db/get-update-count))]
+                                     (+ total affected)))
+                                 0)))))
+    (catch Throwable cause
+      (l/err :obj "file-data"
+             :hint "error on chunk deletion, skipping it"
+             :chunk rows
+             :cause cause)
+      0)))
+
+(defn- delete-file-data
+  [{:keys [::threshold ::chunk-size] :as cfg}]
+  (let [rf (fn ([total] total)
+             ([total chunk]
+              (let [deleted (delete-file-data-chunk cfg chunk)]
+                (jobs/heartbeat cfg)
+                (+ total deleted))))]
+    (db/tx-run! (assoc cfg ::db/read-only true)
+                (fn [{:keys [::db/conn]}]
+                  (transduce (comp (map (fn [row] {:file-id (:file-id row) :id (:id row)}))
+                                   (partition-all chunk-size))
+                             rf 0
+                             (db/plan conn [sql:get-file-data threshold]
+                                      {:fetch-size 5}))))))
 
 (def ^:private sql:get-file-change
-  "SELECT id, file_id, deleted_at
-     FROM file_change
+  "SELECT id FROM file_change
     WHERE deleted_at IS NOT NULL
       AND deleted_at <= ?
-    ORDER BY deleted_at ASC
-    LIMIT ?
+    ORDER BY deleted_at ASC")
+
+(def ^:private sql:lock-file-change
+  "SELECT id, file_id, deleted_at FROM file_change
+    WHERE id = ANY(?::uuid[])
+      AND deleted_at IS NOT NULL
+      AND deleted_at <= ?
       FOR UPDATE
      SKIP LOCKED")
 
-(defn- delete-file-changes!
-  [{:keys [::db/conn ::threshold ::chunk-size] :as cfg}]
-  (->> (db/plan conn [sql:get-file-change threshold chunk-size] {:fetch-size 5})
-       (reduce (fn [total {:keys [id file-id deleted-at] :as xlog}]
-                 (l/trc :obj "file-change"
-                        :id (str id)
-                        :file-id (str file-id)
-                        :deleted-at (ct/format-inst deleted-at))
+(defn- delete-file-changes-chunk
+  [cfg ids]
+  (try
+    (db/tx-run! cfg
+                (fn [{:keys [::db/conn ::threshold]}]
+                  (db/exec-one! conn ["SET LOCAL rules.deletion_protection TO off"])
+                  (let [ids (db/create-array conn "uuid" ids)]
+                    (->> (db/exec! conn [sql:lock-file-change ids threshold])
+                         (reduce (fn [total {:keys [id file-id deleted-at]}]
+                                   (l/trc :obj "file-change"
+                                          :id (str id)
+                                          :file-id (str file-id)
+                                          :deleted-at (ct/format-inst deleted-at))
 
-                 (let [affected (-> (db/delete! conn :file-change {:id id})
-                                    (db/get-update-count))]
-                   (+ total affected)))
-               0)))
-
-(def ^:private deletion-proc-vars
-  ;; NOTE: upload sessions go first: deleting a profile cascades to its
-  ;; sessions, which would hit the upload_session_chunk NO ACTION foreign key
-  ;; while mappings still exist.
-  [#'delete-upload-sessions!
-   #'delete-profiles!
-   #'delete-file-media-objects!
-   #'delete-file-object-thumbnails!
-   #'delete-file-thumbnails!
-   #'delete-file-data!
-   #'delete-file-changes!
-   #'delete-files!
-   #'delete-projects!
-   #'delete-fonts!
-   #'delete-teams!])
-
-(defn- execute-proc
-  "A generic function that executes the specified proc iterativelly
-  until 0 results is returned. Heartbeats after each committed chunk so
-  a long backlog in a single proc cannot outrun the orphan lease
-  (mirrors storage/gc-deleted clean-deleted, which heartbeats per
-  chunk)."
-  [cfg proc-fn]
-  (loop [total 0]
-    (let [result (db/tx-run! cfg
-                             (fn [{:keys [::db/conn] :as cfg}]
-                               (db/exec-one! conn ["SET LOCAL rules.deletion_protection TO off"])
-                               (proc-fn cfg)))]
-      (if (pos? result)
-        (do
-          (jobs/heartbeat cfg)
-          (recur (long (+ total result))))
-        total))))
+                                   (let [affected (-> (db/delete! conn :file-change {:id id})
+                                                      (db/get-update-count))]
+                                     (+ total affected)))
+                                 0)))))
+    (catch Throwable cause
+      (l/err :obj "file-change"
+             :hint "error on chunk deletion, skipping it"
+             :chunk ids
+             :cause cause)
+      0)))
 
+(defn- delete-file-changes
+  [{:keys [::threshold ::chunk-size] :as cfg}]
+  (let [rf (fn ([total] total)
+             ([total chunk]
+              (let [deleted (delete-file-changes-chunk cfg chunk)]
+                (jobs/heartbeat cfg)
+                (+ total deleted))))]
+    (db/tx-run! (assoc cfg ::db/read-only true)
+                (fn [{:keys [::db/conn]}]
+                  (transduce (comp (map :id) (partition-all chunk-size)) rf 0
+                             (db/plan conn [sql:get-file-change threshold]
+                                      {:fetch-size 5}))))))
 
 (defmethod ig/assert-key ::job-def
   [_ params]
@@ -381,6 +699,7 @@
 (defmethod ig/expand-key ::job-def
   [k v]
   {k (assoc v ::chunk-size 100)})
+
 (declare execute-objects-gc)
 
 (def schema:objects-gc-params
@@ -406,20 +725,26 @@
   "Plain job handler: garbage collect orphan storage objects."
   ([cfg] (execute-objects-gc cfg {}))
   ([cfg params]
-   (let [now       (ct/now)
-         threshold (if (:skip-delay params)
+   (let [threshold (if (:skip-delay params)
                      (ct/in-future {:days 3650})
-                     now)
+                     (ct/now))
          cfg       (assoc cfg
-                          ::timestamp now
                           ::threshold threshold
                           ::chunk-size (or (:chunk-size params)
-                                           (::chunk-size cfg)))]
-     (loop [procs (map deref deletion-proc-vars)
-            total 0]
-       (if-let [proc-fn (first procs)]
-         (let [result (execute-proc cfg proc-fn)]
-           (jobs/heartbeat cfg)
-           (recur (rest procs)
-                  (long (+ total result))))
-         {:processed total})))))
+                                           (::chunk-size cfg)))
+
+         ;; NOTE: upload sessions go first: deleting a profile cascades to its
+         ;; sessions, which would hit the upload_session_chunk NO ACTION foreign
+         ;; key while mappings still exist.
+         total     (+ (delete-upload-sessions cfg)
+                      (delete-profiles cfg)
+                      (delete-file-media-objects cfg)
+                      (delete-file-object-thumbnails cfg)
+                      (delete-file-thumbnails cfg)
+                      (delete-file-data cfg)
+                      (delete-file-changes cfg)
+                      (delete-files cfg)
+                      (delete-projects cfg)
+                      (delete-fonts cfg)
+                      (delete-teams cfg))]
+     {:processed total})))

backend/test/backend_tests/climit_test.clj

@@ -0,0 +1,693 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) KALEIDOS INC Sucursal en España SL
+
+(ns backend-tests.climit-test
+  (:require
+   [app.common.logging :as l]
+   [app.common.uuid :as uuid]
+   [app.main :as main]
+   [app.metrics :as mtx]
+   [app.rpc :as-alias rpc]
+   [app.rpc.climit :as climit]
+   [app.util.services :as-alias sv]
+   [backend-tests.helpers :as th]
+   [clojure.edn :as edn]
+   [clojure.java.io :as io]
+   [clojure.test :as t]
+   [integrant.core :as ig]))
+
+(def ^:private calls (atom []))
+
+(defn- record-metrics
+  "Run `f` recording every metrics call it makes."
+  [f]
+  (reset! calls [])
+  (with-redefs [mtx/run!
+                (fn [_ & {:keys [id labels val]}]
+                  (swap! calls conj {:id id :labels (vec labels) :val val}))]
+    (f)))
+
+(defn- acquired-in-order
+  "Limiter names acquired so far, in acquisition order."
+  []
+  (->> @calls
+       (filter #(= :rpc-climit-timing (:id %)))
+       (mapcat :labels)
+       (vec)))
+
+(defn- saw-call?
+  "Wait until a metrics call mentions `label`."
+  [label timeout]
+  (let [deadline (+ (System/currentTimeMillis) timeout)]
+    (loop []
+      (cond
+        (some (fn [call] (some #{label} (:labels call))) @calls)
+        true
+
+        (> (System/currentTimeMillis) deadline)
+        false
+
+        :else
+        (do (Thread/sleep 10) (recur))))))
+
+(defn- failed-type
+  "Run `f` and return its value, or the type of the error it raised."
+  [f]
+  (try
+    (f)
+    (catch Throwable cause
+      (:type (ex-data cause)))))
+
+(def ^:private no-timeout-hint
+  "limiter without timeout, a saturated one parks its threads forever")
+
+(defn- warned-ids
+  "Ids of the captured log records that warn about a missing timeout."
+  [records]
+  (->> records
+       (keep (fn [record]
+               (when (= no-timeout-hint (get (::l/props record) :hint))
+                 (get (::l/props record) :id))))
+       (set)))
+
+(defn- warned?
+  "Wait until a captured log record warns about a missing timeout."
+  [records timeout]
+  (let [deadline (+ (System/currentTimeMillis) timeout)]
+    (loop []
+      (cond
+        (seq (warned-ids @records)) true
+        (> (System/currentTimeMillis) deadline) false
+        :else (do (Thread/sleep 10) (recur))))))
+
+;; One permit and a bounded wait per limiter: a call either gets its permit, or
+;; fails with a concurrency limit error, never parks a thread forever.
+(def ^:private test-config
+  {:root/global                {:permits 1 :timeout 3000}
+   :root/by-profile            {:permits 1 :timeout 3000}
+   :process-image/global       {:permits 1 :timeout 3000}
+   :process-image/by-profile   {:permits 1 :timeout 3000}})
+
+;; The limits `upload-file-media-object` and `assemble-file-media-object`
+;; declare, per profile.
+(def ^:private image-limits
+  [[:process-image/by-profile ::rpc/profile-id]
+   [:process-image/global]])
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; ACQUISITION ORDER
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(t/deftest acquires-root-limits-before-the-command-own-limits
+  ;; A command declaring its own limits must meet the root limiters first.
+  ;; The nested `climit/invoke!` calls take only the command's own limits and
+  ;; run inside the root ones, so any other order lets two calls of the same
+  ;; profile hold the same limiters in opposite order and park for good.
+  (record-metrics
+   (fn []
+     (th/with-climit [climit test-config]
+       (let [mdata   {::sv/name "test-command" ::climit/id image-limits}
+             wrapped (climit/wrap {::rpc/climit climit} (fn [_ _] :ok) mdata)
+             result  (wrapped {::rpc/climit climit} {::rpc/profile-id (uuid/next)})]
+         (t/is (= :ok result))
+         (t/is (= ["root/by-profile"
+                   "root/global"
+                   "process-image/by-profile"
+                   "process-image/global"]
+                  (acquired-in-order))))))))
+
+(t/deftest nested-limits-do-not-deadlock-with-the-command-own-limits
+  ;; Two paths over one profile: a command declaring its own limits (like
+  ;; `upload-file-media-object`) and a command that takes the root limiters and
+  ;; then asks for the same limits from inside its handler (like
+  ;; `create-file-media-object-from-url`). Each path holds what the other one
+  ;; waits for the moment the order differs, and nothing releases.
+  (record-metrics
+   (fn []
+     (th/with-climit [climit test-config]
+       (let [pid     (uuid/next)
+             gate    (promise)
+             entered (promise)
+
+             handler-b (fn [cfg params]
+                         (deliver entered true)
+                         @gate
+                         (-> cfg
+                             (assoc ::climit/id [[:process-image/by-profile pid]
+                                                 [:process-image/global]])
+                             (assoc ::climit/label "path-b")
+                             (climit/invoke! (fn [_ _] :nested-ok) params)))
+
+             wrapped-a (climit/wrap {::rpc/climit climit}
+                                    (fn [_ _] :ok)
+                                    {::sv/name "path-a" ::climit/id image-limits})
+
+             wrapped-b (climit/wrap {::rpc/climit climit}
+                                    handler-b
+                                    {::sv/name "path-b"})]
+
+         ;; Path B takes the root limiters and waits inside its handler.
+         (let [fb (future (failed-type #(wrapped-b {::rpc/climit climit}
+                                                   {::rpc/profile-id pid})))]
+           (t/is (true? (deref entered 5000 false)))
+
+           ;; Path A, started now, takes its own limiters and then waits for the
+           ;; root ones, which B holds. The recorded metrics are how the test
+           ;; knows A got that far instead of guessing with a sleep.
+           (reset! calls [])
+           (let [fa (future (failed-type #(wrapped-a {::rpc/climit climit}
+                                                     {::rpc/profile-id pid})))]
+             (t/is (true? (saw-call? "root/by-profile" 5000)))
+
+             ;; Let B ask for the limits A holds: if the order differs, each path
+             ;; now waits for a permit the other one holds.
+             (deliver gate true)
+
+             (t/is (= :ok (deref fa 15000 :timeout)))
+             (t/is (= :nested-ok (deref fb 15000 :timeout))))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; REENTRANCY
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(t/deftest reentrant-invoke-does-not-consume-a-second-permit
+  ;; A handler entering climit for a limit it already holds must not queue
+  ;; behind itself: it runs inline and takes no second permit. Another thread
+  ;; asking for the same limiter still waits, so the limit stays in place.
+  (th/with-climit [climit {:process-image/by-profile
+                           {:permits 1 :timeout 2000}}]
+    (let [pid     (uuid/next)
+          cfg     {::rpc/climit climit
+                   ::climit/id [[:process-image/by-profile pid]]}
+          inner   (promise)
+          other   (promise)
+          handler (fn [cfg params]
+                    (deliver inner
+                             (failed-type #(climit/invoke! cfg (fn [_ _] :inner-ok) params)))
+                    (deliver other (future (climit/invoke! cfg (fn [_ _] :other-ok) params)))
+                    (t/is (= :waiting (deref @other 300 :waiting)))
+                    :outer-ok)
+
+          outcome (failed-type #(climit/invoke! cfg handler {}))]
+
+      ;; With no reentrancy handling the inner call waits for the permit this very
+      ;; thread holds and ends failing by timeout.
+      (t/is (= :inner-ok (deref inner 5000 :timeout)))
+      (t/is (= :outer-ok outcome))
+
+      ;; once the outer call releases, the other thread gets its permit
+      (t/is (= :other-ok (deref @other 5000 :timeout))))))
+
+(t/deftest reentrant-tracking-is-cleaned-up-when-the-handler-fails
+  ;; If the mark is not removed, the thread keeps believing it holds the
+  ;; limiter and every later call of that key would skip the limit.
+  (th/with-climit [climit {:process-image/by-profile
+                           {:permits 1 :timeout 1000}}]
+    (let [pid     (uuid/next)
+          cfg     {::rpc/climit climit
+                   ::climit/id [[:process-image/by-profile pid]]}
+          holding (promise)
+          gate    (promise)]
+
+      ;; The failing call runs on this thread, so this thread is the one that
+      ;; must forget it held the limiter.
+      (t/is (thrown? clojure.lang.ExceptionInfo
+                     (climit/invoke! cfg (fn [_ _] (throw (ex-info "boom" {}))) {})))
+
+      ;; another thread takes the only permit
+      (let [fb (future (climit/invoke! cfg (fn [_ _]
+                                             (deliver holding true)
+                                             @gate
+                                             :held)
+                                       {}))]
+        (t/is (true? (deref holding 5000 false)))
+
+        ;; this thread must wait for it, not skip the limiter
+        (t/is (= :concurrency-limit
+                 (failed-type #(climit/invoke! cfg (fn [_ _] :inner-ok) {}))))
+
+        (deliver gate true)
+        (t/is (= :held (deref fb 5000 :timeout)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; SHIPPED CONFIG
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(t/deftest example-config-bounds-every-wait
+  ;; A limiter without `:timeout` parks the calling thread forever, which is
+  ;; how a limit nobody releases turns into lost worker threads and days of
+  ;; silent 429s. Every entry of the shipped config must carry one.
+  (let [path (io/resource "climit.edn")]
+    (t/is (some? path))
+    (let [data (edn/read-string (slurp path))]
+      (t/is (seq data))
+      (doseq [[id config] data]
+        (t/is (int? (:timeout config))
+              (str id " must declare a timeout"))))))
+
+(t/deftest warns-when-a-limiter-has-no-timeout
+  ;; The config that production loads lives outside the repository and is
+  ;; maintained by hand, so a limiter without a timeout has to say so at
+  ;; startup instead of parking threads in silence months later.
+  (let [records (atom [])]
+    (add-watch l/log-record ::capture
+               (fn [_ _ _ record] (swap! records conj record)))
+    (try
+      (th/with-climit [_climit {:process-image/by-profile {:permits 1 :timeout 1000}
+                                :process-image/global {:permits 8}}]
+        (t/is (true? (warned? records 2000)))
+        (t/is (= #{:process-image/global} (warned-ids @records))))
+
+      (finally
+        (remove-watch l/log-record ::capture)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; WAITING COUNTER
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn- waiting-value-of
+  "Values published to the waiting gauge for one limiter name, in order."
+  [name]
+  (->> @calls
+       (filter #(= :rpc-climit-waiting (:id %)))
+       (filter #(= name (first (:labels %))))
+       (map :val)
+       (vec)))
+
+(defn- waiting-last
+  "Last value published to the waiting gauge for one limiter name. How many
+  publications land inside a window is not part of the contract, the value is,
+  so this is what the assertions read."
+  [name]
+  (last (waiting-value-of name)))
+
+(defn- waiting-count
+  "Current waiting count of a limiter name, read from its component."
+  [climit name]
+  (.get ^java.util.concurrent.atomic.AtomicLong
+   (#'climit/waiting-counter (:counters climit) name)))
+
+(defn- wait-until
+  "Wait until `pred` holds, or give up."
+  [pred timeout]
+  (let [deadline (+ (System/currentTimeMillis) timeout)]
+    (loop []
+      (cond
+        (pred) true
+        (> (System/currentTimeMillis) deadline) false
+        :else (do (Thread/sleep 10) (recur))))))
+
+(defn- limiter-name
+  "The name climit publishes for a limiter id: the keyword without the colon."
+  [id]
+  (subs (str id) 1))
+
+(defn- limiter-cfg
+  [climit name key]
+  {::rpc/climit climit
+   ::climit/id [[name key]]})
+
+(t/deftest waiting-gauge-follows-the-queue
+  ;; The value is the number of calls waiting for a permit: up when a call
+  ;; starts waiting, down when the wait ends. The gauges that sampled the
+  ;; limiter stats could not show this, because the value of whichever limiter
+  ;; of the name ran last was the one that survived.
+  (record-metrics
+   (fn []
+     (th/with-climit [climit {:test-waiting/by-profile {:permits 1 :timeout 3000}}]
+       (let [name    (limiter-name :test-waiting/by-profile)
+             entered (promise)
+             gate    (promise)
+             holder  (future (climit/invoke! (limiter-cfg climit :test-waiting/by-profile "a")
+                                             (fn [_ _] (deliver entered true) @gate :held)
+                                             {}))]
+
+         (t/is (true? (deref entered 5000 false)))
+
+         ;; the holder is running, not waiting
+         (reset! calls [])
+         (let [waiter (future (climit/invoke! (limiter-cfg climit :test-waiting/by-profile "a")
+                                              (fn [_ _] :waited)
+                                              {}))]
+           (t/is (true? (wait-until #(= 1 (waiting-last name)) 5000)))
+           (t/is (= 1 (waiting-count climit name)))
+
+           (deliver gate true)
+           (t/is (= :waited (deref waiter 5000 :timeout)))
+           (t/is (= :held (deref holder 5000 :timeout)))
+           (t/is (true? (wait-until #(= 0 (waiting-last name)) 5000)))
+           (t/is (= 0 (waiting-count climit name)))))))))
+
+(t/deftest waiting-gauge-sums-every-key-of-a-name
+  ;; Two profiles queueing on the same limiter name add up. That is the shape
+  ;; that stayed invisible in production: one series per name, counting the
+  ;; entries and the exits, instead of one value per limiter overwritten by the
+  ;; next one.
+  (record-metrics
+   (fn []
+     (th/with-climit [climit {:test-waiting-keys/by-profile {:permits 1 :timeout 3000}}]
+       (let [name  (limiter-name :test-waiting-keys/by-profile)
+             gates {:a (promise) :b (promise)}
+             holders
+             (into {}
+                   (map (fn [k]
+                          (let [entered (promise)]
+                            [k {:entered entered
+                                :future  (future (climit/invoke! (limiter-cfg climit :test-waiting-keys/by-profile k)
+                                                                 (fn [_ _]
+                                                                   (deliver entered true)
+                                                                   @(gates k)
+                                                                   :held)
+                                                                 {}))}])))
+                   [:a :b])]
+
+         (doseq [k [:a :b]]
+           (t/is (true? (deref (:entered (holders k)) 5000 false))))
+
+         ;; one call per key, waiting behind its own holder
+         (let [waiters (into {}
+                             (map (fn [k]
+                                    [k (future (climit/invoke! (limiter-cfg climit :test-waiting-keys/by-profile k)
+                                                               (fn [_ _] :waited)
+                                                               {}))]))
+                             [:a :b])]
+
+           (t/is (true? (wait-until #(= 2 (waiting-count climit name)) 5000)))
+           ;; the increment that reaches 2 always publishes 2, whichever waiter
+           ;; does it last: the order of two concurrent publications is not the
+           ;; contract, the value is.
+           (t/is (some #(= 2 %) (waiting-value-of name)))
+
+           (doseq [k [:a :b]] (deliver (gates k) true))
+
+           (doseq [k [:a :b]]
+             (t/is (= :waited (deref (waiters k) 5000 :timeout)))
+             (t/is (= :held (deref (:future (holders k)) 5000 :timeout))))
+
+           (t/is (true? (wait-until #(= 0 (waiting-count climit name)) 5000)))
+           (t/is (some #(= 0 %) (waiting-value-of name)))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; REJECTIONS
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn- rejections
+  "Rejections published, as [name reason] pairs."
+  []
+  (->> @calls
+       (filter #(= :rpc-climit-rejected (:id %)))
+       (map (fn [call] [(first (:labels call)) (second (:labels call))]))
+       (vec)))
+
+(t/deftest rejection-counter-tells-why
+  ;; Rejections had no metric: the panel counted them from the logs. Now a call
+  ;; rejected because the queue is full and a call rejected because it waited
+  ;; too long are counted apart.
+  (record-metrics
+   (fn []
+     (th/with-climit [climit {:test-rejected/by-profile {:permits 1 :queue 1 :timeout 60000}}]
+       (let [name    (limiter-name :test-rejected/by-profile)
+             cfg     (limiter-cfg climit :test-rejected/by-profile "a")
+             entered (promise)
+             gate    (promise)
+             holder  (future (climit/invoke! cfg
+                                             (fn [_ _] (deliver entered true) @gate :held)
+                                             {}))]
+
+         (t/is (true? (deref entered 5000 false)))
+         (reset! calls [])
+
+         ;; the queue holds one waiter, so the next call is rejected right away
+         (let [queued (future (failed-type #(climit/invoke! cfg (fn [_ _] :queued) {})))]
+           (t/is (true? (wait-until #(= 1 (waiting-last name)) 5000)))
+           (t/is (= :concurrency-limit (failed-type #(climit/invoke! cfg (fn [_ _] :extra) {}))))
+           (t/is (= [[name "queue-full"]] (rejections)))
+
+           (deliver gate true)
+           (t/is (= :held (deref holder 5000 :timeout)))
+           (t/is (= :queued (deref queued 5000 :timeout))))))
+
+     ;; a wait that times out is counted as such, not as a full queue
+     (th/with-climit [climit {:test-timeout/by-profile {:permits 1 :timeout 300}}]
+       (let [name    (limiter-name :test-timeout/by-profile)
+             cfg     (limiter-cfg climit :test-timeout/by-profile "a")
+             entered (promise)
+             gate    (promise)
+             holder  (future (climit/invoke! cfg
+                                             (fn [_ _] (deliver entered true) @gate :held)
+                                             {}))]
+
+         (t/is (true? (deref entered 5000 false)))
+         (reset! calls [])
+         (t/is (= :concurrency-limit (failed-type #(climit/invoke! cfg (fn [_ _] :late) {}))))
+         (t/is (= [[name "timeout"]] (rejections)))
+
+         (deliver gate true)
+         (t/is (= :held (deref holder 5000 :timeout))))))))
+
+(t/deftest the-waiting-count-comes-back-after-a-rejection
+  ;; A rejected call increments and decrements exactly once: a limiter that
+  ;; rejects under pressure must not drift the panel up.
+  (record-metrics
+   (fn []
+     (th/with-climit [climit {:test-rejected-baseline/by-profile {:permits 1 :queue 0 :timeout 3000}}]
+       (let [name    (limiter-name :test-rejected-baseline/by-profile)
+             cfg     (limiter-cfg climit :test-rejected-baseline/by-profile "a")
+             entered (promise)
+             gate    (promise)
+             holder  (future (climit/invoke! cfg
+                                             (fn [_ _] (deliver entered true) @gate :held)
+                                             {}))]
+
+         (t/is (true? (deref entered 5000 false)))
+         (reset! calls [])
+
+         (t/is (= :concurrency-limit (failed-type #(climit/invoke! cfg (fn [_ _] :extra) {}))))
+         (t/is (= 0 (waiting-count climit name)))
+         (t/is (true? (wait-until #(= 0 (waiting-last name)) 5000)))
+
+         (deliver gate true)
+         (t/is (= :held (deref holder 5000 :timeout))))))))
+
+(t/deftest the-waiting-count-comes-back-when-the-handler-throws
+  ;; A handler that throws still leaves the count where it was.
+  (record-metrics
+   (fn []
+     (th/with-climit [climit {:test-handler-throws/by-profile {:permits 1 :timeout 3000}}]
+       (let [name (limiter-name :test-handler-throws/by-profile)
+             cfg  (limiter-cfg climit :test-handler-throws/by-profile "a")]
+
+         (reset! calls [])
+         (t/is (thrown? clojure.lang.ExceptionInfo
+                        (climit/invoke! cfg (fn [_ _] (throw (ex-info "boom" {}))) {})))
+
+         (t/is (= 0 (waiting-count climit name)))
+         (t/is (true? (wait-until #(= 0 (waiting-last name)) 5000))))))))
+
+(defn- failing-first-waiting-publish
+  "A `mtx/run!` replacement that fails the first waiting publication and records
+  the rest, so the decrement of the unwinding path still lands."
+  [calls]
+  (let [pending (atom true)]
+    (fn [_ & {:keys [id labels val]}]
+      (if (and @pending (= :rpc-climit-waiting id))
+        (do (reset! pending false)
+            (throw (ex-info "publishing is down" {})))
+        (swap! calls conj {:id id :labels (vec labels) :val val})))))
+
+(t/deftest a-throwable-while-waiting-leaves-no-mark-and-no-count
+  ;; `waiting-inc` sits inside the `try`: a throwable from the publishing path
+  ;; unwinds through the `finally`, so the thread neither keeps the limiter
+  ;; marked as held (it would skip that limiter for that key for ever) nor
+  ;; leaves the count up.
+  (th/with-climit [climit {:test-throw-waiting/by-profile {:permits 1 :timeout 3000}}]
+    (let [name (limiter-name :test-throw-waiting/by-profile)
+          cfg  (limiter-cfg climit :test-throw-waiting/by-profile "a")]
+
+      (reset! calls [])
+      (with-redefs [mtx/run! (failing-first-waiting-publish calls)]
+        (t/is (thrown? clojure.lang.ExceptionInfo
+                       (climit/invoke! cfg (fn [_ _] :never) {}))))
+
+      ;; the count came back down instead of staying up for good
+      (t/is (= 0 (waiting-count climit name)))
+      (t/is (= [0] (waiting-value-of name)))
+
+      ;; and the thread dropped the mark: with it left behind, this call would
+      ;; run inline instead of waiting for the permit another thread holds.
+      (let [entered (promise)
+            gate    (promise)
+            holder  (future (climit/invoke! cfg
+                                            (fn [_ _] (deliver entered true) @gate :held)
+                                            {}))]
+        (t/is (true? (deref entered 5000 false)))
+        (t/is (= :concurrency-limit (failed-type #(climit/invoke! cfg (fn [_ _] :inline) {}))))
+        (deliver gate true)
+        (t/is (= :held (deref holder 5000 :timeout)))))))
+
+(defn- gauge-value
+  "Current value of the waiting gauge for one limiter name, read from a real
+  prometheus collector."
+  [metrics name]
+  (let [collector (:app.metrics.definition/instance
+                   (mtx/get-collector metrics :rpc-climit-waiting))]
+    (.get ^io.prometheus.client.Gauge$Child
+     (.labels ^io.prometheus.client.Gauge collector (into-array String [name])))))
+
+(t/deftest the-waiting-gauge-reaches-a-real-registry
+  ;; The recorded calls prove the arguments, not that a collector with that name
+  ;; and those labels exists: a typo in the metric id or a wrong label arity
+  ;; would only show up in production. Here the value is read back from a real
+  ;; prometheus registry.
+  (let [metrics (ig/init-key :app.metrics/metrics {:default main/default-metrics})
+        name    (limiter-name :test-registry/by-profile)]
+
+    (th/with-climit [climit {:test-registry/by-profile {:permits 1 :timeout 3000}} metrics]
+      (let [cfg     (limiter-cfg climit :test-registry/by-profile "a")
+            entered (promise)
+            gate    (promise)
+            holder  (future (climit/invoke! cfg
+                                            (fn [_ _] (deliver entered true) @gate :held)
+                                            {}))]
+
+        (t/is (true? (deref entered 5000 false)))
+
+        (let [waiter (future (climit/invoke! cfg (fn [_ _] :waited) {}))]
+          (t/is (true? (wait-until #(= 1.0 (gauge-value metrics name)) 5000)))
+          (deliver gate true)
+          (t/is (= :waited (deref waiter 5000 :timeout)))
+          (t/is (= :held (deref holder 5000 :timeout)))
+          (t/is (true? (wait-until #(= 0.0 (gauge-value metrics name)) 5000))))))))
+
+(defn- rejected-record
+  "The first captured log record that reports a rejection with `reason`."
+  [records reason]
+  (let [deadline (+ (System/currentTimeMillis) 5000)]
+    (loop []
+      (let [record (first (filter (fn [record]
+                                    (let [props (::l/props record)]
+                                      (and (= "rejected" (get props :hint))
+                                           (= reason (get props :reason)))))
+                                  @records))]
+        (cond
+          record record
+          (> (System/currentTimeMillis) deadline) nil
+          :else (do (Thread/sleep 10) (recur)))))))
+
+(t/deftest rejection-logs-say-why-and-how-big-the-limits-are
+  ;; The line has to say whether the queue was full or the wait timed out, and
+  ;; how many permits and how much queue the limiter has, or nobody can tell
+  ;; whether the limiter did its job.
+  (let [records (atom [])]
+    (add-watch l/log-record ::capture
+               (fn [_ _ _ record] (swap! records conj record)))
+    (try
+      (record-metrics
+       (fn []
+         (th/with-climit [climit {:test-log/by-profile {:permits 1 :queue 2 :timeout 60000}}]
+           (let [name    (limiter-name :test-log/by-profile)
+                 cfg     (limiter-cfg climit :test-log/by-profile "a")
+                 entered (promise)
+                 gate    (promise)
+                 holder  (future (climit/invoke! cfg
+                                                 (fn [_ _] (deliver entered true) @gate :held)
+                                                 {}))]
+
+             (t/is (true? (deref entered 5000 false)))
+             (reset! calls [])
+
+             (let [q1 (future (climit/invoke! cfg (fn [_ _] :q1) {}))
+                   q2 (future (climit/invoke! cfg (fn [_ _] :q2) {}))]
+
+               ;; the two of them fill the queue, so the next one is rejected
+               (t/is (true? (wait-until #(= 2 (waiting-count climit name)) 5000)))
+               (t/is (some #(= 2 %) (waiting-value-of name)))
+               (t/is (= :concurrency-limit (failed-type #(climit/invoke! cfg (fn [_ _] :x) {}))))
+
+               (let [props (::l/props (rejected-record records "queue-full"))]
+                 (t/is (= 1 (get props :permits)))
+                 (t/is (= 2 (get props :queue-max)))
+                 (t/is (= :capacity-limit-reached (get props :code)))
+                 (t/is (= "queue-full" (get props :reason))))
+
+               (deliver gate true)
+               (t/is (= :held (deref holder 5000 :timeout)))
+               (deref q1 5000 nil)
+               (deref q2 5000 nil))))
+
+         ;; A wait that times out carries its own reason in the line, next to the
+         ;; code the limiter raised. The line is emitted at TRACE when nothing
+         ;; else is left queued behind it (the caller was the only one waiting),
+         ;; so the call to `log` is captured instead of the record, which the
+         ;; logger would drop.
+         (th/with-climit [climit {:test-log-timeout/by-profile {:permits 1 :timeout 300}}]
+           (let [cfg     (limiter-cfg climit :test-log-timeout/by-profile "a")
+                 lines   (atom [])
+                 entered (promise)
+                 gate    (promise)
+                 capture (fn [_ action _req-id _stats _elapsed code reason]
+                           (swap! lines conj [action code reason]))
+                 holder  (future (climit/invoke! cfg
+                                                 (fn [_ _] (deliver entered true) @gate :held)
+                                                 {}))]
+
+             (t/is (true? (deref entered 5000 false)))
+
+             (with-redefs [climit/log capture]
+               (t/is (= :concurrency-limit (failed-type #(climit/invoke! cfg (fn [_ _] :late) {}))))
+               (t/is (= [["rejected" :capacity-limit-reached "timeout"]]
+                        (filterv #(= "rejected" (first %)) @lines))))
+
+             (deliver gate true)
+             (t/is (= :held (deref holder 5000 :timeout)))))))
+
+      (finally
+        (remove-watch l/log-record ::capture)))))
+
+(t/deftest republish-writes-the-current-waiting-count
+  ;; A call that never comes back keeps the count up, but if it is also the
+  ;; last thing that happened nothing rewrites that series and it goes stale in
+  ;; the scrape. The republish is what keeps it visible. The counters are built
+  ;; on their own: with a component, its sampler would also publish the same
+  ;; count the moment its first tick lands inside the window.
+  (let [counters (#'climit/create-waiting-counters)
+        name     (limiter-name :test-republish/by-profile)
+        counter  ^java.util.concurrent.atomic.AtomicLong (#'climit/waiting-counter counters name)]
+
+    (.set counter 3)
+
+    (record-metrics
+     (fn []
+       (#'climit/republish-waiting (th/metrics-stub) counters)
+       (t/is (= [3] (waiting-value-of name)))))))
+
+(t/deftest halting-the-component-stops-the-republisher
+  ;; The republisher is a daemon thread started with the component: halting it
+  ;; has to stop the thread, or every restart leaves another one running.
+  (let [climit  (th/init-climit {:test-halt/by-profile {:permits 1 :timeout 3000}})
+        sampler ^java.util.concurrent.ScheduledThreadPoolExecutor (:sampler climit)]
+
+    (t/is (false? (.isShutdown sampler)))
+
+    (ig/halt-key! ::rpc/climit climit)
+
+    (t/is (true? (.isShutdown sampler)))))
+
+(t/deftest the-climit-metrics-that-remain-are-defined
+  ;; A typo in a metric id, or a definition that is not there, makes the
+  ;; publishing silent, which is the failure mode this work removes. And the
+  ;; gauges that could not tell the truth must be gone.
+  (let [metrics (ig/init-key :app.metrics/metrics {:default main/default-metrics})]
+
+    (t/is (= ["name"]
+             (:app.metrics.definition/labels (mtx/get-collector metrics :rpc-climit-waiting))))
+    (t/is (= ["name" "reason"]
+             (:app.metrics.definition/labels (mtx/get-collector metrics :rpc-climit-rejected))))
+    (t/is (some? (mtx/get-collector metrics :rpc-climit-timing)))
+
+    (t/is (nil? (mtx/get-collector metrics :rpc-climit-queue)))
+    (t/is (nil? (mtx/get-collector metrics :rpc-climit-permits)))
+    (t/is (nil? (mtx/get-collector metrics :http-worker-busy-threads)))))

backend/test/backend_tests/health_test.clj

@@ -0,0 +1,81 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) KALEIDOS INC Sucursal en España SL
+
+(ns backend-tests.health-test
+  (:require
+   [app.common.exceptions :as ex]
+   [app.db :as db]
+   [app.health :as health]
+   [app.http.debug :as debug]
+   [app.srepl.main :as srepl]
+   [backend-tests.helpers :as th]
+   [clojure.test :as t]
+   [yetti.response :as-alias yres]))
+
+(t/use-fixtures :once th/state-init)
+
+(defn- restore-availability
+  "The availability flag is a global atom shared by the whole test JVM, so
+  every test leaves the instance online."
+  [next]
+  (try
+    (next)
+    (finally
+      (health/set-online))))
+
+(t/use-fixtures :each (th/serial th/database-reset restore-availability))
+
+;; ----------------------------------------------------------------
+;; Tests: app.health state
+;; ----------------------------------------------------------------
+
+(t/deftest instance-is-online-by-default
+  (t/is (true? (health/online?))))
+
+(t/deftest set-offline-and-set-online-toggle-the-flag
+  (health/set-offline)
+  (t/is (false? (health/online?)))
+
+  (health/set-online)
+  (t/is (true? (health/online?))))
+
+;; ----------------------------------------------------------------
+;; Tests: /readyz handler
+;; ----------------------------------------------------------------
+
+(t/deftest readyz-reports-ok-when-instance-is-online
+  (let [response (debug/health-handler th/*system* {})]
+    (t/is (= 200 (::yres/status response)))
+    (t/is (= "OK" (::yres/body response)))))
+
+(t/deftest readyz-reports-unavailable-when-instance-is-offline
+  (health/set-offline)
+  (let [response (debug/health-handler th/*system* {})]
+    (t/is (= 503 (::yres/status response)))
+    (t/is (= "OFFLINE" (::yres/body response)))))
+
+(t/deftest readyz-does-not-query-the-database-when-instance-is-offline
+  (health/set-offline)
+  (with-redefs [db/exec-one! (fn [_ _]
+                               (throw (ex-info "database unreachable" {})))]
+    (let [response (debug/health-handler th/*system* {})]
+      (t/is (= 503 (::yres/status response)))
+      (t/is (= "OFFLINE" (::yres/body response))))))
+
+;; ----------------------------------------------------------------
+;; Tests: srepl helpers (the operator entry points)
+;; ----------------------------------------------------------------
+
+(t/deftest srepl-helpers-change-the-readyz-answer
+  (srepl/set-offline)
+  (let [drained (debug/health-handler th/*system* {})]
+    (t/is (= 503 (::yres/status drained)))
+    (t/is (= "OFFLINE" (::yres/body drained))))
+
+  (srepl/set-online)
+  (let [restored (debug/health-handler th/*system* {})]
+    (t/is (= 200 (::yres/status restored)))
+    (t/is (= "OK" (::yres/body restored)))))

backend/test/backend_tests/helpers.clj

@@ -24,9 +24,11 @@
    [app.main :as main]
    [app.media]
    [app.media :as-alias mtx]
+   [app.metrics :as-alias metrics]
    [app.migrations]
    [app.msgbus :as-alias mbus]
    [app.rpc :as-alias rpc]
+   [app.rpc.climit :as-alias climit]
    [app.rpc.commands.auth :as cmd.auth]
    [app.rpc.commands.files :as files]
    [app.rpc.commands.files-create :as files.create]
@@ -541,6 +543,40 @@
                                      (assoc ::jobs/context (jobs/make-context row))
                                      (assoc ::jobs/job-id (:id row)))))))))
 
+(defn metrics-stub
+  "A metrics instance with no collectors, where every `run!` is a no-op."
+  []
+  (reify metrics/IMetrics
+    (get-handler [_] nil)
+    (get-collector [_ _] nil)
+    (get-registry [_] nil)))
+
+(defn init-climit
+  "Build a concurrency limiter component from an inline config map. The
+  optional second argument is the metrics instance to publish to (a
+  `metrics-stub` by default, where every `run!` is a no-op)."
+  ([config]
+   (init-climit config (metrics-stub)))
+  ([config metrics]
+   (let [file (doto (java.io.File/createTempFile "climit" ".edn")
+                (.deleteOnExit))]
+     (spit file (pr-str config))
+     (ig/init-key ::rpc/climit
+                  {::climit/enabled true
+                   ::climit/config (.getAbsolutePath file)
+                   ::metrics/metrics metrics}))))
+
+(defmacro with-climit
+  "Build a concurrency limiter from an inline config map, run the body and
+  halt it, so the republisher thread it starts never outlives the test. An
+  optional third binding element is the metrics instance to publish to."
+  [[sym config & [metrics]] & body]
+  `(let [~sym (init-climit ~config ~@(when metrics [metrics]))]
+     (try
+       ~@body
+       (finally
+         (ig/halt-key! ::rpc/climit ~sym)))))
+
 ;; --- UTILS
 
 (defn print-error!

backend/test/backend_tests/http_metrics_test.clj

@@ -16,7 +16,6 @@
    io.prometheus.client.Counter
    io.prometheus.client.Gauge
    io.undertow.server.ConnectorStatistics
-   java.util.concurrent.ScheduledThreadPoolExecutor
    org.xnio.management.XnioWorkerMXBean))
 
 (t/use-fixtures :once th/state-init)
@@ -29,9 +28,6 @@
   {:http-worker-queue-size          {:name "penpot_http_worker_queue_size"
                                      :help "test"
                                      :type :gauge}
-   :http-worker-busy-threads        {:name "penpot_http_worker_busy_threads"
-                                     :help "test"
-                                     :type :gauge}
    :http-worker-pool-size           {:name "penpot_http_worker_pool_size"
                                      :help "test"
                                      :type :gauge}
@@ -132,23 +128,20 @@
     (http/sample-worker-metrics metrics mxbean)
 
     (t/is (= 2.0  (gauge-value (collector-instance metrics :http-worker-queue-size))))
-    (t/is (= 10.0 (gauge-value (collector-instance metrics :http-worker-busy-threads))))
     (t/is (= 40.0 (gauge-value (collector-instance metrics :http-worker-pool-size))))
     (t/is (= 512.0 (gauge-value (collector-instance metrics :http-worker-max-pool-size))))))
 
 (t/deftest sample-worker-metrics-skips-negative-samples
-  ;; the xnio MXBean occasionally returns -1 on the busy thread count;
-  ;; a negative value is a missing measurement, not a zero.
+  ;; the xnio MXBean occasionally returns -1 on a count; a negative value is a
+  ;; missing measurement, not a zero.
   (let [metrics (fake-metrics)
-        mxbean  (fake-mxbean {:queue 0 :busy -1 :pool 4 :max 512})]
+        mxbean  (fake-mxbean {:queue -1 :busy -1 :pool 4 :max 512})]
 
     (http/sample-worker-metrics metrics mxbean)
 
     (t/is (= 0.0 (gauge-value (collector-instance metrics :http-worker-queue-size))))
     (t/is (= 4.0 (gauge-value (collector-instance metrics :http-worker-pool-size))))
-    (t/is (= 512.0 (gauge-value (collector-instance metrics :http-worker-max-pool-size))))
-    (t/is (= 0.0
-             (gauge-value (collector-instance metrics :http-worker-busy-threads))))))
+    (t/is (= 512.0 (gauge-value (collector-instance metrics :http-worker-max-pool-size))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Test: connector metrics
@@ -230,28 +223,3 @@
       (finally
         (px/shutdown-now sampler)
         (t/is (px/shutdown? sampler))))))
-
-(t/deftest create-metrics-sampler-reschedules-after-error
-  ;; the docstring promise: an unexpected error on a single sample must
-  ;; not cancel the following runs. The first sample runs immediately
-  ;; and throws; the next one must still be scheduled afterwards.
-  (let [calls (atom 0)]
-    (with-redefs [http/sample-http-metrics (fn [_ _ _]
-                                             (swap! calls inc)
-                                             (throw (ex-info "boom" {})))]
-      (let [sampler (http/create-metrics-sampler nil (fake-metrics))
-            queue   (.getQueue ^ScheduledThreadPoolExecutor sampler)]
-        (try
-          (t/is (loop [i 0]
-                  (cond (pos? @calls) true
-                        (> i 200) false
-                        :else (do (Thread/sleep 10) (recur (inc i)))))
-                "the first sample must run immediately")
-
-          (t/is (loop [i 0]
-                  (cond (= 1 (.size queue)) true
-                        (> i 200) false
-                        :else (do (Thread/sleep 10) (recur (inc i)))))
-                "the next sample must be scheduled after the error")
-          (finally
-            (px/shutdown-now sampler)))))))

backend/test/backend_tests/metrics_test.clj

@@ -10,11 +10,13 @@
    [app.metrics :as mtx]
    [app.metrics.definition :as-alias mdef]
    [clojure.test :as t]
-   [integrant.core :as ig])
+   [integrant.core :as ig]
+   [promesa.exec :as px])
   (:import
    io.prometheus.client.Collector$MetricFamilySamples
    io.prometheus.client.Collector$MetricFamilySamples$Sample
-   io.prometheus.client.CollectorRegistry))
+   io.prometheus.client.CollectorRegistry
+   java.util.concurrent.ScheduledThreadPoolExecutor))
 
 (def ^:private valid-definitions? @#'app.metrics/valid-definitions?)
 
@@ -136,3 +138,28 @@
                         ::mdef/help "typo check"
                         ::mdef/type :histogram
                         ::mdef/bucksets [100]}}))))
+
+(t/deftest create-sampler-reschedules-after-error
+  ;; The docstring promise, tested once for both call sites: an unexpected error
+  ;; on a single sample must not cancel the following runs. The first sample
+  ;; runs immediately and throws; the next one must still be scheduled.
+  (let [calls   (atom 0)
+        sampler (mtx/create-sampler 1000 (fn []
+                                           (swap! calls inc)
+                                           (throw (ex-info "boom" {}))))]
+    (try
+      (t/is (loop [i 0]
+              (cond (pos? @calls) true
+                    (> i 200) false
+                    :else (do (Thread/sleep 10) (recur (inc i)))))
+            "the first sample must run immediately")
+
+      (let [queue (.getQueue ^ScheduledThreadPoolExecutor sampler)]
+        (t/is (loop [i 0]
+                (cond (= 1 (.size queue)) true
+                      (> i 200) false
+                      :else (do (Thread/sleep 10) (recur (inc i)))))
+              "the next sample must be scheduled after the error"))
+
+      (finally
+        (px/shutdown-now sampler)))))

backend/test/backend_tests/objects_gc_test.clj

@@ -0,0 +1,125 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) KALEIDOS INC Sucursal en España SL
+
+(ns backend-tests.objects-gc-test
+  (:require
+   [app.common.logging :as l]
+   [app.common.time :as ct]
+   [app.db :as db]
+   [app.storage :as sto]
+   [app.tasks.objects-gc :as ogc]
+   [backend-tests.helpers :as th]
+   [clojure.test :as t]))
+
+(t/use-fixtures :once th/state-init)
+(t/use-fixtures :each th/database-reset)
+
+(defn- create-deleted-file!
+  "Creates a file and applies the deletion cascade on it (the same task the RPC
+  uses), so its children are marked as deleted for the given date. Returns the
+  file."
+  [profile i deleted-at]
+  (let [file (th/create-file* i {:profile-id (:id profile)
+                                 :project-id (:default-project-id profile)})]
+    (th/run-task! :delete-object {:object :file
+                                  :deleted-at deleted-at
+                                  :id (:id file)})
+    file))
+
+(defn- block-file!
+  "Leaves an unmarked `file_media_object` pointing at the file, which is what
+  happens in production: a child that the deletion cascade did not mark. Its
+  foreign key towards `file` is `NO ACTION`, so it blocks the file deletion."
+  [file]
+  (let [media (sto/put-object! (::sto/storage th/*system*)
+                               {::sto/content (sto/content "media")
+                                :content-type "text/plain"
+                                :bucket "file-media-object"})]
+    (th/create-file-media-object* {:file-id (:id file)
+                                   :media-id (:id media)})))
+
+(defn- find-file
+  [id]
+  (th/db-get :file {:id id} {::db/remove-deleted false}))
+
+(defn- chunk-error
+  "The first captured log record that reports a skipped chunk for `obj`,
+  waiting for it because logging is asynchronous."
+  [records obj]
+  (let [deadline (+ (System/currentTimeMillis) 5000)]
+    (loop []
+      (let [record (first (filter (fn [record]
+                                    (let [props (::l/props record)]
+                                      (and (= obj (get props :obj))
+                                           (= "error on chunk deletion, skipping it"
+                                              (get props :hint)))))
+                                  @records))]
+        (cond
+          record record
+          (> (System/currentTimeMillis) deadline) nil
+          :else (do (Thread/sleep 10) (recur)))))))
+
+(t/deftest deletes-the-pending-files
+  (let [profile (th/create-profile* 1)
+        file    (create-deleted-file! profile 1 (ct/in-past "10m"))
+        result  (th/run-task! :objects-gc {})]
+
+    (t/is (pos? (:processed result)))
+    (t/is (nil? (find-file (:id file))))))
+
+(t/deftest profile-cascade-keeps-profile-deletion-date
+  ;; The cascade marks the owned rows with the deletion date of the profile,
+  ;; like the RPC delete-profile flow does, not with the timestamp of the run.
+  ;; The team survives because only the profiles chunk runs here, so its row
+  ;; still shows that date.
+  (let [profile (th/create-profile* 1)
+        _       (th/db-update! :profile {:deleted-at (ct/in-past "30m")} {:id (:id profile)})
+
+        deleted-at (:deleted-at (th/db-get :profile {:id (:id profile)}
+                                           {::db/remove-deleted false}))
+
+        cfg     {::db/pool th/*pool*
+                 ::sto/storage (::sto/storage th/*system*)
+                 ::ogc/threshold deleted-at}
+        total   (#'ogc/delete-profiles-chunk cfg [(:id profile)])]
+
+    (t/testing "the profile is gone and the chunk reports it"
+      (t/is (= 1 total))
+      (t/is (nil? (th/db-get :profile {:id (:id profile)} {::db/remove-deleted false}))))
+
+    (t/testing "the owned team keeps the deletion date of the profile"
+      (t/is (= deleted-at (:deleted-at (th/db-get :team {:id (:default-team-id profile)}
+                                                  {::db/remove-deleted false})))))))
+
+(t/deftest blocked-chunk-does-not-stop-the-run
+  ;; Chunks of one file: the blocked file takes down its own chunk and nothing
+  ;; else, so the clean file of the next chunk is still deleted and the run
+  ;; finishes. The next run retries the blocked file.
+  (let [profile (th/create-profile* 1)
+        blocked (create-deleted-file! profile 1 (ct/in-past "30m"))
+        clean   (create-deleted-file! profile 2 (ct/in-past "20m"))
+
+        _       (block-file! blocked)
+
+        records (atom [])
+        _       (add-watch l/log-record ::capture
+                           (fn [_ _ _ record] (swap! records conj record)))
+        result  (try
+                  (th/run-task! :objects-gc {:chunk-size 1})
+                  (finally
+                    (remove-watch l/log-record ::capture)))]
+
+    (t/testing "the clean file of the next chunk is deleted"
+      (t/is (nil? (find-file (:id clean)))))
+
+    (t/testing "the blocked file is still pending"
+      (t/is (some? (find-file (:id blocked)))))
+
+    (t/testing "the failed chunk is reported"
+      (t/is (some? (chunk-error records "file"))))
+
+    (t/testing "the run finishes"
+      (t/is (pos? (:processed result))))))

backend/test/backend_tests/restore_storage_objects_test.clj

@@ -0,0 +1,132 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) KALEIDOS INC Sucursal en España SL
+
+(ns backend-tests.restore-storage-objects-test
+  (:require
+   [app.common.time :as ct]
+   [app.common.uuid :as uuid]
+   [app.db :as db]
+   [app.rpc.commands.files :as files]
+   [app.srepl.main :as srepl]
+   [app.storage :as sto]
+   [app.system :as sys]
+   [backend-tests.helpers :as th]
+   [clojure.test :as t]))
+
+(t/use-fixtures :once th/state-init)
+(t/use-fixtures :each th/database-reset)
+
+;; Restoring a file brings its rows back to life, so the storage objects those
+;; rows reference must stop being marked for deletion: otherwise the storage GC
+;; hits the foreign key and skips them forever.
+
+(defn- put-object!
+  ([bucket]
+   (put-object! bucket {}))
+  ([bucket metadata]
+   (sto/put-object! (::sto/storage th/*system*)
+                    (merge {::sto/content (sto/content "sobject")
+                            :content-type "text/plain"
+                            :bucket bucket}
+                           metadata))))
+
+(defn- find-object
+  [id]
+  (th/db-get :storage-object {:id id} {::db/remove-deleted false}))
+
+(defn- mark-object!
+  [id]
+  (th/db-update! :storage-object {:deleted-at (ct/in-past {:days 1})} {:id id}))
+
+(defn- restore-file!
+  [file-id]
+  (db/tx-run! th/*system*
+              (fn [{:keys [::db/conn]}]
+                (#'files/restore-files conn [file-id]))))
+
+(t/deftest restoring-a-file-unmarks-the-objects-its-rows-reference
+  (let [profile   (th/create-profile* 1)
+        file      (th/create-file* 1 {:profile-id (:id profile)
+                                      :project-id (:default-project-id profile)})
+
+        ;; The media object's thumbnail points at an object of another bucket:
+        ;; that is the anomaly found in production. The marking task decides
+        ;; with the table of the object's bucket, so it does not see that
+        ;; reference and ends up marking an object that a live row still uses.
+        media-id  (:id (put-object! "file-media-object"))
+        thumb-id  (:id (put-object! "file-object-thumbnail"))
+        bystander (:id (put-object! "file-object-thumbnail"))
+        mobject   (th/create-file-media-object* {:file-id (:id file)
+                                                 :media-id media-id})]
+
+    (th/db-update! :file-media-object
+                   {:thumbnail-id thumb-id
+                    :deleted-at (ct/in-past {:days 1})}
+                   {:id (:id mobject)})
+
+    (t/testing "the fixture reproduces the anomaly"
+      (t/is (= "file-object-thumbnail"
+               (:bucket (meta (sto/get-object (::sto/storage th/*system*) thumb-id))))))
+
+    ;; The objects end up marked as deleted, as the marking task leaves them.
+    (mark-object! media-id)
+    (mark-object! thumb-id)
+    (mark-object! bystander)
+
+    (restore-file! (:id file))
+
+    (t/testing "the objects referenced by the restored rows are alive again"
+      (t/is (nil? (:deleted-at (find-object media-id))))
+      (t/is (nil? (:deleted-at (find-object thumb-id)))))
+
+    (t/testing "objects of other rows are left alone"
+      (t/is (some? (:deleted-at (find-object bystander)))))))
+
+(t/deftest restoring-a-file-unmarks-the-objects-of-its-data
+  (let [profile  (th/create-profile* 1)
+        file     (th/create-file* 1 {:profile-id (:id profile)
+                                     :project-id (:default-project-id profile)})
+        data-id  (uuid/next)
+        ;; file-data objects carry the ids of their row: the GC resolves the
+        ;; reference with that pair.
+        sobject  (:id (put-object! "file-data" {:file-id (:id file)
+                                                :id data-id}))]
+
+    (th/db-update! :file {:deleted-at (ct/in-past {:days 1})} {:id (:id file)})
+    (th/db-insert! :file-data
+                   {:file-id (:id file)
+                    :id data-id
+                    :type "main"
+                    :backend "fs"
+                    :deleted-at (ct/in-past {:days 1})
+                    :metadata (db/json {"storage-ref-id" (str sobject)})})
+    (mark-object! sobject)
+
+    (restore-file! (:id file))
+
+    (t/is (nil? (:deleted-at (find-object sobject))))))
+
+(t/deftest restoring-a-team-unmarks-the-objects-of-its-fonts
+  (let [profile  (th/create-profile* 1)
+        team     (th/create-team* 1 {:profile-id (:id profile)})
+        sobject  (:id (put-object! "team-font-variant"))]
+
+    (th/db-insert! :team-font-variant
+                   {:id (uuid/next)
+                    :team-id (:id team)
+                    :profile-id (:id profile)
+                    :font-id (uuid/next)
+                    :font-family "somefont"
+                    :font-weight 400
+                    :font-style "normal"
+                    :deleted-at (ct/in-past {:days 1})
+                    :woff1-file-id sobject})
+    (mark-object! sobject)
+
+    (with-redefs [sys/system th/*system*]
+      (srepl/restore-team! (:id team)))
+
+    (t/is (nil? (:deleted-at (find-object sobject))))))

backend/test/backend_tests/rpc_audit_test.clj

@@ -13,6 +13,7 @@
    [app.db :as db]
    [app.loggers.audit :as audit]
    [app.rpc :as-alias rpc]
+   [app.rpc.climit :as climit]
    [app.util.services :as sv]
    [backend-tests.helpers :as th]
    [clojure.test :as t]
@@ -35,6 +36,48 @@
         "x-forwarded-for" "127.0.0.44"
         "x-real-ip" "127.0.0.43"))))
 
+(t/deftest push-audit-events-limit-is-keyed-by-profile
+  ;; Regression guard. This command asks for a per-profile limit, but it used
+  ;; to declare it as a plain keyword next to `::climit/key-fn`, metadata that
+  ;; `climit/wrap` does not read: it takes the key only from the positional
+  ;; `key-fn` of the vector form. That silently turned the limit into a single
+  ;; shared one, so one stuck call ended up rejecting the audit batches of
+  ;; every profile on the instance. Two profiles must not share a limiter.
+  (th/with-climit [climit {:submit-audit-events/by-profile
+                           {:permits 1 :queue 1 :timeout 30000}}]
+    (let [;; The metadata declared by the command itself, that is what the test
+          ;; has to cover.
+          mdata   (meta (ns-resolve 'app.rpc.commands.audit 'sm$push-audit-events))
+
+          gate    (promise)
+          entered (promise)
+          calls   (atom 0)
+          handler (fn [_ _]
+                    (when (= 1 (swap! calls inc))
+                      (deliver entered true)
+                      @gate)
+                    :ok)
+          wrapped (climit/wrap {::rpc/climit climit} handler mdata)
+          call    (fn [profile-id]
+                    (wrapped {::rpc/climit climit} {::rpc/profile-id profile-id}))
+          pid-a   (uuid/next)
+          pid-b   (uuid/next)
+          holder  (future (call pid-a))]
+
+      ;; The first call stays inside the handler holding the only permit.
+      (t/is (true? (deref entered 2000 false)))
+
+      ;; Another call from the SAME profile shares the limiter, so it waits.
+      (let [same (future (call pid-a))]
+        (t/is (= :waiting (deref same 300 :waiting))))
+
+      ;; A different profile owns a different limiter and is served right away.
+      ;; With the shared limiter (the bug) this one waits too and times out.
+      (t/is (= :ok (deref (future (call pid-b)) 2000 :timeout)))
+
+      (deliver gate true)
+      (t/is (= :ok (deref holder 2000 :timeout))))))
+
 (t/deftest prepare-context-initiator-is-plain-string
   ;; The initiator must always be a plain string, never a keyword: shared-key
   ;; authenticated callers (exporter, admin-console) arrive as keywords on

backend/test/backend_tests/rpc_climit_test.clj

@@ -0,0 +1,51 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) KALEIDOS INC Sucursal en España SL
+
+(ns backend-tests.rpc-climit-test
+  (:require
+   [app.rpc.climit :as-alias climit]
+   [app.util.services :as-alias sv]
+   [backend-tests.helpers :as th]
+   [clojure.test :as t]))
+
+(t/use-fixtures :once th/state-init)
+
+(defn- method-limit-declarations
+  "The `::climit/id` declarations of every RPC command, as the running system
+  wraps them."
+  []
+  (->> (:app.rpc/methods th/*system*)
+       (vals)
+       (map first)
+       (keep (fn [mdata]
+               (when-let [limits (::climit/id mdata)]
+                 [mdata limits])))))
+
+(t/deftest commands-declare-the-by-profile-limit-before-the-global-one
+  ;; `climit/get-limits` reverses a declared vector of pairs, so the first one
+  ;; declared is acquired first, and the nested `climit/invoke!` chains read the
+  ;; same declaration. A pair declared global first puts a command back in the
+  ;; inverted order that parked two paths of one profile for good.
+  (let [declarations (method-limit-declarations)]
+
+    ;; the system wraps every command, so a short list means the scan went stale
+    (t/is (<= 10 (count declarations)))
+
+    (doseq [[mdata limits] declarations
+            :when (and (vector? limits) (vector? (first limits)))]
+      (let [ids   (mapv first limits)
+            index (into {} (map-indexed (fn [idx id] [id idx]) ids))
+            where (str (::sv/name mdata))]
+
+        (t/is (= (count ids) (count (distinct ids)))
+              (str where " declares the same limit twice"))
+
+        (doseq [[id idx] index
+                :when (= "by-profile" (name id))]
+          (when-let [gidx (get index (keyword (namespace id) "global"))]
+            (t/is (< idx gidx)
+                  (str where " must declare " id " before "
+                       (keyword (namespace id) "global")))))))))

backend/test/backend_tests/srepl_main_test.clj

@@ -2,13 +2,45 @@
 ;; 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
+;; Copyright (c) KALEIDOS INC Sucursal en España SL
 
 (ns backend-tests.srepl-main-test
   (:require
+   [app.common.time :as ct]
+   [app.jobs :as jobs]
    [app.srepl.main :as srepl]
+   [app.system :as sys]
+   [backend-tests.helpers :as th]
    [clojure.test :as t]))
 
+(t/use-fixtures :once th/state-init)
+(t/use-fixtures :each th/database-reset)
+
+;; --- HELPERS
+
+(defn- capture-submissions!
+  "Runs `f` with `jobs/submit` replaced by a collector, and returns the option
+  maps it was called with, in order."
+  [f]
+  (let [submitted (atom [])]
+    (with-redefs [jobs/submit (fn [_cfg opts]
+                                (swap! submitted conj opts)
+                                (get-in opts [::jobs/params :id]))]
+      (f))
+    @submitted))
+
+(defn- params-of
+  [submitted]
+  (mapv ::jobs/params submitted))
+
+(defn- create-deleted-profile!
+  [i deleted-at]
+  (let [profile (th/create-profile* i)]
+    (th/db-update! :profile {:deleted-at deleted-at} {:id (:id profile)})
+    profile))
+
+;; --- TESTS
+
 (t/deftest parse-emails
   (t/is (= ["some@example.com"]
            (srepl/parse-emails "some@example.com")))
@@ -26,3 +58,95 @@
 
   (t/is (thrown? clojure.lang.ExceptionInfo
                  (srepl/parse-emails 42))))
+
+(t/deftest cascade-enqueues-one-delete-object-job-per-deleted-row
+  (let [deleted   (create-deleted-profile! 991 (ct/in-past {:days 30}))
+        _         (th/create-profile* 992)
+        submitted (capture-submissions!
+                   #(#'srepl/submit-deleted-cascade
+                     th/*system* {:table "profile" :object :profile}))]
+
+    (t/testing "only the soft-deleted row is processed"
+      (t/is (= 1 (count submitted))))
+
+    (t/testing "the enqueued job is a delete-object for that row"
+      (let [opts (first submitted)]
+        (t/is (= :delete-object (::jobs/name opts)))
+        (t/is (= {:object :profile :id (:id deleted)}
+                 (select-keys (::jobs/params opts) [:object :id])))))
+
+    (t/testing "the date is the row's own, not now"
+      (t/is (ct/is-before? (:deleted-at (::jobs/params (first submitted)))
+                           (ct/in-past {:days 29}))))
+
+    (t/testing "label is the row id and dedupe is on"
+      (t/is (= (str (:id deleted)) (::jobs/label (first submitted))))
+      (t/is (true? (::jobs/dedupe (first submitted)))))))
+
+(t/deftest cascade-honours-limit-and-ids
+  (let [p1 (create-deleted-profile! 993 (ct/in-past {:days 10}))
+        _  (create-deleted-profile! 994 (ct/in-past {:days 9}))
+        _  (create-deleted-profile! 995 (ct/in-past {:days 8}))]
+
+    (t/testing "limit bounds how many rows are read"
+      (let [submitted (capture-submissions!
+                       #(#'srepl/submit-deleted-cascade
+                         th/*system* {:table "profile" :object :profile :limit 2}))]
+        (t/is (= 2 (count submitted)))))
+
+    (t/testing "ids restricts the run to the given rows"
+      (let [submitted (capture-submissions!
+                       #(#'srepl/submit-deleted-cascade
+                         th/*system* {:table "profile" :object :profile :ids [(:id p1)]}))]
+        (t/is (= [{:object :profile :id (:id p1)}]
+                 (mapv #(select-keys % [:object :id]) (params-of submitted))))))))
+
+(t/deftest cascade-dry-run-counts-without-enqueueing
+  (let [_         (create-deleted-profile! 996 (ct/in-past {:days 10}))
+        submitted (atom [])
+        result    (with-redefs [jobs/submit (fn [_cfg opts] (swap! submitted conj opts))]
+                    (#'srepl/submit-deleted-cascade
+                     th/*system* {:table "profile" :object :profile :dry-run? true}))]
+
+    (t/is (= 1 (:found result)))
+    (t/is (= 0 (:submitted result)))
+    (t/is (empty? @submitted))))
+
+(t/deftest public-helpers-read-their-own-table
+  (let [profile (th/create-profile* 997)
+        team    (th/create-team* 997 {:profile-id (:id profile)})
+        project (th/create-project* 997 {:profile-id (:id profile)
+                                         :team-id (:id team)})
+        file    (th/create-file* 997 {:profile-id (:id profile)
+                                      :project-id (:id project)})
+        old     (ct/in-past {:days 10})]
+
+    (th/db-update! :profile {:deleted-at old} {:id (:id profile)})
+    (th/db-update! :team {:deleted-at old} {:id (:id team)})
+    (th/db-update! :project {:deleted-at old} {:id (:id project)})
+    (th/db-update! :file {:deleted-at old} {:id (:id file)})
+
+    (with-redefs [sys/system th/*system*]
+      (let [ids (fn [submitted] (into #{} (map :id (params-of submitted))))]
+
+        (t/testing "profiles helper"
+          (let [submitted (capture-submissions! #(srepl/process-deleted-profiles-cascade))]
+            (t/is (contains? (ids submitted) (:id profile)))))
+
+        (t/testing "teams helper"
+          (let [submitted (capture-submissions! #(srepl/process-deleted-teams-cascade))]
+            (t/is (contains? (ids submitted) (:id team)))))
+
+        (t/testing "projects helper"
+          (let [submitted (capture-submissions! #(srepl/process-deleted-projects-cascade))]
+            (t/is (contains? (ids submitted) (:id project)))))
+
+        (t/testing "files helper"
+          (let [submitted (capture-submissions! #(srepl/process-deleted-files-cascade))]
+            (t/is (contains? (ids submitted) (:id file)))))
+
+        (t/testing "the helpers accept options"
+          (let [submitted (capture-submissions!
+                           #(srepl/process-deleted-files-cascade :ids [(:id file)]))]
+            (t/is (= [{:object :file :id (:id file)}]
+                     (mapv #(select-keys % [:object :id]) (params-of submitted))))))))))

backend/test/backend_tests/storage_gc_deleted_test.clj

@@ -0,0 +1,93 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) KALEIDOS INC Sucursal en España SL
+
+(ns backend-tests.storage-gc-deleted-test
+  (:require
+   [app.common.time :as ct]
+   [app.common.uuid :as uuid]
+   [app.db :as db]
+   [app.storage :as sto]
+   [backend-tests.helpers :as th]
+   [clojure.test :as t]))
+
+(t/use-fixtures :once th/state-init)
+(t/use-fixtures :each th/database-reset)
+
+;; The GC processes the pending objects in chunks of 25 (see `clean-deleted`), so
+;; a chunk boundary is what separates a blocked object from the objects of the
+;; next chunk.
+
+(def ^:private chunk-size 25)
+
+(defn- put-object!
+  "Puts a tiny object in storage and returns it."
+  [deleted-at]
+  (let [sobject (sto/put-object! (::sto/storage th/*system*)
+                                 {::sto/content (sto/content "sobject")
+                                  :content-type "text/plain"
+                                  :bucket "file-media-object"})]
+    (th/db-update! :storage-object {:deleted-at deleted-at} {:id (:id sobject)})
+    sobject))
+
+(defn- blocked-object!
+  "Puts an object that cannot be deleted because a `file_media_object` points
+  at it as its thumbnail (a `NO ACTION` foreign key)."
+  [file-id]
+  (let [media   (sto/put-object! (::sto/storage th/*system*)
+                                 {::sto/content (sto/content "media")
+                                  :content-type "text/plain"
+                                  :bucket "file-media-object"})
+        blocked (put-object! (ct/in-past "30m"))]
+
+    (th/db-insert! :file-media-object
+                   {:id (uuid/next)
+                    :file-id file-id
+                    :is-local true
+                    :name "sample"
+                    :media-id (:id media)
+                    :thumbnail-id (:id blocked)
+                    :width 100
+                    :height 100
+                    :mtype "image/svg+xml"})
+
+    blocked))
+
+(defn- find-object
+  [id]
+  (th/db-get :storage-object {:id id} {::db/remove-deleted false}))
+
+(t/deftest deletes-the-pending-objects
+  (let [objects (mapv (fn [_] (put-object! (ct/in-past "10m"))) (range 3))
+        result  (th/run-task! :storage-gc-deleted {})]
+
+    (t/is (= 3 (:deleted result)))
+
+    (doseq [sobject objects]
+      (t/is (nil? (find-object (:id sobject)))))))
+
+(t/deftest blocked-chunk-does-not-stop-the-run
+  (let [profile (th/create-profile* 1)
+        file    (th/create-file* 1 {:profile-id (:id profile)
+                                    :project-id (:default-project-id profile)})
+
+        ;; The blocked object goes first in `deleted_at` order, so it lands in
+        ;; the first chunk, together with the objects that fill it up. The last
+        ;; object of the batch lands in the next chunk: it is the one that
+        ;; proves the run kept going after the failure.
+        blocked (blocked-object! (:id file))
+        _       (mapv (fn [_] (put-object! (ct/in-past "20m"))) (range (dec chunk-size)))
+        last-id (:id (put-object! (ct/in-past "5m")))
+
+        result  (th/run-task! :storage-gc-deleted {})]
+
+    (t/testing "the run finishes and only the object of the second chunk is deleted"
+      (t/is (= 1 (:deleted result))))
+
+    (t/testing "the blocked object is still pending"
+      (t/is (some? (find-object (:id blocked)))))
+
+    (t/testing "the object of the next chunk is gone"
+      (t/is (nil? (find-object last-id))))))

backend/test/backend_tests/storage_test.clj

@@ -698,7 +698,10 @@
                                       (throw (ex-info "boom" {})))
                                     (apply orig args))))
       (try
-        (t/is (thrown? Exception (th/run-task! :storage-gc-deleted {})))
+        (let [result (th/run-task! :storage-gc-deleted {})]
+          (t/testing "the fault of the second chunk is skipped, the run finishes"
+            (t/is (= 25 (:deleted result)))))
+
         (t/testing "first chunk committed before the fault"
           (t/is (= 1 (:cnt (th/db-exec-one! ["SELECT count(*) AS cnt FROM storage_object WHERE deleted_at IS NOT NULL"])))))
         (finally

common/src/app/common/files/migrations.cljc

@@ -2179,6 +2179,44 @@
         (update :pages-index d/update-vals repair-container)
         (d/update-when :components d/update-vals repair-container))))
 
+;; A shape can point to an existing parent that does not list it in its
+;; `:shapes`. Such shapes are unreachable from the root, and operations
+;; that walk the tree through `:shapes` miss them; e.g. deleting a variant
+;; also deleted its container, which looked empty, and left the other
+;; variants pointing to a deleted parent. Add them back to their parent.
+(defmethod migrate-data "0032-fix-children-not-in-parent"
+  [data _]
+  (letfn [(get-unlisted-children [objects]
+            ;; Returns a {parent-id -> [child-id]} map
+            (let [listed (reduce-kv (fn [result id shape]
+                                      (if-let [shapes (not-empty (:shapes shape))]
+                                        (assoc result id (set shapes))
+                                        result))
+                                    {}
+                                    objects)]
+              (reduce-kv (fn [result id shape]
+                           (let [parent-id (:parent-id shape)]
+                             (if (and (not (cfh/root? shape))
+                                      (contains? objects parent-id)
+                                      (not (contains? (get listed parent-id) id)))
+                               (update result parent-id (fnil conj []) id)
+                               result)))
+                         {}
+                         objects)))
+
+          (fix-objects [objects]
+            (reduce-kv (fn [objects parent-id child-ids]
+                         (update-in objects [parent-id :shapes] (fnil into []) child-ids))
+                       objects
+                       (get-unlisted-children objects)))
+
+          (update-container [container]
+            (d/update-when container :objects fix-objects))]
+
+    (-> data
+        (update :pages-index d/update-vals update-container)
+        (d/update-when :components d/update-vals update-container))))
+
 (def available-migrations
   (into (d/ordered-set)
         ["legacy-2"
@@ -2267,4 +2305,5 @@
          "0028-normalize-constrained-values"
          "0029-move-background-blur-out-of-blur"
          "0030-remove-stroke-per-side-attr"
-         "0031-migrate-stroke-width-token-attr"]))
+         "0031-migrate-stroke-width-token-attr"
+         "0032-fix-children-not-in-parent"]))

common/src/app/common/files/repair.cljc

@@ -45,29 +45,25 @@
 
 (defmethod repair-error :parent-not-found
   [_ {:keys [shape page-id] :as error} file-data _]
-  (let [repair-shape
-        (fn [shape]
-          ;; Set parent to root frame.
-          (log/debug :hint "  -> set to " :parent-id uuid/zero)
-          (assoc shape :parent-id uuid/zero))]
-
-    (log/debug :hint "repairing shape :parent-not-found" :id (:id shape) :name (:name shape) :page-id page-id)
-    (-> (pcb/empty-changes nil page-id)
-        (pcb/with-file-data file-data)
-        (pcb/update-shapes [(:id shape)] repair-shape))))
+  ;; Move the shape to the root frame. `:mov-objects` adds it to the
+  ;; root's children list when applied, so several repairs on the same
+  ;; root do not overwrite each other
+  (log/debug :hint "repairing shape :parent-not-found" :id (:id shape) :name (:name shape) :page-id page-id)
+  (log/debug :hint "  -> set to " :parent-id uuid/zero)
+  (-> (pcb/empty-changes nil page-id)
+      (pcb/with-file-data file-data)
+      (pcb/change-parent uuid/zero [shape] nil {:allow-altering-copies true})))
 
 (defmethod repair-error :child-not-in-parent
   [_ {:keys [shape page-id] :as error} file-data _]
-  (let [repair-shape
-        (fn [parent-shape]
-          ;; Add shape to parent's children list
-          (log/debug :hint "  -> add children to" :parent-id (:id parent-shape))
-          (update parent-shape :shapes conj (:id shape)))]
-
-    (log/debug :hint "repairing shape :child-not-in-parent" :id (:id shape) :name (:name shape) :page-id page-id)
-    (-> (pcb/empty-changes nil page-id)
-        (pcb/with-file-data file-data)
-        (pcb/update-shapes [(:parent-id shape)] repair-shape))))
+  ;; Add the shape to its parent's children list. `:mov-objects` adds it
+  ;; when applied, so several repairs on the same parent do not
+  ;; overwrite each other
+  (log/debug :hint "repairing shape :child-not-in-parent" :id (:id shape) :name (:name shape) :page-id page-id)
+  (log/debug :hint "  -> add children to" :parent-id (:parent-id shape))
+  (-> (pcb/empty-changes nil page-id)
+      (pcb/with-file-data file-data)
+      (pcb/change-parent (:parent-id shape) [shape] nil {:allow-altering-copies true})))
 
 (defmethod repair-error :duplicated-children
   [_ {:keys [shape page-id] :as error} file-data _]

common/src/app/common/files/validate.cljc

@@ -118,6 +118,19 @@
              {}
              objects))
 
+(defn- listed-in-parent?
+  "Check if `parent` lists `shape-id` in its `:shapes`. A `nil` parent
+  lists nothing.
+
+  Fast path: O(1) set lookup when `*children-sets*` is pre-computed for
+  the current page. Falls back to an O(k) linear scan via `some` when
+  the var is unbound (e.g. in isolated single-shape validation calls
+  outside a full page pass)."
+  [parent shape-id]
+  (if-let [cs *children-sets*]
+    (contains? (get cs (:id parent)) shape-id)
+    (some #(= shape-id %) (:shapes parent))))
+
 (defn- find-ref-shape*
   "Cached wrapper around `ctf/find-ref-shape` with `:include-deleted? true`.
   When `*ref-shape-cache*` is bound, each shape-id is resolved at most once
@@ -195,13 +208,7 @@
                     shape file page)
       (do
         (when-not (cfh/root? shape)
-          ;; Fast path: O(1) set lookup when `*children-sets*` is pre-computed
-          ;; for the current page.  Falls back to an O(k) linear scan via
-          ;; `some` when the var is unbound (e.g. in isolated single-shape
-          ;; validation calls outside a full page pass).
-          (when-not (if-let [cs *children-sets*]
-                      (contains? (get cs (:id parent)) shape-id)
-                      (some #(= shape-id %) (:shapes parent)))
+          (when-not (listed-in-parent? parent shape-id)
             (report-error :child-not-in-parent
                           (str/ffmt "Shape % not in parent's children list" shape-id)
                           shape file page)))
@@ -797,9 +804,10 @@
     (check-variant-component component file)))
 
 (defn- get-orphan-shapes
-  "Return the ids of shapes whose parent does not exist in the objects
-  map (i.e. shapes unreachable from the root traversal). The root
-  shape itself is excluded since it is always validated separately.
+  "Return the ids of shapes unreachable from the root traversal: shapes
+  whose parent does not exist in the objects map, or whose parent exists
+  but does not list them in its `:shapes`. The root shape itself is
+  excluded since it is always validated separately.
 
   Implemented with `reduce-kv` rather than a `map`/`filter` pipeline.
   The previous implementation mapped over `objects` and returned a
@@ -810,8 +818,10 @@
   [{:keys [objects] :as _page}]
   (persistent!
    (reduce-kv (fn [result id shape]
+                ;; A missing parent is `nil`, which lists nothing, so this
+                ;; also covers shapes whose parent does not exist
                 (if (and (not (cfh/root? shape))
-                         (not (contains? objects (:parent-id shape))))
+                         (not (listed-in-parent? (get objects (:parent-id shape)) id)))
                   (conj! result id)
                   result))
               (transient [])

common/test/common_tests/files/repair_test.cljc

@@ -228,3 +228,50 @@
       (t/is (nil? errors'))
       (t/is (= "Group / Subgroup" (:path comp1')))
       (t/is (= "Component" (:name comp1'))))))
+
+(t/deftest repair-child-not-in-parent
+  (t/testing "detect and repair shapes whose parent exists but does not list them"
+    (let [file    (-> (thf/sample-file :file1 :page-label :page1)
+                      (ths/add-sample-shape :frame1 :type :frame)
+                      (ths/add-sample-shape :shape1 :parent-label :frame1)
+                      (ths/add-sample-shape :shape2 :parent-label :frame1)
+                      (ths/update-shape :frame1 :shapes []))
+
+          errors  (cfv/validate-file file {})
+          changes (cfr/repair-file file {} errors)
+          file'   (thf/apply-changes file {:redo-changes changes} :validate? false)
+          errors' (cfv/validate-file file' {})
+
+          frame1' (ths/get-shape file' :frame1 :page-label :page1)]
+
+      (t/is (= #{:child-not-in-parent} (into #{} (map :code) errors)))
+      (t/is (= #{(thi/id :shape1) (thi/id :shape2)} (into #{} (map :shape-id) errors)))
+
+      (t/is (nil? errors'))
+      (t/is (= #{(thi/id :shape1) (thi/id :shape2)} (set (:shapes frame1')))))))
+
+(t/deftest repair-parent-not-found
+  (t/testing "detect and repair shapes whose parent does not exist"
+    (let [file    (-> (thf/sample-file :file1 :page-label :page1)
+                      (ths/add-sample-shape :shape1)
+                      (ths/add-sample-shape :shape2)
+                      (ths/update-shape :shape1 :parent-id (uuid/next))
+                      (ths/update-shape :shape2 :parent-id (uuid/next))
+                      (ths/update-shape-by-id uuid/zero :shapes []))
+
+          errors  (cfv/validate-file file {})
+          changes (cfr/repair-file file {} errors)
+          file'   (thf/apply-changes file {:redo-changes changes} :validate? false)
+          errors' (cfv/validate-file file' {})
+
+          shape1' (ths/get-shape file' :shape1 :page-label :page1)
+          shape2' (ths/get-shape file' :shape2 :page-label :page1)
+          root'   (ths/get-shape-by-id file' uuid/zero :page-label :page1)]
+
+      (t/is (= #{:parent-not-found} (into #{} (map :code) errors)))
+      (t/is (= #{(thi/id :shape1) (thi/id :shape2)} (into #{} (map :shape-id) errors)))
+
+      (t/is (nil? errors'))
+      (t/is (= uuid/zero (:parent-id shape1')))
+      (t/is (= uuid/zero (:parent-id shape2')))
+      (t/is (= #{(thi/id :shape1) (thi/id :shape2)} (set (:shapes root')))))))

common/test/common_tests/files_migrations_test.cljc

@@ -554,3 +554,54 @@
     (t/is (contains? (:migrations file') migration-id) "migration id persisted")
     (t/is (= "30" (:stroke-width-top applied'))
           "legacy token applied to the sides")))
+
+(t/deftest migration-0032-adds-unlisted-children-to-their-parent
+  (let [migration-id "0032-fix-children-not-in-parent"
+        page-id      (uuid/next)
+        parent-id    (uuid/next)
+        listed-id    (uuid/next)
+        unlisted1-id (uuid/next)
+        unlisted2-id (uuid/next)
+        orphan-id    (uuid/next)
+        root         (cts/setup-shape {:id uuid/zero :type :frame :shapes [parent-id orphan-id]})
+        parent       (cts/setup-shape {:id parent-id :type :frame :parent-id uuid/zero
+                                       :shapes [listed-id]})
+        child        (fn [id parent-id]
+                       (cts/setup-shape {:id id :type :rect :parent-id parent-id}))
+        data         {:pages-index
+                      {page-id
+                       {:objects {uuid/zero    root
+                                  parent-id    parent
+                                  listed-id    (child listed-id parent-id)
+                                  unlisted1-id (child unlisted1-id parent-id)
+                                  unlisted2-id (child unlisted2-id parent-id)
+                                  orphan-id    (child orphan-id (uuid/next))}}}}
+        data'        (cfm/migrate-data data migration-id)
+        objects'     (get-in data' [:pages-index page-id :objects])
+        shapes'      (get-in objects' [parent-id :shapes])]
+
+    (t/is (= listed-id (first shapes')) "already listed children keep their place")
+    (t/is (= #{listed-id unlisted1-id unlisted2-id} (set shapes'))
+          "unlisted children added to the parent")
+    (t/is (= 3 (count shapes')) "no duplicated children")
+    (t/is (= [parent-id orphan-id] (get-in objects' [uuid/zero :shapes]))
+          "root unchanged")
+    (t/is (= (get-in data [:pages-index page-id :objects orphan-id])
+             (get objects' orphan-id))
+          "shapes whose parent does not exist are left untouched")
+    (t/is (= data' (cfm/migrate-data data' migration-id))
+          "migration is idempotent")))
+
+(t/deftest migration-0032-adds-unlisted-children-in-components
+  (let [migration-id "0032-fix-children-not-in-parent"
+        component-id (uuid/next)
+        main-id      (uuid/next)
+        child-id     (uuid/next)
+        data         {:components
+                      {component-id
+                       {:objects {main-id  (cts/setup-shape {:id main-id :type :frame :shapes []})
+                                  child-id (cts/setup-shape {:id child-id :type :rect
+                                                             :parent-id main-id})}}}}
+        data'        (cfm/migrate-data data migration-id)]
+
+    (t/is (= [child-id] (get-in data' [:components component-id :objects main-id :shapes])))))

docs/technical-guide/configuration.md

@@ -665,6 +665,16 @@ In a high-availability (HA) scenario, managing the state outside of replicas is
 - Valkey: Penpot only needs one Valkey instance to function correctly. Due to the nature of the data it manages, replication isn't even essential.
 - User media storage: This should not be configured with local storage but rather with centralized storage, such as Kubernetes PVC or S3.
 
+### Draining a backend instance
+
+To restart one backend without affecting ongoing clients, take it out of the
+load balancer first. From the backend REPL, run `(app.srepl.main/set-offline)`.
+The `/readyz` endpoint then answers `503 OFFLINE`, so the load balancer stops
+sending new requests to that instance while the requests already in flight
+finish normally. Wait for the traffic to drop, restart the process, and the
+instance comes back online on its own. To undo the drain without a restart,
+run `(app.srepl.main/set-online)`. Drain one instance at a time.
+
 ## Backend
 
 This section enumerates the backend only configuration variables.

frontend/packages/mousetrap/index.js

@@ -178,6 +178,16 @@ function _addEvent(object, type, callback) {
   object.attachEvent("on" + type, callback);
 }
 
+/**
+ * true for the letter (A-Z) and main-row digit (0-9) keycodes
+ *
+ * @param {number} which
+ * @return {boolean}
+ */
+function _isLetterOrDigit(which) {
+  return (which >= 48 && which <= 57) || (which >= 65 && which <= 90);
+}
+
 /**
  * takes the event and returns the key character
  *
@@ -222,6 +232,12 @@ function _characterFromEvent(e) {
     return _KEYCODE_MAP[e.which];
   }
 
+  // keydown bindings name the key, not the glyph it types under modifiers
+  // ("fi" for Option+Shift+5, ")" for Shift+0)
+  if (_isLetterOrDigit(e.which)) {
+    return String.fromCharCode(e.which).toLowerCase();
+  }
+
   // if it is not in the special map
   if (typeof e.key === "string") {
     return e.key.toLowerCase();

frontend/playwright/ui/specs/numeric-input.spec.js

@@ -133,7 +133,7 @@ test("BUG 10001: Negative margins are allowed on the numeric input", async ({
   });
 
   await expect(verticalMarginInput).toBeVisible();
-  
+
   await verticalMarginInput.fill("-10");
   await verticalMarginInput.press("Enter");
   await expect(verticalMarginInput).toHaveValue("-10");
@@ -230,3 +230,54 @@ test("BUG 10638 - Invalid padding input on multi-selection must not persist stri
   expect(seenLayoutValues).not.toEqual([]);
   expect(badLayoutValues).toEqual([]);
 });
+
+test("BUG 12227: Numeric inputs only show the scrub cursor when they hold a single value", async ({
+  page,
+}) => {
+  const workspacePage = new WasmWorkspacePage(page);
+  await workspacePage.setupEmptyFile(page);
+  await workspacePage.mockRPC(
+    /get\-file\?/,
+    "workspace/get-file-copy-paste.json",
+  );
+  await workspacePage.mockRPC(
+    "get-file-fragment?file-id=*&fragment-id=*",
+    "workspace/get-file-copy-paste-fragment.json",
+  );
+
+  await workspacePage.goToWorkspace({
+    fileId: "870f9f10-87b5-8137-8005-934804124660",
+    pageId: "870f9f10-87b5-8137-8005-934804124661",
+  });
+
+  await page.getByTestId("layer-item").getByRole("button").first().click();
+  await workspacePage.layers.getByTestId("layer-row").nth(0).click();
+
+  const measuresSection = workspacePage.rightSidebar.getByRole("region", {
+    name: "shape-measures-section",
+  });
+  await expect(measuresSection).toBeVisible();
+
+  const widthInput = measuresSection.getByRole("textbox", {
+    name: "Width",
+    exact: true,
+  });
+  await expect(widthInput).toHaveValue("360");
+
+  // The wrapper around the input is the element that carries the cursor.
+  const widthWrapper = measuresSection
+    .getByTestId("numeric-input-wrapper")
+    .filter({ has: page.getByRole("textbox", { name: "Width", exact: true }) });
+
+  // A single committed value can be scrubbed.
+  await expect(widthWrapper).toHaveCSS("cursor", "ew-resize");
+
+  // Selecting a second shape with a different width mixes the values.
+  // The field then has no single value, so it must not look scrubbable.
+  await workspacePage.layers
+    .getByTestId("layer-row")
+    .nth(1)
+    .click({ modifiers: ["Shift"] });
+  await expect(widthInput).toHaveAttribute("placeholder", "Mixed");
+  await expect(widthWrapper).not.toHaveCSS("cursor", "ew-resize");
+});

frontend/src/app/main/data/auth.cljs

@@ -235,7 +235,7 @@
   (ptk/reify ::logged-out
     ptk/UpdateEvent
     (update [_ state]
-      (select-keys state [:route :router :session-id :history]))
+      (select-keys state [:route :router :session-id]))
 
     ptk/WatchEvent
     (watch [_ _ _]

frontend/src/app/main/data/persistence.cljs

@@ -20,6 +20,7 @@
    [app.main.errors :as errors]
    [app.main.refs :as refs]
    [app.main.repo :as rp]
+   [app.main.store :as st]
    [app.util.i18n :refer [tr]]
    [beicon.v2.core :as rx]
    [potok.v2.core :as ptk]))
@@ -38,6 +39,8 @@
 (def ^:private saving-stall-timeout-ms (* 5 60 1000))
 (def ^:private saving-check-interval-ms 30000)
 (def ^:private save-wait-timeout-ms (* 2 60 1000))
+;; Longer than the stall threshold so a hung save is reported before it is retried.
+(def ^:private save-request-timeout-ms (* 7 60 1000))
 
 (defn terminal-status?
   "True when a persistence snapshot releases waiters: a failed save, or
@@ -383,6 +386,13 @@
                 :features features}]
     ;; UI read-only mode does not invalidate already queued edits.
     (->> (update-file-request request-id params)
+         ;; Fails an unanswered request as a transient network error, so the
+         ;; retry path resends it instead of blocking the queue.
+         (rx/timeout save-request-timeout-ms
+                     (rx/throw (ex-info "The save request timed out"
+                                        {:type :network
+                                         :code :save-request-timeout
+                                         :file-id file-id})))
          (rx/take 1)
          ;; A response that carries no revision, including one that never
          ;; arrived, is treated as a failed save rather than a saved file.
@@ -552,6 +562,17 @@
           (rx/of (run-persistence-task))
           (rx/empty))))))
 
+(defn- sync-unload-guard
+  "Turns the browser's leave-page warning on while edits are unsaved:
+  buffered, queued, or retained after a failed save."
+  [buffered?]
+  (ptk/reify ::sync-unload-guard
+    ptk/EffectEvent
+    (effect [_ state _]
+      (if (or buffered? (seq (dm/get-in state [:persistence :queue])))
+        (swap! st/ongoing-tasks conj :persistence)
+        (swap! st/ongoing-tasks disj :persistence)))))
+
 (defn initialize-persistence
   []
   (ptk/reify ::initialize-persistence
@@ -560,6 +581,9 @@
       (log/debug :hint "initialize persistence")
       (let [stoper-s (rx/filter (ptk/type? ::initialize-persistence) stream)
 
+            ;; True while local commits wait in the buffer for the next flush.
+            buffered? (volatile! false)
+
             local-commits-s
             (->> stream
                  (rx/filter dch/commit?)
@@ -602,6 +626,19 @@
               (rx/map #(ptk/data-event ::persistence-notification))
               (rx/take-until stoper-s))
 
+         ;; Syncs the leave-page warning on every local commit and on every
+         ;; queue change (append after a flush, discard after a save).
+         (->> (rx/merge
+               (rx/of false)
+               (->> local-commits-s
+                    (rx/map (fn [_] (vreset! buffered? true))))
+               (->> stream
+                    (rx/filter #(or (ptk/type? ::append-commit %)
+                                    (ptk/type? ::discard-commit %)))
+                    (rx/map (fn [_] @buffered?))))
+              (rx/map sync-unload-guard)
+              (rx/take-until stoper-s))
+
          (->> local-commits-s
               (rx/debounce 200)
               (rx/map (fn [_]
@@ -614,6 +651,7 @@
          (->> local-commits-s
               (rx/take-until stoper-s)
               (rx/buffer-until notifier-s)
+              (rx/tap (fn [_] (vreset! buffered? false)))
               (rx/mapcat merge-commit)
               (rx/map append-commit)
               (rx/finalize (fn []

frontend/src/app/main/router.cljs

@@ -17,7 +17,6 @@
    [app.util.timers :as ts]
    [beicon.v2.core :as rx]
    [cuerdas.core :as str]
-   [goog.events :as e]
    [potok.v2.core :as ptk]))
 
 ;; --- Router API
@@ -26,6 +25,11 @@
 ;; (see `app.main.ui.routes/routes`). The `screen` query param carries
 ;; the route name; every other param travels as a plain query param.
 
+(def ^:private history-path-prefix
+  "The application base path. The history token is the query string
+  appended to it; the path never carries the token."
+  (:path cf/public-uri))
+
 (defn create
   [routes]
   routes)
@@ -120,9 +124,8 @@
 
     ptk/EffectEvent
     (effect [_ state _]
-      (let [router  (:router state)
-            history (:history state)
-            path    (resolve router id params)]
+      (let [router (:router state)
+            path   (resolve router id params)]
 
         (if ^boolean new-window
           (let [name   (or (::window-name options) "_blank")
@@ -130,8 +133,8 @@
             (dom/open-new-window uri name nil))
           (ts/asap
            #(if ^boolean replace
-              (bhistory/replace-token! history path)
-              (bhistory/set-token! history path))))))))
+              (bhistory/replace-token! history-path-prefix path)
+              (bhistory/set-token! history-path-prefix path))))))))
 
 (defn assign-exception
   [error]
@@ -221,26 +224,14 @@
 (defn initialize-history
   [on-change]
   (ptk/reify ::initialize-history
-    ptk/UpdateEvent
-    (update [_ state]
-      (let [history (bhistory/create (:path cf/public-uri))]
-        (bhistory/enable! history)
-        (assoc state :history history)))
-
     ptk/EffectEvent
     (effect [_ state stream]
       (let [stopper (rx/filter (ptk/type? ::initialize-history) stream)
-            history (:history state)
             router  (:router state)]
-        (ts/schedule #(on-change router (.getToken ^js history) true))
+        (ts/schedule #(on-change router (bhistory/get-token) true))
         (->> (rx/concat
               (rx/of nil nil)
-              (rx/create
-               (fn [subs]
-                 (let [key (e/listen history "navigate" (fn [o] (rx/push! subs (.-token ^js o))))]
-                   (fn []
-                     (bhistory/disable! history)
-                     (e/unlistenByKey key))))))
+              bhistory/token-changes)
              (rx/buffer 2 1)
              (rx/take-until stopper)
              (rx/subs!

frontend/src/app/main/store.cljs

@@ -84,6 +84,7 @@
   (let [buffer  (atom [])
         omitset #{:potok.v2.core/undefined
                   :app.main.data.workspace.persistence/update-persistence-status
+                  :app.main.data.persistence/sync-unload-guard
                   :app.main.data.websocket/send-message
                   :app.main.data.workspace.notifications/handle-pointer-send
                   :app.main.router/assign-exception}]
@@ -145,6 +146,8 @@
 
 (add-watch ongoing-tasks ::ongoing-tasks
            (fn [_ _ _ events]
-             (if (empty? events)
-               (obj/set! js/window "onbeforeunload" nil)
-               (obj/set! js/window "onbeforeunload" (constantly false)))))
+             ;; No `window` outside the browser.
+             (when (exists? js/window)
+               (if (empty? events)
+                 (obj/set! js/window "onbeforeunload" nil)
+                 (obj/set! js/window "onbeforeunload" (constantly false))))))

frontend/src/app/main/ui.cljs

@@ -6,6 +6,7 @@
 
 (ns app.main.ui
   (:require
+   [app.common.exceptions :as ex]
    [app.common.uuid :as uuid]
    [app.config :as cf]
    [app.main.data.nitrate :as dnt]
@@ -53,10 +54,14 @@
    ::mf/private true}
   [{:keys [team-id children]}]
   (mf/with-effect [team-id]
-    (when (uuid? team-id)
-      (st/emit! (dtm/initialize-team team-id))
-      (fn []
-        (st/emit! (dtm/finalize-team team-id)))))
+    (if (uuid? team-id)
+      (do
+        (st/emit! (dtm/initialize-team team-id))
+        (fn []
+          (st/emit! (dtm/finalize-team team-id))))
+      (ex/raise :type :not-found
+                :code :invalid-team-id
+                :hint "provided team-id is invalid or nil")))
 
   (if-not (uuid? team-id)
     nil

frontend/src/app/main/ui/auth/common.scss

@@ -132,6 +132,10 @@
   gap: var(--sp-xxl);
 }
 
+.notification-text {
+  color: var(--color-foreground-secondary);
+}
+
 .notification-email {
   @include use-typography("title-medium");
 

frontend/src/app/main/ui/dashboard.cljs

@@ -8,6 +8,7 @@
   (:require-macros [app.main.style :as stl])
   (:require
    [app.common.data.macros :as dm]
+   [app.common.exceptions :as ex]
    [app.config :as cf]
    [app.main.data.dashboard :as dd]
    [app.main.data.dashboard.shortcuts :as sc]

frontend/src/app/main/ui/ds/controls/numeric_input.cljs

@@ -245,6 +245,10 @@
         is-token-applied? (and (some? token-applied-name)
                                (not= :multiple token-applied-name))
 
+        scrubbable?     (and (some? value)
+                             (not disabled)
+                             (not is-token-applied?))
+
         focused-id*     (mf/use-state nil)
         focused-id      (deref focused-id*)
 
@@ -572,24 +576,22 @@
 
         on-scrub-pointer-down
         (mf/use-fn
-         (mf/deps disabled is-open is-multiple? ref min max nillable default is-token-applied?)
+         (mf/deps is-open ref min max nillable default scrubbable?)
          (fn [event]
-           (when-not (or disabled is-open is-multiple?  is-token-applied?)
-             (let [has-token (some? (deref token-applied-name*))]
-               (when-not has-token
-                 (let [client-x  (.-clientX event)
-                       parsed    (parse-value (str/trim (mf/ref-val raw-value*)) (mf/ref-val last-value*) min max nillable)
-                       start-val (or parsed default 0)]
-                   (mf/set-ref-val! drag-state* :maybe-dragging)
-                   (mf/set-ref-val! drag-start-x* client-x)
-                   (mf/set-ref-val! drag-start-val* start-val)
-                   (dom/capture-pointer event)))))))
+           (when (and (not is-open) scrubbable?)
+             (let [client-x  (.-clientX event)
+                   parsed    (parse-value (str/trim (mf/ref-val raw-value*)) (mf/ref-val last-value*) min max nillable)
+                   start-val (or parsed default 0)]
+               (mf/set-ref-val! drag-state* :maybe-dragging)
+               (mf/set-ref-val! drag-start-x* client-x)
+               (mf/set-ref-val! drag-start-val* start-val)
+               (dom/capture-pointer event)))))
 
         on-scrub-pointer-move
         (mf/use-fn
-         (mf/deps apply-value update-input step min max on-change-start is-token-applied?)
+         (mf/deps apply-value update-input step min max on-change-start scrubbable?)
          (fn [event]
-           (when-not is-token-applied?
+           (when scrubbable?
              (let [state (mf/ref-val drag-state*)]
                (when (or (= state :maybe-dragging) (= state :dragging))
                  (let [client-x (.-clientX event)
@@ -857,9 +859,9 @@
     (mf/with-effect [handle-unmount] handle-unmount)
 
     [:div {:class [class (stl/css-case :input-wrapper true
-                                       :resizable (and (not is-token-applied?)
-                                                       (not disabled)))]
+                                       :scrubbable scrubbable?)]
            :ref wrapper-ref
+           :data-testid "numeric-input-wrapper"
            :on-pointer-down on-scrub-pointer-down
            :on-pointer-move on-scrub-pointer-move
            :on-pointer-up on-scrub-pointer-up

frontend/src/app/main/ui/ds/controls/numeric_input.scss

@@ -22,7 +22,7 @@
   inline-size: 100%;
   position: relative;
 
-  &.resizable {
+  &.scrubbable {
     cursor: ew-resize;
   }
 

frontend/src/app/main/ui/error_boundary.cljs

@@ -15,9 +15,40 @@
    [goog.functions :as gfn]
    [rumext.v2 :as mf]))
 
+(defn reset-keys
+  "The `resetKeys` prop for the boundary: the current screen name, or nil
+  before the first route resolves. It never has more than one entry:
+  every screen change is a new entry.
+
+  A navigation is a fresh attempt at rendering, so a change of screen
+  clears a caught error on its own. Without that, the error page stays
+  on screen after the URL changes, because the boundary keeps its error
+  in internal React state that only `reset-error-boundary` clears, and
+  every exit from the error page (the logo, the dialogs, the feedback
+  link) only navigates.
+
+  It is a real JS array, never a ClojureScript vector:
+  `react-error-boundary` compares `resetKeys` with `.length` and
+  `.some`, which a `PersistentVector` does not have, so its
+  `componentDidUpdate` then throws `some is not a function`.
+
+  It holds the screen name as a *string*, not the whole route, not the
+  URL and not the keyword. The library compares entries with
+  `Object.is`, which compares strings by value but compares objects by
+  identity, and ClojureScript does not intern keywords: two equal
+  keywords are two objects, so `Object.is` on a keyword is always
+  false. A keyword here would therefore read as a new key on every
+  route rebuilt, and the boundary would reset on a param change inside
+  the same screen — replaying the screen that just crashed. A route map
+  has the same problem and would reset on every render."
+  [route]
+  #js [(some-> (get-in route [:data :name]) name)])
+
 (mf/defc error-boundary*
   [{:keys [fallback children]}]
-  (let [fallback-wrapper
+  (let [route (mf/deref refs/route)
+
+        fallback-wrapper
         (mf/with-memo [fallback]
           (mf/fnc fallback-wrapper*
             [{:keys [error reset-error-boundary]}]
@@ -63,5 +94,6 @@
 
     [:> reb/ErrorBoundary
      {:FallbackComponent fallback-wrapper
-      :onError on-error}
+      :onError on-error
+      :resetKeys (reset-keys route)}
      children]))

frontend/src/app/main/ui/shortcuts.cljs

@@ -53,8 +53,9 @@
 ;; aren't in that map. Recording punctuation from `code` therefore matches
 ;; what Mousetrap triggers regardless of layout (e.g. the key next to Right
 ;; Shift on a US layout is always "Period", whatever glyph it types on a
-;; given ISO layout). Letters/digits must stay glyph-based to match
-;; Mousetrap's own resolution for them.
+;; given ISO layout). With modifiers, letters and digits come from keyCode
+;; like Mousetrap's keydown match (see `letter-or-digit`); otherwise from the
+;; glyph, like its keypress match.
 (def ^:private code-name-map
   {"Minus"        "-"
    "Equal"        "="
@@ -76,12 +77,24 @@
     (or (.getBrowserEvent event) event)
     event))
 
+(defn- letter-or-digit
+  "Letter or digit named by keyCode when a modifier is held, ignoring the glyph
+  it makes the key type (Option+Shift+5 types \"fi\" on macOS)."
+  [^js event]
+  (let [key-code (.-keyCode event)]
+    (when (and (or (.-ctrlKey event) (.-metaKey event)
+                   (.-altKey event) (.-shiftKey event))
+               (or (<= 48 key-code 57)
+                   (<= 65 key-code 90)))
+      (.toLowerCase (js/String.fromCharCode key-code)))))
+
 (defn- normalize-key
   [^js event]
   (let [key  (.-key event)]
     (when (and key (not (contains? modifier-keys key)))
       (or (get key-name-map key)
           (get code-name-map (.-code (event->native event)))
+          (letter-or-digit event)
           (some-> key .toLowerCase)))))
 
 (defn- event->modifier-parts

frontend/src/app/main/ui/static.cljs

@@ -34,7 +34,6 @@
    [app.util.timers :as tm]
    [app.util.webapi :as wapi]
    [beicon.v2.core :as rx]
-   [cuerdas.core :as str]
    [rumext.v2 :as mf]))
 
 ;; FIXME: this is a workaround until we export this class on beicon library
@@ -613,12 +612,12 @@
   [{:keys [data route] :as props}]
 
   (let [type        (:type data)
-        path        (:path route)
         params      (:query-params route)
 
-        workspace?  (str/includes? path "workspace")
-        dashboard?  (str/includes? path "dashboard")
-        view?       (str/includes? path "view")
+        screen      (get params :screen)
+        workspace?  (= screen "workspace")
+        dashboard?  (= screen "dashboard")
+        view?       (= screen "view")
 
         ;; We store the request access info int this state
         info*       (mf/use-state nil)

frontend/src/app/main/ui/viewer.cljs

@@ -644,5 +644,13 @@
 
 (mf/defc viewer-page*
   {::mf/lazy-load true}
-  [props]
-  [:> viewer* props])
+  [{:keys [file-id] :as props}]
+
+  (mf/with-effect [file-id]
+    (when-not (uuid? file-id)
+      (ex/raise :type :not-found
+                :code :missing-file-id
+                :hint "provided file-id is invalid uuid or nil")))
+
+  (when (uuid? file-id)
+    [:> viewer* props]))

frontend/src/app/util/browser_history.cljs

@@ -0,0 +1,82 @@
+;; 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 app.util.browser-history
+  "Query-string browser history.
+
+  The history token is the query string (`?screen=<name>&params`) and the
+  path always stays the application base, so the URL of a token is just
+  the application base followed by the token.
+
+  Replaces `goog.history.Html5History`, which is a fragment (hash)
+  router. Once fragment navigation was dropped, its token, URL and
+  popstate logic reduced to `location.search` plus
+  `pushState`/`replaceState`, while it kept a `hashchange` listener,
+  gated popstate on a fragment that was then always `null`, and
+  asserted on `history.pushState` in its constructor, which made it
+  unusable outside a browser and therefore untestable."
+  (:require
+   [app.common.data.macros :as dm]
+   [app.util.globals :as globals]
+   [beicon.v2.core :as rx]))
+
+(def ^:dynamic *browser*
+  "The browser handles this namespace needs. Bound in tests, so they can
+  drive a fake History API and assert on the URLs written."
+  {:location globals/location
+   :history  (.-history globals/window)})
+
+(defn get-token
+  "The current history token: the query string, `\"\"` when the URL
+  carries none."
+  []
+  (or (.-search ^js (:location *browser*)) ""))
+
+(defn url
+  "The URL of `token` under `path-prefix`, the application base path.
+  The path never carries the token; only the query string does."
+  [path-prefix token]
+  (dm/str path-prefix token))
+
+(def token-changes
+  "Emits the new token on every history change.
+
+  `pushState` and `replaceState` never fire `popstate`, so this
+  namespace reports its own writes here too. Subscribers cannot tell the
+  two apart, and do not need to."
+  (rx/subject))
+
+(defn- report!
+  [token]
+  (rx/push! token-changes token))
+
+(defn set-token!
+  "Set `token` as a new history entry and report it.
+
+  Does nothing when `token` already is the current one: navigating to
+  the screen you are on must not grow the history stack, and there is
+  nothing new for a subscriber to re-read from the URL."
+  [path-prefix token]
+  (when-not (= token (get-token))
+    (.pushState ^js (:history *browser*) nil "" (url path-prefix token))
+    (report! token)))
+
+(defn replace-token!
+  "Replace the current history entry with `token` and report it.
+
+  Unlike [[set-token!]], this always writes and always reports. A replace
+  is how the app corrects the URL in place — legacy `#/…` translation, a
+  cleaned share link — and that correction has to reach the router even
+  when the token did not change."
+  [path-prefix token]
+  (.replaceState ^js (:history *browser*) nil "" (url path-prefix token))
+  (report! token))
+
+;; Back/forward. A `popstate` event carries no token, so re-read it from
+;; the URL. Installed once: the application has a single history.
+(rx/sub! (->> (rx/from-event globals/window "popstate")
+              (rx/map (fn [_] (get-token))))
+         token-changes)

frontend/src/app/util/browser_history.js

@@ -1,52 +0,0 @@
-/**
- * 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
- */
-
-"use strict";
-
-goog.provide("app.util.browser_history");
-goog.require("goog.history.Html5History");
-
-goog.scope(function() {
-  const self = app.util.browser_history;
-  const Html5History = goog.history.Html5History;
-
-  class TokenTransformer {
-    // Query-string routing: the history token is the query string
-    // ("?screen=...&..."), the path always stays the application base.
-    retrieveToken(pathPrefix, location) {
-      return location.search;
-    }
-
-    createUrl(token, pathPrefix, location) {
-      return pathPrefix + token;
-    }
-  }
-
-  self.create = function(pathPrefix) {
-    const instance = new Html5History(null, new TokenTransformer());
-    instance.setUseFragment(false);
-    instance.setPathPrefix(pathPrefix);
-    return instance;
-  };
-
-  self.enable_BANG_ = function(instance) {
-    instance.setEnabled(true);
-  };
-
-  self.disable_BANG_ = function(instance) {
-    instance.setEnabled(false);
-  };
-
-  self.set_token_BANG_ = function(instance, token) {
-    instance?.setToken(token);
-  }
-
-  self.replace_token_BANG_ = function(instance, token) {
-    instance?.replaceToken(token);
-  }
-});

frontend/src/app/util/globals.js

@@ -74,6 +74,16 @@ goog.scope(function () {
         mediaObj.onchange = null;
         return mediaObj;
       };
+      // The History API. `app.util.browser-history` writes the router
+      // through `history.pushState`/`replaceState`, so the mock only has
+      // to accept the calls; nothing reads the resulting URL back.
+      mockWindow.history = {
+        pushState() {},
+        replaceState() {},
+        back() {},
+        forward() {},
+        go() {},
+      };
       return mockWindow;
     }
   })();

frontend/test/frontend_tests/browser_history_test.cljs

@@ -0,0 +1,105 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) KALEIDOS SUBSIDIARY SL
+
+(ns frontend-tests.browser-history-test
+  (:require
+   [app.util.browser-history :as bh]
+   [beicon.v2.core :as rx]
+   [cljs.test :as t :include-macros true]))
+
+(defn- fake-browser
+  "A browser handle map whose `location.search` is `search`, and a
+  `history` that records every write and keeps `search` in sync. The
+  returned atom holds `{:calls [...] :search \"...\"}` so a test can
+  assert on both the write and the resulting token."
+  [search]
+  (let [state (atom {:search search :calls []})]
+    [state
+     {:location #js {:search search}
+      :history  #js {:pushState    (fn [_ _ url]
+                                     (swap! state assoc :search (subs url 1))
+                                     (swap! state update :calls conj [:push url]))
+                     :replaceState (fn [_ _ url]
+                                     (swap! state assoc :search (subs url 1))
+                                     (swap! state update :calls conj [:replace url]))}}]))
+
+(defn- tokens-reported
+  "Runs `f` and returns the tokens it reported on `token-changes`, in
+  order. That subject is a module-level stream shared with the app, so
+  the subscription is dropped again once the collected sequence is
+  realised. Note `rx/subs!` takes the callbacks before the observable."
+  [f]
+  (let [reported (atom [])
+        sub      (rx/subs! #(swap! reported conj %) bh/token-changes)]
+    (try
+      (f)
+      (finally
+        (rx/dispose! sub)))
+    @reported))
+
+(t/deftest get-token-reads-the-current-query-string
+  (let [[_state handles] (fake-browser "?screen=workspace")]
+    (binding [bh/*browser* handles]
+      (t/is (= "?screen=workspace" (bh/get-token))))))
+
+(t/deftest get-token-is-empty-when-the-url-has-no-query
+  ;; `location.search` is `""`, never nil, on a URL with no query.
+  (let [[_state handles] (fake-browser "")]
+    (binding [bh/*browser* handles]
+      (t/is (= "" (bh/get-token))))))
+
+(t/deftest url-appends-the-token-to-the-base-path
+  ;; The path stays the application base; only the query carries the token.
+  (t/is (= "/?screen=workspace&team-id=t1"
+           (bh/url "/" "?screen=workspace&team-id=t1")))
+  (t/is (= "/design/?screen=viewer" (bh/url "/design/" "?screen=viewer")))
+  (t/is (= "/" (bh/url "/" ""))))
+
+(t/deftest set-token-pushes-a-new-entry-and-reports-it
+  (let [[state handles] (fake-browser "?screen=dashboard-recent")
+        reported        (tokens-reported
+                         #(binding [bh/*browser* handles]
+                            (bh/set-token! "/"
+                                           "?screen=workspace&team-id=t1")))]
+    (t/is (= [[:push "/?screen=workspace&team-id=t1"]] (:calls @state)))
+    (t/is (= ["?screen=workspace&team-id=t1"] reported))))
+
+(t/deftest set-token-keeps-the-path-on-the-base
+  (let [[state handles] (fake-browser "")]
+    (binding [bh/*browser* handles]
+      (bh/set-token! "/design/" "?screen=viewer"))
+    (let [[[_op written-url]] (:calls @state)]
+      (t/is (= "/design/?screen=viewer" written-url)))))
+
+(t/deftest set-token-does-nothing-when-the-token-already-is-current
+  ;; Navigating to the screen you are on must not grow the history stack,
+  ;; so neither the URL nor the subscribers see a change.
+  (let [[state handles] (fake-browser "?screen=dashboard-recent")
+        reported        (tokens-reported
+                         #(binding [bh/*browser* handles]
+                            (bh/set-token! "/" "?screen=dashboard-recent")))]
+    (t/is (= [] (:calls @state)))
+    (t/is (= [] reported))))
+
+(t/deftest replace-token-always-writes-and-reports-on-a-new-token
+  (let [[state handles] (fake-browser "?screen=dashboard-recent")
+        reported        (tokens-reported
+                         #(binding [bh/*browser* handles]
+                            (bh/replace-token! "/" "?screen=auth-login")))]
+    (t/is (= [[:replace "/?screen=auth-login"]] (:calls @state)))
+    (t/is (= ["?screen=auth-login"] reported))))
+
+(t/deftest replace-token-also-writes-and-reports-the-current-token
+  ;; Replacing corrects the URL in place — legacy `#/…` translation, a
+  ;; cleaned share link — so it has to reach the router even when the
+  ;; token did not change. That is the deliberate difference against
+  ;; `set-token!`.
+  (let [[state handles] (fake-browser "?screen=dashboard-recent")
+        reported        (tokens-reported
+                         #(binding [bh/*browser* handles]
+                            (bh/replace-token! "/" "?screen=dashboard-recent")))]
+    (t/is (= [[:replace "/?screen=dashboard-recent"]] (:calls @state)))
+    (t/is (= ["?screen=dashboard-recent"] reported))))

frontend/test/frontend_tests/data/persistence_retry_test.cljs

@@ -44,8 +44,9 @@
                    :undo-changes []}))
 
 (defn- with-persistence
-  "Async fixture for the persistence tests: mocks the transport and flash, and
-  runs `f` with persistence initialized.
+  "Async fixture for the persistence tests: mocks the transport, flash and
+  the leave-page task set (`:tasks`), and runs `f` with persistence
+  initialized.
 
   Evaluates to a promise resolving once `f` settles and teardown completes;
   `await` it from an `^:async` test.
@@ -60,22 +61,24 @@
         response (rx/subject)
         failures (atom [])
         requests (atom [])
+        tasks    (atom #{})
         store    (ptk/store {:state {:current-file-id file-id
                                      :permissions {:can-edit true}
                                      :files {file-id {:id file-id :revn 0}}}
                              :on-error #(t/is false (str %))})]
     (mock/with-mocks*
-      {rp/cmd!      (mock/stub (fn [cmd params]
-                                 (swap! requests conj [cmd params])
-                                 (if respond
-                                   (respond cmd params)
-                                   (->> response (rx/take 1) (rx/observe-on :async)))))
-       errors/flash (fn [& {:keys [cause]}]
-                      (swap! failures conj cause))}
+      {rp/cmd!          (mock/stub (fn [cmd params]
+                                     (swap! requests conj [cmd params])
+                                     (if respond
+                                       (respond cmd params)
+                                       (->> response (rx/take 1) (rx/observe-on :async)))))
+       errors/flash     (fn [& {:keys [cause]}]
+                          (swap! failures conj cause))
+       st/ongoing-tasks tasks}
       (try
         (ptk/emit! store (dps/initialize-persistence))
         (await (f {:file-id file-id :response response :failures failures
-                   :requests requests :store store}))
+                   :requests requests :store store :tasks tasks}))
         (finally
           (rx/dispose! store)
           (rx/end! response))))))
@@ -455,7 +458,8 @@
                                  (swap! causes conj cause)
                                  "report")
         st/emit!               (mock/stub (fn [& emitted] (swap! events into emitted)))
-        rt/get-current-href    (constantly "https://penpot.example.com/#/workspace")}
+        rt/get-current-href    (constantly "https://penpot.example.com/#/workspace")
+        st/ongoing-tasks       (atom #{})}
        (try
          (ptk/emit! store (dps/initialize-persistence))
          ;; Phase 1 — the first stall reports once.
@@ -485,3 +489,33 @@
            (rx/dispose! store)
            (rx/end! ticks)
            (rx/end! response)))))))
+
+;; Scenario: the first send never answers. The request timeout fails it as
+;; a transient error, and the retry resends the same commit and saves. The
+;; timeout is shortened by wrapping the real operator. Proves: a hung save
+;; does not block the queue.
+(t/deftest ^:async hung-save-request-times-out-and-retries
+  (let [calls    (atom 0)
+        timeouts (atom [])
+        timeout  rx/timeout]
+    (await
+     (with-persistence
+       (^:async fn [{:keys [file-id requests store]}]
+         (await
+          (mock/with-mocks*
+            {rx/timer   (mock/stub (fn [_] (rx/of :tick)))
+             rx/timeout (mock/stub (fn [ms with ob]
+                                     (swap! timeouts conj ms)
+                                     (timeout 0 with ob)))}
+            (ptk/emit! store (local-commit file-id) ::dps/force-persist)
+            (await (async/wait-for #(and (= :saved (get-in @store [:persistence :status]))
+                                         (empty? (get-in @store [:persistence :queue])))
+                                   "the retry saves the file"))
+            (t/is (= 2 (count @requests)) "hung send plus one retry")
+            (t/is (apply = (map (comp :commit-id second) @requests))
+                  "both sends carry the same commit id")
+            (t/is (= [420000 420000] @timeouts) "every send gets the 7 minute timeout"))))
+       (fn [_ _]
+         (if (= 1 (swap! calls inc))
+           (rx/subject)
+           (rx/of {:revn 1})))))))

frontend/test/frontend_tests/data/persistence_test.cljs

@@ -88,10 +88,11 @@
                              :on-error #(swap! errors conj %)})]
 
     (mock/with-mocks*
-      {rp/cmd! (mock/stub (fn [cmd params]
-                            (let [req (->> response (rx/take 1) (rx/observe-on :async))]
-                              (swap! requests conj {:cmd cmd :params params :req req})
-                              req)))}
+      {rp/cmd!          (mock/stub (fn [cmd params]
+                                     (let [req (->> response (rx/take 1) (rx/observe-on :async))]
+                                       (swap! requests conj {:cmd cmd :params params :req req})
+                                       req)))
+       st/ongoing-tasks (atom #{})}
       (try
         (await (run-read-only-phases store response requests file-id read-only-event errors))
         (finally
@@ -193,7 +194,8 @@
                                 (let [m (apply hash-map params)]
                                   (swap! reports conj m)
                                   (when (fn? (:report m))
-                                    ((:report m)))))}
+                                    ((:report m)))))
+       st/ongoing-tasks       (atom #{})}
       (try
         (ptk/emit! store (dps/initialize-persistence))
         (await (f {:clock clock :ticks ticks :response response :requests requests
@@ -359,7 +361,8 @@
                           (let [subscription (.subscribe ticks subscriber)]
                             (fn []
                               (rx/dispose! subscription)
-                              (swap! active-timers dec)))))))}
+                              (swap! active-timers dec)))))))
+        st/ongoing-tasks (atom #{})}
        (try
          (ptk/emit! store (dps/initialize-persistence))
          (t/is (= 1 @active-timers))
@@ -434,8 +437,9 @@
 ;; assert block is preceded by `wait-for` on its leading signal (or a bare
 ;; `settle` tick when it asserts only absence).
 (defn- with-persistence
-  "Async fixture for the persistence tests: mocks the transport and flash, and
-  runs `f` with persistence initialized.
+  "Async fixture for the persistence tests: mocks the transport, flash and
+  the leave-page task set (`:tasks`), and runs `f` with persistence
+  initialized.
 
   Evaluates to a promise resolving once `f` settles and teardown completes;
   `await` it from an `^:async` test.
@@ -450,22 +454,24 @@
         response (rx/subject)
         failures (atom [])
         requests (atom [])
+        tasks    (atom #{})
         store    (ptk/store {:state {:current-file-id file-id
                                      :permissions {:can-edit true}
                                      :files {file-id {:id file-id :revn 0}}}
                              :on-error #(t/is false (str %))})]
     (mock/with-mocks*
-      {rp/cmd!      (mock/stub (fn [cmd params]
-                                 (swap! requests conj [cmd params])
-                                 (if respond
-                                   (respond cmd params)
-                                   (->> response (rx/take 1) (rx/observe-on :async)))))
-       errors/flash (fn [& {:keys [cause]}]
-                      (swap! failures conj cause))}
+      {rp/cmd!          (mock/stub (fn [cmd params]
+                                     (swap! requests conj [cmd params])
+                                     (if respond
+                                       (respond cmd params)
+                                       (->> response (rx/take 1) (rx/observe-on :async)))))
+       errors/flash     (fn [& {:keys [cause]}]
+                          (swap! failures conj cause))
+       st/ongoing-tasks tasks}
       (try
         (ptk/emit! store (dps/initialize-persistence))
         (await (f {:file-id file-id :response response :failures failures
-                   :requests requests :store store}))
+                   :requests requests :store store :tasks tasks}))
         (finally
           (rx/dispose! store)
           (rx/end! response))))))
@@ -791,3 +797,60 @@
        (t/is (= :saved (get-in @store [:persistence :status])))
        (t/is (empty? (get-in @store [:persistence :queue]))))
      (fn [_ _] (rx/of {:revn 1})))))
+
+;; Leave-page guard tests.
+
+;; Scenario: an edit is buffered, then sent, then saved. The leave-page
+;; guard turns on with the buffered edit, stays on while the save is in
+;; flight, and turns off once it lands. Proves: unsaved edits always keep
+;; the browser's leave-page warning on.
+(t/deftest ^:async unsaved-edits-keep-the-leave-page-guard
+  (await
+   (with-persistence
+     (^:async fn [{:keys [file-id response requests store tasks]}]
+       (ptk/emit! store (local-commit file-id))
+       (await (async/wait-for #(contains? @tasks :persistence)
+                              "a buffered edit turns the guard on"))
+       (ptk/emit! store ::dps/force-persist)
+       (await (async/wait-for #(seq @requests) "the edit is sent"))
+       (t/is (contains? @tasks :persistence) "the guard stays on while the save is in flight")
+       (rx/push! response {:revn 1})
+       (await (async/wait-for #(not (contains? @tasks :persistence))
+                              "the save turns the guard off"))
+       (t/is (= :saved (get-in @store [:persistence :status])))))))
+
+;; Scenario: a second edit arrives while the first is being saved, and the
+;; first save lands while the second edit is still in the buffer. The queue
+;; is empty at that point, yet the guard stays on until the second edit is
+;; saved. Proves: edits waiting in the buffer keep the leave-page warning on.
+(t/deftest ^:async edits-buffered-during-a-save-keep-the-leave-page-guard
+  (await
+   (with-persistence
+     (^:async fn [{:keys [file-id response requests store tasks]}]
+       (ptk/emit! store (local-commit file-id) ::dps/force-persist)
+       (await (async/wait-for #(= 1 (count @requests)) "the first edit is sent"))
+       (ptk/emit! store (local-commit file-id))
+       (rx/push! response {:revn 1})
+       (await (async/wait-for #(empty? (get-in @store [:persistence :queue]))
+                              "the first save lands"))
+       (await (async/settle))
+       (t/is (contains? @tasks :persistence) "the buffered edit keeps the guard on")
+       (ptk/emit! store ::dps/force-persist)
+       (await (async/wait-for #(= 2 (count @requests)) "the buffered edit is sent"))
+       (rx/push! response {:revn 2})
+       (await (async/wait-for #(not (contains? @tasks :persistence))
+                              "the second save turns the guard off"))
+       (t/is (empty? (get-in @store [:persistence :queue])))))))
+
+;; Scenario: the save fails terminally. The edit stays queued, and so does
+;; the guard. Proves: retained edits are not dropped silently on leave.
+(t/deftest ^:async failed-save-keeps-the-leave-page-guard
+  (await
+   (with-persistence
+     (^:async fn [{:keys [file-id store tasks]}]
+       (ptk/emit! store (local-commit file-id) ::dps/force-persist)
+       (await (async/wait-for #(= :error (get-in @store [:persistence :status]))
+                              "the save fails"))
+       (t/is (= 1 (count (get-in @store [:persistence :queue]))))
+       (t/is (contains? @tasks :persistence) "the guard stays on for retained edits"))
+     (fn [_ _] (rx/throw (ex-info "invalid" {:type :validation}))))))

frontend/test/frontend_tests/runner.cljs

@@ -5,6 +5,7 @@
    [clojure.string :as str]
    [clojure.tools.cli :refer [parse-opts]]
    [frontend-tests.basic-shapes-test]
+   [frontend-tests.browser-history-test]
    [frontend-tests.code-gen-style-test]
    [frontend-tests.composable-tests.comp.sync-test]
    [frontend-tests.copy-as-svg-test]
@@ -116,6 +117,7 @@
    [frontend-tests.ui.comments-position-modifier-test]
    [frontend-tests.ui.drawarea-test]
    [frontend-tests.ui.ds-controls-numeric-input-test]
+   [frontend-tests.ui.error-boundary-test]
    [frontend-tests.ui.gradient-handlers-test]
    [frontend-tests.ui.history-test]
    [frontend-tests.ui.inspect-geometry-test]
@@ -130,6 +132,7 @@
    [frontend-tests.ui.settings-shortcuts-test]
    [frontend-tests.ui.shape-filters-test]
    [frontend-tests.ui.shortcuts-labels-test]
+   [frontend-tests.ui.shortcuts-recording-test]
    [frontend-tests.ui.sidebar-scroll-test]
    [frontend-tests.ui.stroke-menu-test]
    [frontend-tests.ui.text-attrs-multiple-test]
@@ -247,6 +250,7 @@
    'frontend-tests.render-wasm.text-editor-content-range-test
    'frontend-tests.render-wasm.text-paste-test
    'frontend-tests.render-wasm.webgl-test
+   'frontend-tests.browser-history-test
    'frontend-tests.router-test
    'frontend-tests.svg-fills-test
    'frontend-tests.svg-filters-test
@@ -269,6 +273,7 @@
    'frontend-tests.ui.comments-position-modifier-test
    'frontend-tests.ui.drawarea-test
    'frontend-tests.ui.ds-controls-numeric-input-test
+   'frontend-tests.ui.error-boundary-test
    'frontend-tests.ui.gradient-handlers-test
    'frontend-tests.ui.history-test
    'frontend-tests.ui.inspect-geometry-test
@@ -285,6 +290,7 @@
    'frontend-tests.ui.settings-shortcuts-test
    'frontend-tests.ui.shape-filters-test
    'frontend-tests.ui.shortcuts-labels-test
+   'frontend-tests.ui.shortcuts-recording-test
    'frontend-tests.ui.sidebar-scroll-test
    'frontend-tests.ui.stroke-menu-test
    'frontend-tests.ui.text-attrs-multiple-test

frontend/test/frontend_tests/ui/error_boundary_test.cljs

@@ -0,0 +1,55 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) KALEIDOS SUBSIDIARY SL
+
+(ns frontend-tests.ui.error-boundary-test
+  (:require
+   [app.main.ui.error-boundary :as eb]
+   [cljs.test :as t :include-macros true]))
+
+(defn- match
+  "A route match like the one `refs/route` holds, with `screen` as the
+  screen name and `params` as the query map. `rt/match` builds a fresh
+  keyword for the screen on every navigation, so the caller gets a
+  different object each time — like the real one."
+  [screen params]
+  {:data {:name (keyword (name screen))}
+   :params {:path {} :query params}
+   :query-params params})
+
+(t/deftest reset-keys-is-a-real-js-array
+  ;; `react-error-boundary` reads `resetKeys` with `.length` and `.some`
+  ;; inside `componentDidUpdate`. A ClojureScript vector has neither, so
+  ;; passing one throws `some is not a function` the first time the
+  ;; boundary is in error state and the route changes.
+  (t/is (array? (eb/reset-keys nil)))
+  (t/is (array? (eb/reset-keys (match :workspace {})))))
+
+(t/deftest reset-keys-holds-the-screen-name
+  (t/is (= "workspace"
+           (aget (eb/reset-keys (match :workspace {:team-id "team-1"})) 0)))
+  ;; `app` renders `page*` only once a route exists, so the first render
+  ;; has no match yet. The boundary has to get through that and reset
+  ;; when the first screen arrives.
+  (t/is (nil? (aget (eb/reset-keys nil) 0))))
+
+(t/deftest reset-keys-ignores-params-of-the-same-screen
+  ;; A param change on the same screen is not a new screen. Replaying
+  ;; the screen that just crashed is the one thing to avoid, so the
+  ;; entries the library compares with `Object.is` must stay put when
+  ;; only params move — even though the route map, and the keyword in
+  ;; it, are fresh objects on every navigation.
+  (let [a (eb/reset-keys (match :workspace {:team-id "team-1"}))
+        b (eb/reset-keys (match :workspace {:team-id "team-2"}))]
+    (t/is (= (alength a) (alength b)))
+    (t/is (identical? (aget a 0) (aget b 0)))))
+
+(t/deftest reset-keys-changes-when-the-screen-changes
+  ;; This is what lets every exit from the error page work: each of them
+  ;; only navigates, and none of them reaches `reset-error-boundary`.
+  (let [a (eb/reset-keys (match :workspace {:team-id "team-1"}))
+        b (eb/reset-keys (match :dashboard-recent {}))]
+    (t/is (= (alength a) (alength b)))
+    (t/is (not (identical? (aget a 0) (aget b 0))))))

frontend/test/frontend_tests/ui/shortcuts_recording_test.cljs

@@ -0,0 +1,60 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) KALEIDOS SUBSIDIARY SL
+
+(ns frontend-tests.ui.shortcuts-recording-test
+  (:require
+   [app.main.ui.shortcuts :as ss]
+   [cljs.test :as t :include-macros true]))
+
+(def ^:private keyboard-event->mousetrap
+  @#'ss/keyboard-event->mousetrap)
+
+(defn- key-event
+  [props]
+  (clj->js (merge {:altKey false :shiftKey false :ctrlKey false :metaKey false}
+                  props)))
+
+(t/deftest records-alt-digit-from-key-code
+  ;; macOS Option+Shift+5 types "fi"; Mousetrap matches it as "5"
+  (t/is (= "alt+shift+5"
+           (keyboard-event->mousetrap
+            (key-event {:key "fi" :code "Digit5" :keyCode 53 :altKey true :shiftKey true})))))
+
+(t/deftest records-alt-letter-from-key-code
+  ;; macOS Option+A types "å"; Mousetrap matches it as "a"
+  (t/is (= "alt+a"
+           (keyboard-event->mousetrap
+            (key-event {:key "å" :code "KeyA" :keyCode 65 :altKey true})))))
+
+(t/deftest records-shift-digit-from-key-code
+  ;; US Shift+0 types ")"; Mousetrap matches it as "0"
+  (t/is (= "shift+0"
+           (keyboard-event->mousetrap
+            (key-event {:key ")" :code "Digit0" :keyCode 48 :shiftKey true})))))
+
+(t/deftest records-modified-letter-from-key-code
+  ;; Russian layout V types "м"; Mousetrap matches Alt+V as "v"
+  (t/is (= "alt+v"
+           (keyboard-event->mousetrap
+            (key-event {:key "м" :code "KeyV" :keyCode 86 :altKey true})))))
+
+(t/deftest records-unmodified-key-from-glyph
+  ;; without modifiers Mousetrap matches the typed glyph on keypress
+  (t/is (= "&"
+           (keyboard-event->mousetrap
+            (key-event {:key "&" :code "Digit1" :keyCode 49}))))
+  (t/is (= "ñ"
+           (keyboard-event->mousetrap
+            (key-event {:key "ñ" :code "" :keyCode 0})))))
+
+(t/deftest records-shift-punctuation-from-code
+  ;; Shift+. types ":" and Shift+= types "+" (US); the key is recorded
+  (t/is (= "shift+."
+           (keyboard-event->mousetrap
+            (key-event {:key ":" :code "Period" :keyCode 190 :shiftKey true}))))
+  (t/is (= "shift+="
+           (keyboard-event->mousetrap
+            (key-event {:key "+" :code "Equal" :keyCode 187 :shiftKey true})))))