github/penpot
1
0
Fork 0
mirror of https://github.com/penpot/penpot.git synced 2026-11-04 09:00:37 +00:00
Code Issues Packages Projects Releases Wiki Activity

Merge remote-tracking branch 'origin/develop' into alvorithm-issue-12665

Browse Source 
Resolve the collision between the counters this branch adds and the
auto-repair path that develop gained (#12524):

- main.clj declares both sets of metrics, one beside the other.
- files_update.clj keeps the METRICS helpers from this branch and the
  repair helpers from develop. `record-repair-outcome` now calls
  `record-metric!` instead of repeating the metrics lookup.
- `process-changes-and-validate` keeps develop's `fdata/with-untracked`
  and runs both validation passes inside it.

The hard referential gate now feeds the auto-repair path, so a file
damaged before the save is repaired instead of refused. The test
`referential-refusal-reports-the-gate-stage-and-code` therefore starts
from a valid file and damages it through the changes, which is the case
the gate still refuses.

AI-assisted-by: claude-opus-5-5
Signed-off-by: Álvaro Tejero Cantero <alvorithm@teje.ro>
This commit is contained in:
Álvaro Tejero Cantero 2026-11-03 12:37:58 +01:00
commit af34669f21
No known key found for this signature in database
434 changed files with 17121 additions and 4548 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
.agents/skills/local-ci/SKILL.md
View File

@ -1,6 +1,6 @@
---
name: local-ci
description: Run local CI-style checks with ./scripts/ci (lint, tests, format) per monorepo module. Use when verifying changes before declaring work done, running lint or tests locally, fixing formatting, or repairing Clojure delimiter errors.
description: Run local CI-style checks with ./scripts/ci (lint, tests, format, and on request production builds) per monorepo module. Use when verifying changes before declaring work done, running lint or tests locally, fixing formatting, repairing Clojure delimiter errors, or checking that a module still compiles.
---
# Local CI
@ -29,10 +29,12 @@ Run from the repo root:
```
Modules: `frontend` `backend` `common` `render-wasm` `exporter` `mcp`
`plugins` `library`, or `--all` for every module.
`plugins` `library` `media-processor`, or `--all` for every module.
With no task flags it runs three tasks per module, in order: **lint**,
**test**, **fmt** (format check; `--fix` formats files instead).
**test**, **fmt** (format check; `--fix` formats files instead). **build**
is opt-in: it compiles the module the way production does and is the slow
one, so it never runs unless you ask for it.
| Flag | Effect |
|------|--------|
@ -41,6 +43,7 @@ With no task flags it runs three tasks per module, in order: **lint**,
| `--lint` / `--no-lint` | Run only lint / drop lint |
| `--test` / `--no-test` | Run only tests / drop tests |
| `--fmt` / `--no-fmt` | Run only format check / drop it |
| `--build` / `--no-build` | Run only the production build / drop it |
| `--fix` | Format files instead of checking (other tasks unaffected) |
| `--paren-repair` | Fix delimiter errors in Clojure/CLJS files |
| `--fail-fast` | Stop at the first failure |
@ -72,6 +75,12 @@ log path.
# Format the module without running the test suite
./scripts/ci --fix --no-test frontend
# Check that the module still compiles (slow: minutes)
./scripts/ci --build frontend
# Compile every module (8 builds, ~4 min with warm caches)
./scripts/ci --build --all
# Broke delimiters in Clojure/CLJS files: repair first, then lint
./scripts/ci --paren-repair frontend
./scripts/ci --lint frontend
@ -89,7 +98,12 @@ log path.
- Test tasks are long-running (backend runs `clojure -M:dev:test`); give
the bash call a generous timeout (10–20 minutes) instead of letting it
time out mid-run.
- `mcp` has no lint task — it shows as skipped, not failed.
- `mcp` and `media-processor` have no lint task — they show as skipped,
not failed. `common` has no build task for the same reason.
- Build runs are the slow ones (frontend ~2 min even with warm caches;
cold caches roughly double it). Give the shell a generous timeout and
do not run two builds at once in the same checkout: `render-wasm` takes
a build lock.
- `--paren-repair` only fixes delimiters; run lint afterwards to catch
what remains. See `mem:scripts/paren-repair`.
- What to run and how to read test results: `mem:testing`.

4
.devenv/README.md
View File

@ -85,6 +85,10 @@ target instance is running and its MCP config has been generated:
# 'main', 'ws1' and similar spellings are rejected.
./manage.sh start-coding-agent claude --ws 1
./manage.sh start-coding-agent opencode --ws 2
# Run a different executable (e.g. a wrapper script) with the same MCP
# wiring. --ws and --bin may come in any order.
./manage.sh start-coding-agent claude --bin claude-alt
```
Equivalents by hand (run from inside the workspace directory):

4
.github/workflows/build-docker-devenv.yml vendored
View File

@ -38,13 +38,13 @@ jobs:
uses: docker/setup-buildx-action@f87e5991a6d7451dcb8d9637bfbc97413f497069 # v4.4.1
- name: Login to Docker Registry (push destination)
uses: docker/login-action@dbcb813823bdd20940b903addbd779551569679f # v4.6.0
uses: docker/login-action@81c6f93d4bc991e510b342a00b419b3bb4efc5c6 # v4.7.0
with:
username: ${{ secrets.PUB_DOCKER_USERNAME }}
password: ${{ secrets.PUB_DOCKER_PASSWORD }}
- name: Login to Docker Hardened Images registry (base image pull)
uses: docker/login-action@dbcb813823bdd20940b903addbd779551569679f # v4.6.0
uses: docker/login-action@81c6f93d4bc991e510b342a00b419b3bb4efc5c6 # v4.7.0
with:
registry: dhi.io
username: ${{ secrets.PUB_DOCKER_USERNAME }}

10
.github/workflows/build-docker.yml vendored
View File

@ -200,7 +200,7 @@ jobs:
ref: ${{ inputs.sha != '' && inputs.sha || inputs.gh_ref }}
- name: Login to Docker Registry
uses: docker/login-action@dbcb813823bdd20940b903addbd779551569679f # v4.6.0
uses: docker/login-action@81c6f93d4bc991e510b342a00b419b3bb4efc5c6 # v4.7.0
with:
registry: ${{ secrets.DOCKER_REGISTRY }}
username: ${{ secrets.DOCKER_USERNAME }}
@ -210,7 +210,7 @@ jobs:
# images from DockerHub for unregistered users.
# https://docs.docker.com/docker-hub/usage/
- name: Login to DockerHub Registry
uses: docker/login-action@dbcb813823bdd20940b903addbd779551569679f # v4.6.0
uses: docker/login-action@81c6f93d4bc991e510b342a00b419b3bb4efc5c6 # v4.7.0
with:
username: ${{ secrets.PUB_DOCKER_USERNAME }}
password: ${{ secrets.PUB_DOCKER_PASSWORD }}
@ -222,7 +222,7 @@ jobs:
# reuses the same PUB_DOCKER_* credentials as the DockerHub
# login above.
- name: Login to Docker Hardened Images registry (base image pull)
uses: docker/login-action@dbcb813823bdd20940b903addbd779551569679f # v4.6.0
uses: docker/login-action@81c6f93d4bc991e510b342a00b419b3bb4efc5c6 # v4.7.0
with:
registry: dhi.io
username: ${{ secrets.PUB_DOCKER_USERNAME }}
@ -301,7 +301,7 @@ jobs:
uses: docker/setup-buildx-action@f87e5991a6d7451dcb8d9637bfbc97413f497069 # v4.4.1
- name: Login to Docker Registry
uses: docker/login-action@dbcb813823bdd20940b903addbd779551569679f # v4.6.0
uses: docker/login-action@81c6f93d4bc991e510b342a00b419b3bb4efc5c6 # v4.7.0
with:
registry: ${{ secrets.DOCKER_REGISTRY }}
username: ${{ secrets.DOCKER_USERNAME }}
@ -371,7 +371,7 @@ jobs:
uses: docker/setup-buildx-action@f87e5991a6d7451dcb8d9637bfbc97413f497069 # v4.4.1
- name: Login to Docker Registry
uses: docker/login-action@dbcb813823bdd20940b903addbd779551569679f # v4.6.0
uses: docker/login-action@81c6f93d4bc991e510b342a00b419b3bb4efc5c6 # v4.7.0
with:
registry: ${{ secrets.DOCKER_REGISTRY }}
username: ${{ secrets.DOCKER_USERNAME }}

12
.github/workflows/build-renovate.yml vendored
View File

@ -114,20 +114,20 @@ jobs:
persist-credentials: false
- name: Login to Docker Registry
uses: docker/login-action@dbcb813823bdd20940b903addbd779551569679f # v4.6.0
uses: docker/login-action@81c6f93d4bc991e510b342a00b419b3bb4efc5c6 # v4.7.0
with:
registry: ${{ secrets.DOCKER_REGISTRY }}
username: ${{ secrets.DOCKER_USERNAME }}
password: ${{ secrets.DOCKER_PASSWORD }}
- name: Login to DockerHub Registry
uses: docker/login-action@dbcb813823bdd20940b903addbd779551569679f # v4.6.0
uses: docker/login-action@81c6f93d4bc991e510b342a00b419b3bb4efc5c6 # v4.7.0
with:
username: ${{ secrets.PUB_DOCKER_USERNAME }}
password: ${{ secrets.PUB_DOCKER_PASSWORD }}
- name: Login to Docker Hardened Images registry
uses: docker/login-action@dbcb813823bdd20940b903addbd779551569679f # v4.6.0
uses: docker/login-action@81c6f93d4bc991e510b342a00b419b3bb4efc5c6 # v4.7.0
with:
registry: dhi.io
username: ${{ secrets.PUB_DOCKER_USERNAME }}
@ -191,13 +191,13 @@ jobs:
persist-credentials: false
- name: Login to DockerHub Registry
uses: docker/login-action@dbcb813823bdd20940b903addbd779551569679f # v4.6.0
uses: docker/login-action@81c6f93d4bc991e510b342a00b419b3bb4efc5c6 # v4.7.0
with:
username: ${{ secrets.PUB_DOCKER_USERNAME }}
password: ${{ secrets.PUB_DOCKER_PASSWORD }}
- name: Login to Docker Hardened Images registry
uses: docker/login-action@dbcb813823bdd20940b903addbd779551569679f # v4.6.0
uses: docker/login-action@81c6f93d4bc991e510b342a00b419b3bb4efc5c6 # v4.7.0
with:
registry: dhi.io
username: ${{ secrets.PUB_DOCKER_USERNAME }}
@ -242,7 +242,7 @@ jobs:
persist-credentials: false
- name: Login to Docker Hardened Images registry
uses: docker/login-action@dbcb813823bdd20940b903addbd779551569679f # v4.6.0
uses: docker/login-action@81c6f93d4bc991e510b342a00b419b3bb4efc5c6 # v4.7.0
with:
registry: dhi.io
username: ${{ secrets.PUB_DOCKER_USERNAME }}

4
.github/workflows/plugins-deploy-api-doc.yml vendored
View File

@ -48,10 +48,10 @@ jobs:
# No dependency cache here: a deploy must not restore a cache that
# other workflows can write to.
- name: Setup pnpm + Node.js
uses: pnpm/setup@a0881977cd8ea73b1ed212236c99ca10dcc80cf4 # v3.1.1
uses: pnpm/setup@fa36a5ef7dcdefc3a7cb25655c122e00cf6e636e # v3.1.2
with:
working-directory: plugins
runtime: node@24.22.1
runtime: node@26.13.0
install: false
- name: Install deps

4
.github/workflows/plugins-deploy-styles-doc.yml vendored
View File

@ -46,10 +46,10 @@ jobs:
# No dependency cache here: a deploy must not restore a cache that
# other workflows can write to.
- name: Setup pnpm + Node.js
uses: pnpm/setup@a0881977cd8ea73b1ed212236c99ca10dcc80cf4 # v3.1.1
uses: pnpm/setup@fa36a5ef7dcdefc3a7cb25655c122e00cf6e636e # v3.1.2
with:
working-directory: plugins
runtime: node@24.22.1
runtime: node@26.13.0
install: false
- name: Install deps

2
.nvmrc
View File

@ -1 +1 @@
v24.22.1
v24.22.2

3
.serena/memories/backend/auth-permissions-product-domains.md
View File

@ -13,6 +13,9 @@
- Logout may return an OIDC provider redirect URI when the session claims include provider/session data and the provider has a logout URI.
- Invitation tokens are verified through token issuers and only accepted when the token member id/email matches the authenticated profile; otherwise login proceeds without consuming the invitation.
- When public registration is disabled, invitation-based password registration also requires a matching, non-expired `team_invitation` row; registration revalidates it under a row lock before creating the profile.
- Access tokens (`app.http.access-token`): personal tokens have JWT issuer `access-token` and DB type other than `mcp`; MCP tokens have issuer `urn:penpot:mcp-token` (`actoken/mcp-token-issuer`) and DB type `mcp`. Authentication requires issuer and type to agree, and the claim `uid` to match the row's profile; other issuers and undecryptable tokens are treated as anonymous.
- Personal tokens need flag `:access-tokens`. MCP tokens need `:mcp` or `:access-tokens`, and only on routes whose `actoken/authz` gets `::actoken/allow-mcp true` (the RPC routes); elsewhere (e.g. assets) they are anonymous.
- On RPC, an MCP token reaches only commands with `::rpc/token-type "mcp"` (`wrap-authentication` in `app.rpc`); every other command answers 403 `:token-auth-required`. A command with that metadata also rejects sessions and personal tokens. Currently only `send-mcp-feedback`. Blocking a profile invalidates sessions, not tokens, so such commands check `:is-blocked`/`:is-active` themselves.
- HTTP/session parsing details such as cookie/header precedence, JWT session token versions, and SameSite behavior are in `mem:backend/subtleties`.
## Permission model

2
.serena/memories/backend/core.md
View File

@ -32,7 +32,7 @@ Backend: JVM Clojure; Integrant; PostgreSQL; Redis/Valkey; RPC; HTTP; storage; m
RPC commands are defined with `app.util.services/defmethod` and schemas. Use `get-` prefixes for read operations. Command metadata usually includes auth, docs version, params schema, and result schema. Return plain maps/vectors or raise structured exceptions from `app.common.exceptions`.
Backend RPC command areas without focused memories include access tokens, binfile, demo, feedback, file snapshots, fonts, management, Nitrate, and webhooks beyond the notes in `mem:backend/auth-permissions-product-domains`; inspect nearby command tests and command metadata before changing them.
Backend RPC command areas without focused memories include access tokens (auth rules, incl. MCP tokens, in `mem:backend/auth-permissions-product-domains`), binfile, demo, feedback, file snapshots, fonts, management, Nitrate, and webhooks beyond the notes in `mem:backend/auth-permissions-product-domains`; inspect nearby command tests and command metadata before changing them.
## DB conventions

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

@ -18,9 +18,10 @@
- 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.
- 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. Both commands declare their limits now, so the shape cannot happen any more: the root limits are taken last and every path takes the limiters in the same order.
- `climit/wrap` takes the command's own limits before the root ones: the root limiters are appended to the sequence first and the last element of the sequence is the outermost one, so `root/global`/`root/by-profile` end up innermost. A request waiting for its own limits no longer holds the root permits of its profile, which is what kept a pile-up of heavy requests from blocking the other commands of that profile. Every acquisition goes through that wrapper, so every path takes the limiters in the same order: there is no way to enter the limiter from inside a handler, and a command that calls another command internally would take the limiters twice (the second call waits for a permit the first one holds and answers 429 when the timeout runs out). The key of a limit is a function of the params (a keyword is looked up in them, a function is applied to them, any other value is the key itself). Commands declare the by-profile limit before the global one, which makes it the outermost of the pair, and a test fails when the relation between all the limits the commands declare cannot be sorted: two commands that take the same limits in opposite order, or a ring of three, leave the paths of one profile holding them in opposite order.
- The two commands that used to enter climit from inside their handler declare their limits now, so the whole command runs inside them: the download of an external image takes a `process-image` permit, and that limit has one permit per profile, so a slow download holds the image processing of that profile for as long as it takes. It takes the global permit of that limit too (8 permits, queue 20), so eight slow downloads of eight different profiles leave the image processing of every profile waiting. The copy of the body has no timeout (the 30 s of the request covers the connection and the headers), so a server that stops sending keeps the permits until the operating system gives up. The storage write of the profile photo runs inside its limit too.
- The shipped `backend/resources/climit.edn` sets a timeout and a queue 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 queue matters because the root limits no longer bound the waiters: a command takes its own limits first, so a pile-up waits in the queue of that limit. The file and the declarations have to list the same ids: a `::climit/id` without an entry makes `wrap` log `no config found for specified queue` and run the handler with no limiter at all, and a test fails when a command declares an id the file does not list. Only key a limit by profile when the work contends on something shared (`update-file`, images, fonts, thumbnails, the profile row): a global cap on a cheap command adds a rejection path nobody needs, which is why `profile-plugin-ops` and `submit-audit-events` declare only `by-profile`. 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
@ -91,7 +92,15 @@
- File data backends are `legacy-db`, `db`, and `storage`. The storage backend keeps encoded file data in storage bucket `file-data`; the DB row stores metadata with `storage-ref-id` and nil data.
- `fdata/upsert!` touches any storage object referenced by incoming metadata before storing the new row/blob.
- Pointer-map fragments are persisted separately as type `fragment`, and only modified pointer maps are written.
- Pointer-map fragments are persisted separately as type `fragment`, and only modified pointer maps are written. A pointer keeps its id while nothing changes; content (`assoc`/`without`) and metadata (`with-meta`) changes produce a fresh id, so a fragment row is never rewritten after it is written. Re-assoc with an identical value returns the same map in array and hash maps alike, so a save keeps the fragment id of every page it does not change.
- `enable-objects-map` skips unloaded pointer pages: their fragment was already wrapped when it was written, and loading it only to wrap it again costs one page read per untouched page on every save. A page with a plain fragment is wrapped when it is first loaded or edited; a data migration that enables `fdata/objects-map` must rewrite the data itself.
- Snapshots share fragment rows with the live file (they are stored with pointers, not materialized). `file-gc` marks every fragment referenced neither by the current main file nor by an unpurged snapshot; the file is read unrealized and unchanged pages keep their ids via reattach, so a pass over an unchanged file writes no new fragments.
- A save attaches its automatic snapshot before applying pending file migrations: the snapshot keeps the pre-migration pointers, data and migration set, and restoring it leaves the next read to migrate the file. This also holds for files without the feature. The preview (`get-file-snapshot`) applies the pending migrations in memory with the live file's libraries and never persists them: the stored version keeps its data, the payload carries the snapshot's `:migrations` (an ordered set) and `fdata/objects-map` is realized for clients that do not declare it. The historical feature set is deliberately not checked against the enabled one: a version may predate a feature change. The window is narrow: the `get-file` RPC reads with `migrate?` on and its ETag hashes `available-migrations`, so a post-deploy read cannot be a 304 from the pre-deploy state and migrates before any save in the normal flow; the pre-migration snapshot only appears when the save is the first request to touch the file after the deploy (an open tab that saves without re-reading, or a non-UI writer). `create-file-snapshot` and the restore backup read with `migrate?` on, so those versions are stored already migrated.
- `:migrations` is always a `d/ordered-set`: `file-migrations/resolve-applied-migrations` builds one, `fmg/migrate` re-wraps the union after applying, and `file-snapshots/decode-snapshot` converts the `file_change` pgarray (as a plain vector, `set/difference` and `contains?` would compare indexes instead of names). A snapshot with NULL `:migrations` and an old `:version` predates the `file_change.migrations` column (SQL migration 0140): the preview regenerates the set from the stored version and applies that full chain, while `restore!` uses a fixed 67 baseline, so preview and restore can disagree for very old snapshots.
- The migration read path (`binfile.common/migrate-file`) captures `fdata/original-pointers` before realizing, reattaches unchanged positions after applying the migrations, and persists the reattached file; it returns the realized file because reads expose plain data. A migration that adds `fdata/objects-map` skips the reattach so the pages get wrapped.
- `fdata/load-pointer` reads rows that a previous `file-gc` pass marked on purpose (explicit `::db/remove-deleted false`): the fragment is only gone once `objects-gc` purges it. The `get-file-fragment` RPC keeps rejecting marked rows.
- Bind the fragment loader through `fdata/with-pointers` (reads), `fdata/with-tracked-pointers` (writes with a loader) or `fdata/with-tracked` (writes with nothing to load yet, e.g. file creation), and `fdata/with-untracked` (validation passes that must track nothing) instead of hand-rolled `binding` forms. Two direct bindings remain on purpose: the fine-grained tracked toggles of `app.rpc.commands.files-update` (validation/repair turn tracking off, restore the existing atom and read it before repairing), and `binfile.common/encode-file` (a fresh tracked set inheriting the current one). Converge them only if atom-scoped macros (`with-tracking`, `with-inherited-tracking`) are added; today the extra indirection buys nothing.
- Snapshot creation takes `FOR SHARE` on the file row: both `create-file-snapshot` and the backup read of `restore-file-snapshot` hold it from the read to the insert, so they serialize with a `file-gc` pass (`FOR UPDATE ... SKIP LOCKED`) instead of pinning fragments the pass is about to mark. `get-file-snapshot` realizes the snapshot pointers with the live file id (fragment rows are keyed by file, not by snapshot).
- `fdata/realize` combines pointer realization and object-map realization. Use it before operations that need complete in-memory file data instead of pointer placeholders.
- A `file_data` row is one of three classes, told apart by `type`: `main` is the file's current state and carries `id = file_id`; `snapshot` is a point-in-time copy whose `id` is the one its `file_change` row shares; `fragment` is a piece of the pointer-map, referenced from the file's data.
- Their lifecycles differ: `main` and `snapshot` live with the file (dated when it is deleted, undated when it is restored), while a `fragment` carries no date and is collected by `file_gc` once the file stops referencing it. Neither is a session buffer, so do not read a `fragment` as an ephemeral revision.

9
.serena/memories/clojure/promesa.md Normal file
View File

@ -0,0 +1,9 @@
# Promesa
Promise library of the monorepo (frontend CLJS and common, `funcool/promesa` 12.0.1 in `common/deps.edn`). Its API has two call styles and mixing them in one expression is the trap: `fmap`/`mcat`/`merr` are **fn first, promise last** (`->>` friendly) and `then`/`then'`/`catch`/`handle` are **promise first, fn last** (`->` friendly). Convention: `fmap`/`mcat`/`merr` inside `->>` pipelines, `then`/`catch` with `->`. A `then` written inside a `->>` reads backwards and hides whether the step carries a value or a promise.
- `fmap` (alias `map`, both `(f p)`) is functor map: `f` returns a plain value.
- `mcat` (alias `mapcat`, both `(f p)`) is monadic bind: `f` must return a promise, and the result mirrors it.
- `then` also unwraps a promise returned by `f`, which is why it covers both cases at the cost of not naming which one it is; `then'` maps without unwrapping.
- `merr` (fn first) and `catch` (promise first) are the error side.
- `all` takes a collection of promises (a lazy seq works); `let` chains sequential bindings.
- Seam with the rx pipelines of the frontend: `beicon.v2.core/from` builds an observable from "arrays, collections, and promise instance" (`external/beicon`), so `(->> p (p/mcat f) (rx/from) (rx/map g))` is the usual bridge (`app.main.data.imports`, `app.util.zip`).

1
.serena/memories/common/file-change-validation-migration-subtleties.md
View File

@ -21,6 +21,7 @@
- Full referential/semantic validation currently runs only when file features contain `"components/v2"`.
- Validation starts at root plus orphan shapes, then validates component records. `validate-file!` raises `:validation :referential-integrity` with collected details.
- `repair-file` does not mutate data directly; it reduces validation errors into redo changes using `changes-builder`. Callers must apply or persist those changes.
- `repair-file-until-valid` stops on: no errors; unchanged `:data` after apply (backend page/`PointerMap` `=` is pointer identity); stable error fingerprint `(frequencies (map #(dissoc % :shape) errors))` vs previous pass (check fingerprint before `repair-file`/`process-changes`); or `max-iterations`. Each `repair-error` builds from the original `file-data`, so N `:set`-based errors on one shape take N passes.
- `:missing-slot` fires only for a REAL swap: a copy sub-head whose `shape-ref` is no longer a child of the near main parent. A pure positional mismatch (ref still a sibling elsewhere) is a reorder — valid, realigned by the async component sync; do not "repair" it by assigning swap slots (a slot freezes the child out of normal sync). `fix-missing-swap-slots` (migration 0019) follows the same membership rule.
## Migrations

5
.serena/memories/critical-info.md
View File

@ -8,6 +8,7 @@ You are working on the GitHub project `penpot/penpot`, a monorepo.
- Cross-cutting testing principles, TDD workflow, and anti-patterns: `mem:testing`.
- Verified Clojure language behaviors that contradict common assumptions (e.g. `int?` covers `Long`; `integer?` is the general predicate): `mem:clojure/idioms` — read before assuming stdlib predicate semantics.
- Read `mem:clojure/design-rules` (function shape, boundary checks, naming) before writing or modifying Clojure/ClojureScript code — not only when designing a solution or an API.
- Promises: which call style to use where (`fmap`/`mcat`/`merr` vs `then`/`catch`) and how they bridge to rx: `mem:clojure/promesa` — read before chaining promises or mixing them with observables.
# Development workflow
@ -17,6 +18,7 @@ You are working on the GitHub project `penpot/penpot`, a monorepo.
- Before `gh pr create` / `gh pr edit` → `mem:workflow/creating-prs` (title format, body structure, "Note:" line)
- Before a repo-wide pnpm version update → `mem:workflow/updating-pnpm` (workspace layout, `scripts/sync-pnpm-version` flow, the stamp-missing-field and ignored-builds gotchas, verification steps)
- Before a Node version update → `mem:workflow/updating-node` (the six pin sites in `.nvmrc`, the devenv and image Dockerfiles and the plugins-deploy workflows, the DHI tag and digest rules, what to verify)
- Before bumping a non-JS dependency pinned in `docker/images/` (JDK, ImageMagick) → `mem:workflow/docker-images`
- **Never `git push`, force-push, or modify `git origin`** (or any other remote). The user pushes from their own shell; if a push is required, say so and wait. Never amend a commit that the user has already pushed unless explicitly asked.
- **Never edit `CHANGES.md` by hand.** The changelog is generated from GitHub milestones during the release process; update it only via the `update-changelog` skill flow or on explicit user request.
- You have access to the GitHub CLI `gh` or corresponding MCP tools.
@ -25,6 +27,7 @@ You are working on the GitHub project `penpot/penpot`, a monorepo.
- Align `let` binding values: when a `let` form has multiple bindings spanning several lines, align the value forms to the same column with spaces.
- If you introduce delimiter errors (mismatched parens/brackets) in Clojure/CLJS files, fix them with `scripts/paren-repair` BEFORE running lint/format checks. See `mem:scripts/paren-repair` for usage.
- Never run anything that destroys data without explicit permission, including `drop-devenv`, `docker compose down -v`, `docker volume rm ...`. The user's real work lives in the volumes of the shared infra.
- **Never wait for background work with a sleep.** A long command moved to the background reports its own completion: do not poll it with `sleep 150` (or any other wait) inside a foreground command, and do not re-read its output file to check whether it finished. Keep working on something else, or end the response and wait for the notification.
# Project modules
@ -61,7 +64,7 @@ The memory is structured in a way that you can get the critical information abou
- `scripts/error-reports.mjs` — Query error reports via RPC API with token authentication. Supports list/get operations with filtering and pagination. See `mem:scripts/error-reports`.
- `scripts/clean-node-modules` — Remove stale `node_modules` from all pnpm workspaces (root, modules, member packages). Keeps the shared pnpm store at `<repo>/.pnpm-store` unless `--store`; ignores `external/` and `.opencode/`. Usage and reinstall steps: `mem:workflow/updating-pnpm`.
- `scripts/setup-opencode` — Install the opencode CLI in-container as a global pnpm package in `$PNPM_HOME`. Not part of the devenv image; see `mem:devenv/core`.
- `scripts/ci` — CI orchestration script: runs lint, tests, and format checks per module (`frontend backend common render-wasm exporter mcp plugins library`). Logs go to `.ci-logs/`; read the log file on failure. It is the preferred way to run the backend tests, and it exports `PENPOT_FLAGS` with `enable-backend-asserts`, which is what makes `clojure.core/assert` exist in the compiled test code. See `mem:scripts/ci`.
- `scripts/ci` — CI orchestration script: runs lint, tests, and format checks per module, plus the production build on request (`--build`). Modules: `frontend backend common render-wasm exporter mcp plugins library media-processor`. Logs go to `.ci-logs/`; read the log file on failure. It is the preferred way to run the backend tests, and it exports `PENPOT_FLAGS` with `enable-backend-asserts`, which is what makes `clojure.core/assert` exist in the compiled test code. See `mem:scripts/ci`.
# Dependency graph

4
.serena/memories/frontend/dashboard-viewer-subtleties.md
View File

@ -5,7 +5,7 @@
- Dashboard initialization fetches projects and fonts for the team, then listens to websocket messages only for global topic `uuid/zero` or the current profile id.
- Project fetch replaces each project map completely instead of merging, so fields such as `deleted-at` can disappear cleanly.
- Dashboard file/project mutations are often optimistic local updates with fire-and-forget RPC watchers. Bulk permanent delete/restore paths use SSE progress and progress notifications.
- The import wizard runs the package as a job of the backend: it reads the manifest of the file in the main thread (`app.main.data.imports`, no web worker) and follows the job, so its rows paint the milestone of the job (the stage and its counter, with the file in course) instead of the messages the old SSE stream sent. Before the job exists, the rows paint a client-side `:upload` milestone built from the chunked upload (`uploads/upload-blob-chunked` `:on-progress`, chunks done/total), which never comes from the backend; the chunks go one at a time and the row writes them as a percentage of the file, not as a counter. Once created and still waiting for a worker, each entry reports `:queued` ("Queued"); the `:start`/`:retry` events move it to bare progress, and only `:progress` carries a milestone. The export modal follows the same one-job-per-file model, but every file is queued up front (even the ones whose job is created only after the previous one is over) and its queue ends only with a milestone: `:start`/`:retry` do not end it there. Neither modal paints a generic "…ing file…" line any more: each row carries its own status. The `:error` of an import entry is user-facing text (the backend hint, or a translated label), never an i18n key: the wizard renders it as-is, it does not translate it again. The link-later step takes the file id from the `:id` of its resolution entry, never from the key of the resolution map: the map comes from the job result, so what a key holds depends on the result schema of the job-def that wrote it, while the wizard indexes its selection by the id of the entry. The legacy SSE import stays in the backend for other clients.
- The import wizard runs the package as a job of the backend: it reads the manifest of the file in the main thread (`app.main.data.imports`, no web worker) and follows the job, so its header paints the milestone of the job (the stage and its counter) instead of the messages the old SSE stream sent; every file of a container reports the same milestone, so `jp/current-milestone-text` writes it once and the rows never repeat it. Before the job exists, the header paints a client-side `:upload` milestone built from the chunked upload (`uploads/upload-blob-chunked` `:on-progress`, chunks done/total), which never comes from the backend; the chunks go one at a time and it writes them as a percentage of the file, not as a counter. Once created and still waiting for a worker, no row says anything: the header says the import waits for a slot while no job of it has started. The bar of the header measures the whole import, never a file: indeterminate while checking, waiting for a slot or rebuilding, because the client cannot know a global index and total of operations. The upload is the exception — the chunked upload knows its chunks, so the bar is determinate while the containers are sent, weighted by their size (`imp/upload-pct` over `:container-size`, the only percentage the client really knows). The export modal follows the same one-job-per-file model, but every file is queued up front (even the ones whose job is created only after the previous one is over) and its queue ends only with a milestone: `:start`/`:retry` do not end it there. Neither modal paints a generic "…ing file…" line on the rows any more: the rows of the import wizard carry only what is not progress — the name, the size, `Ready` once their container finished uploading, and the error text —, and the button that drops a file only shows while the wizard still offers its import step (the confirmation screen). Above the rows, the import wizard paints a stepper (Check/Upload/Import) plus one phase line: `imp/import-step` derives the step from the dialog status and the entries (upload holds while any file is pending, either `:import-ready` or carrying its own `:upload` milestone), so Check covers analyze, Upload covers the chunked client-side upload, and Import covers queue plus job. A file of a version 3 package shows what it occupies inside its container, computed while analyzing (`imp/file-sizes`): its own `files/<id>…` entries plus the storage objects its media and thumbnails reference, whose metadata is the only link to `objects/<id>…`. The container's own size stays in `:container-size` (what the dropped file weighs) and is what the upload bar weighs, never what a row shows. A file the manifest lists but the container holds no entry of has no size at all, and its row then shows no subtitle: what the package weighs never stands in for it. The subtitle is the size alone, with no extension. While analyzing with no failures nothing renders below the phase header — no rows, no spinner (`imp/awaiting-analysis?`); the header text is the only "Checking…" message. Rows appear once the analysis resolves (one per file inside the package), and a failed analysis takes the error-summary path instead. The ready step and its Continue wait for the end of the analysis (`imp/ready-to-import?`, fed with the completion of `imp/analyze`): a ready file is not enough, because the files still to arrive would never be imported. While rebuilding, the phase title counts the files and `imp/imported-count` counts them done with the job's own `:files` counter, so the number moves while a container rebuilds its files one by one. The `:error` of an import entry is user-facing text (the backend hint, or a translated label), never an i18n key: the wizard renders it as-is, it does not translate it again. The link-later step takes the file id from the `:id` of its resolution entry, never from the key of the resolution map: the map comes from the job result, so what a key holds depends on the result schema of the job-def that wrote it, while the wizard indexes its selection by the id of the entry. The legacy SSE import stays in the backend for other clients.
- File creation/duplication strips file `:data` before putting file summaries into dashboard state.
## Viewer
@ -13,6 +13,6 @@
- `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.
- 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, through `app.main.features.pointer-map/resolve-pointer` (share-link scoped; the workspace and library loaders use `resolve-file`, which resolves the same two levels). Both fail loudly: a fragment that cannot be resolved rejects the stream and is logged with file id and fragment id instead of silently dropping the page.
- `bundle-fetched` indexes pages and precomputes viewer frames/all-frames, stores libraries/users/thumbnails/permissions under `:viewer`, then navigates to frame id, query index, or auto-selected frame.
- Viewer zoom and interaction mode changes update both `:viewer-local` and the `:viewer` route query params. `update-zoom-querystring` guards with a query-param comparison (`not= current expected`) and uses `::rt/replace`; without that guard the load sequence (`bundle-fetched` → `zoom-to-fill` → `update-zoom-querystring` → `rt/nav`) re-runs on every navigation and crashes with React "maximum update depth exceeded" (2.18.0-RC5 regression, fixed in `31b73460c3`; regression test: `bundle-fetched-with-zoom-fill-url-does-not-navigate`).

2
.serena/memories/frontend/ui-conventions-and-style-system.md
View File

@ -12,7 +12,7 @@
- Co-located SCSS modules are preferred. Use `app.main.style/stl` helpers from CLJS and design-system SCSS tokens/mixins instead of legacy global selectors or high-specificity nesting.
- Keep CSS specificity low. Avoid nested selectors unless they target elements the component owns; CSS Modules already prevent class-name collisions.
- Prefer CSS logical properties for directional spacing/layout (`padding-inline-start`, etc.). Physical `width`/`height` are still acceptable where they are clearer.
- Prefer CSS logical properties for directional spacing/layout (`padding-inline-start`, etc.). Physical `width`/`height` are still acceptable where they are clearer. Never mix: a stylesheet logical property (`inline-size`) and an inline physical `width` on the same element cascade separately, and the logical mapping wins — a dynamically driven width must be `width` on both sides (import modal progress bar hit this). And an inline style passed from CLJS must be a JS object (`#js {:width …}`): for plain `[:div …]` elements the Rumext macro does not convert the `:style` map at runtime — a plain CLJS map reaches React raw and React never finds the keys (static style literals are converted at compile time, which is why `:style` maps seem to work elsewhere).
- Use named design-system variables/tokens for spacing, borders, fixed dimensions, colors, and typography. Avoid hardcoded px/rem values and deprecated `resources/styles/common/refactor/spacing.scss` variables.
- Use component-local CSS custom properties for variants and theming instead of one-off Sass variables when a component has multiple visual states.
- Prefer DS typography components (`heading*`, `text*`) and typography mixins instead of plain text wrappers or deprecated typography mixins.

36
.serena/memories/mcp/core.md
View File

@ -13,19 +13,26 @@ enabling advanced AI-driven features in Penpot.
- Build Tool: TypeScript Compiler (tsc) + esbuild
- Package Manager: pnpm
## General Principles
## Principles & Code Style
IMPORTANT: Use an idiomatic, object-oriented style.
In particular, this implies that, for any non-trivial interfaces, you use interfaces that expect explicitly typed abstractions
rather than mere functions (i.e. use the strategy pattern, for example).
* You keep each concern in exactly one home.
A mechanism whose parts are only correct in combination is implemented as a single component/class, and its parts are private to it;
expose a minimal public surface. Java-like encapsulation: If helper functions and constants are only used by one abstraction,
make them internal to the respective class.
* For any non-trivial interfaces, you use functions/methods that expect explicitly typed abstractions
rather than mere functions (i.e. use the strategy pattern, for example).
* Prefer declaring and instantiating concrete classes over defining only interfaces and using object literals.
Comments:
When describing parameters, methods/functions and classes, you use a precise style, where the initial (elliptical) phrase
clearly defines *what* it is. Any details then follow in subsequent sentences.
* When describing parameters, methods/functions and classes, you use a precise style, where the initial (elliptical) phrase
clearly defines *what* it is. Any details then follow in subsequent sentences.
* When describing what blocks of code do, you also use an elliptical style and start with a lower-case letter unless
the comment is a lengthy explanation with at least two sentences (in which case you start with a capital letter, as is
required for sentences).
When describing what blocks of code do, you also use an elliptical style and start with a lower-case letter unless
the comment is a lengthy explanation with at least two sentences (in which case you start with a capital letter, as is
required for sentences).
Syntax:
* Never use if blocks (or other blocks) without braces, even for single-line cases.
## Project Structure (Excerpt)
@ -102,6 +109,19 @@ From the `mcp/` directory, run
stdout directly. `NODE_TEST_CONTEXT` is the env var `node --test` sets.
* Cross-cutting testing principles and anti-patterns: `mem:testing`.
## OAuth for remote MCP clients
- Authorization/discovery URLs, self-contained client IDs, consent and PKCE/code binding, backend Redis state, deployment wiring, and compatibility limits: `mem:mcp/oauth`.
## Backend tools (`submit_feedback`)
- Tools that call the Penpot backend directly (not through the plugin) register only when `PENPOT_MCP_BACKEND_URI` is nonblank (`PenpotMcpServer.initTools`). Currently only `SubmitFeedbackTool`.
- `PenpotBackendClient` owns the HTTP call and the status-to-message mapping; it posts to `api/main/methods/send-mcp-feedback` with `Authorization: Token <MCP user token>`. The token comes from the session context (OAuth bearer or `?userToken=`); without one the tool fails before calling the backend.
- Tool zod schemas mirror the backend malli schema (lengths, blank, control characters); keep both in sync. The backend is the authority.
- Success means the mail job was queued, not delivered; the tool text says so. `formatArgs` hides the feedback from logs.
- Backend side: `send-mcp-feedback` in `app.rpc.commands.feedback`, configured by `PENPOT_MCP_FEEDBACK_EMAIL`; MCP-token auth rules in `mem:backend/auth-permissions-product-domains`.
- User docs: `mcp/README.md` (env tables), `docs/mcp/index.md` (tool list), `docs/technical-guide/configuration.md` (MCP feedback section).
## Devenv plugin/server wiring
In the normal Penpot devenv MCP path, the browser plugin does not discover or route through Postgres. The frontend provides the plugin extension API with `mcp.getServerUrl()`, currently derived from `frontend/src/app/config.cljs` as `penpotMcpServerURI` if set, otherwise `<public-uri>/mcp/ws`. The MCP plugin opens a direct WebSocket to that URL and appends the current MCP access token as a query parameter.

47
.serena/memories/mcp/oauth.md Normal file
View File

@ -0,0 +1,47 @@
# MCP OAuth
## Contract and scope
- MCP-specific authorization; existing Penpot login identifies the user on the approval page. No application vetting or persistent consent policy. Access requires user approval; registration alone grants nothing.
- Return the existing fixed MCP user token. On approval, enable `:mcp-enabled` and create the token only if no usable one exists; preserve an existing usable token. A token is unusable, and replaced, when expired (settings can give MCP tokens an expiry), when its JWT issuer is not `urn:penpot:mcp-token` (tokens issued before MCP tokens had their own issuer), or when this instance cannot decrypt it (e.g. secret key changed); the backend rejects all three. No refresh token, `expires_in`, or new token lifetime.
- No new client database table or schema migration. Client IDs must remain usable across separate authorization flows without server-side registration storage. Do not replace them with expiring Redis registrations.
- MCP transport continues matching user tokens to connected Penpot plugins; no new per-request token introspection or independent semantic validation. The logged-in Penpot instance remains the content-access boundary. Do not silently add resource-server validation or change token semantics.
- README scope: user/developer usage instructions; document `PENPOT_MCP_AUTH_URI` in its environment-variable table. Keep OAuth architecture and protocol details here and non-obvious invariants in source comments.
## Deployment and discovery
- MCP process: `PENPOT_MCP_AUTH_URI=https://penpot.example/api/mcp/oauth` with `--multi-user`. Unset/empty disables OAuth; configured OAuth requires multi-user. Absolute HTTPS, or HTTP on loopback for development; no userinfo, query, or fragment. Invalid configuration fails startup; startup logs OAuth status.
- Devenv: `mcp/scripts/start-mcp-devenv-oauth` starts multi-user mode with `PENPOT_MCP_AUTH_URI` derived from `PENPOT_PUBLIC_URI`. Manual opt-in only: agentic tooling needs the single-user `start-mcp-devenv`.
- Public MCP transport: `<Penpot public URI>/mcp/stream`, proxied to Node `/mcp`. Missing credentials with OAuth enabled: 401 plus `WWW-Authenticate` referencing `<auth base>/resource` and scope `mcp`.
- Bearer header takes precedence over legacy `?userToken=`. Malformed headers do not fall back to the query token. Existing query-token clients remain supported.
- Protected-resource metadata: `/api/mcp/oauth/resource`; issuer: `/api/mcp/oauth`; authorization-server metadata: `/.well-known/oauth-authorization-server/api/mcp/oauth`. All reach the backend. Bundled devenv/production nginx configs forward the well-known path; custom proxies must do likewise. Keep Penpot public URI and external URLs consistent.
- Node implementation: `mcp/packages/server/src/McpAuthentication.ts`, integrated by `PenpotMcpServer.ts`; OAuth-enabled tools advertise `_meta.securitySchemes`.
## Client identification
- `backend/src/app/mcp/oauth_clients.clj`: dynamic registration at `/api/mcp/oauth/register`, HTTPS client metadata documents (CIMD), and registrations obtained in advance via `(app.mcp.oauth-clients/register! {} metadata)`.
- DCR returns `penpot-mcp-v1.` plus unpadded base64url JSON: normalized callback URLs, optional name, authentication method, random nonce, optional secret hash. Fixed grant/response/scope values are reconstructed. Nonce distinguishes registrations with otherwise identical metadata.
- IDs are public, unsigned, unencrypted, non-expiring metadata; validate on every resolution. Client secrets are generated randomly and returned separately; only the hash enters the ID. No signing/encryption key or client record in PostgreSQL/Redis. Old experimental database-backed UUID IDs require registration again.
- An edited payload changes the ID. Authorization-code exchange compares the exact ID string against the approved request before resolving metadata. Do not replace this with comparison of decoded fields; code ownership and PKCE binding must survive metadata edits.
- Supported authentication: `none`, `client_secret_basic`, `client_secret_post`; no `private_key_jwt`. CIMD selects public-client `none` from the document's supported methods; other listed methods do not imply support here. Scope `mcp`; grant `authorization_code`; response `code`. CIMD may advertise additional grants (e.g. Codex lists `refresh_token`); require `authorization_code` support and normalize to the grant Penpot implements, rather than reject broader client capabilities.
- Entire ID capped at 2,048 ASCII characters. DCR returns `invalid_client_metadata` if encoded metadata exceeds this; shorter/fewer callback URLs reduce size. OAuth defines no fixed ID-length maximum (RFC 6749 §2.2); stateless IDs are explicitly described by RFC 7591 §A.5.2. Installed MCP client SDK 2.3.1 accepts a 2,048-character ID; this does not establish Codex/Claude compatibility.
- Redirect matching is exact except loopback HTTP port changes for native clients (`127.0.0.1`, `[::1]`, exact `localhost`). Host, path and query must still match; reject fragments/userinfo and lookalike localhost domains. Allow HTTPS, loopback HTTP, and reverse-domain native schemes.
- CIMD: fetch with existing SSRF-checked `app.http.client/req`, no redirect following, require matching document `client_id`, bounded 64-KiB body and request/body-read timeouts. Cache max 256 entries/one minute, further limited by HTTP max-age; no-store/no-cache/no max-age means no reuse.
## Approval and exchange
- `backend/src/app/http/mcp_oauth.clj`: separate router branch from ordinary RPC middleware; preserve OAuth snake_case JSON and form encoding. Session auth applies to approval request/decision only. Public metadata/register/token endpoints allow noncredentialed CORS; MCP transport CORS was not added.
- Errors: every failure answers with an OAuth `{"error": ...}` body, never the shared Penpot error shape. Failures without `:oauth-error` are also passed to `app.http.errors/handle` for logging only; its response is discarded. `wrap-errors` also wraps the session middleware of `/request` and `/decision`. Safe to log because these routes never set request `:params`.
- `/authorize`: validate client/callback, `code`, PKCE S256, scope/resource/state; store pending request for 600 seconds; redirect to `?screen=mcp-authorize&request=<opaque handle>`.
- `frontend/src/app/main/ui/mcp_authorize.cljs`: existing login with return URL; show application and account details; submit explicit Allow/Cancel. No fixed MCP token in frontend state or browser redirect. Approval refreshes profile and broadcasts MCP enablement; does not connect a plugin automatically.
- `/request`: first authenticated read binds request to profile plus hashed login-session ID and CSRF value, using compare-and-replace. Re-read after the attempt: concurrent GETs may win/lose binding; only the matching session may proceed.
- `/decision`: check exact Origin, session binding and CSRF, then atomically consume the request. Denial creates no token/enables nothing. Approval calls transactional `access-token/ensure-mcp-access!`, then stores code for 120 seconds. Code state holds token row ID, never the fixed token. Callback echoes OAuth `state` and RFC 9207 `iss`.
- `/token`: validate grant, exact client ID/callback/resource and PKCE; resolve current client metadata/authentication method and verify any secret; atomically consume validated code; fetch the unexpired token by original row ID/profile/type. Regeneration deletes the old token row, so a pending code cannot silently yield the replacement token. Return fixed `access_token`, `token_type: Bearer`, scope `mcp`.
- `backend/src/app/mcp/oauth_state.clj` and Lua: tenant/kind/hash-prefixed keys; random handles; SET NX EX must succeed before returning handle. Reads retain raw JSON for atomic comparison. Consume/delete and bind/replace compare the validated raw record in Lua; replacement preserves TTL. Redis failures fail closed. Backend Redis is required independently of Node's optional Redis plugin bridge.
- `backend/src/app/rpc/commands/access_token.clj`: `ensure-mcp-access!` decodes the stored token with `ex/ignoring` to apply the usable-token rule above. Lock profile row in both MCP generation and OAuth provisioning, including when no token exists. Serializes simultaneous approvals and settings regeneration. Provisioning must run within a transaction.
## Verification and limits
- Tests: `mcp_oauth_clients_test.clj`, `mcp_oauth_http_test.clj`, `mcp_oauth_state_test.clj`, OAuth provisioning in `rpc_access_tokens_test.clj`; MCP authentication/HTTP tests; frontend approval tests. Cover no-storage registration, size boundaries, edited-ID rejection, code replay/concurrency, session/CSRF binding, and fixed-token reuse.
- Live OpenAI/Codex/Claude compatibility and marketplace acceptance remain unverified. In particular, verify token persistence without `expires_in` and acceptance of the existing matching-only resource boundary; do not claim protocol conformance from SDK tests alone.
- Protocol references: https://www.rfc-editor.org/rfc/rfc6749.html#section-2.2 ; https://www.rfc-editor.org/rfc/rfc7591.html#appendix-A.5.2 ; https://www.rfc-editor.org/rfc/rfc7636.html ; https://www.rfc-editor.org/rfc/rfc9207.html .

1
.serena/memories/memory-maintenance.md
View File

@ -26,6 +26,7 @@ No manual line wrapping: one line per bullet or paragraph, however long. Memorie
## Add/update threshold
Add or update memories only with stable, non-obvious project conventions that avoid complex rediscovery in the future.
Do not restate what the code already says (comments included): keep only what code cannot represent — decisions and their reasons, cross-file invariants, ordering constraints, environment and tool behavior, and traps that break builds.
Do not add: quick-read facts; generic language/framework knowledge; one-off task notes; volatile line-level details; behavior likely to change soon.
## Maintenance Actions

72
.serena/memories/scripts/ci.md
View File

@ -1,8 +1,9 @@
# CI (scripts/ci)
`scripts/ci` runs CI-style checks — lint, tests, format — for one or more
monorepo modules and prints a per-task summary. It is the local equivalent
of CI; use it to verify changes before declaring work done.
`scripts/ci` runs CI-style checks — lint, tests, format — and, on request,
the production build of each module, for one or more monorepo modules, and
prints a per-task summary. It is the local equivalent of CI; use it to
verify changes before declaring work done.
It also exports `PENPOT_FLAGS` with `enable-backend-asserts` appended (keeping
whatever the caller already set), which is what puts `clojure.core/assert`
@ -25,6 +26,7 @@ Run from the repo root:
```bash
./scripts/ci MODULE... # lint + test + fmt per module
./scripts/ci --build MODULE # production build only
./scripts/ci --all --no-test # lint + fmt on all modules
./scripts/ci --lint frontend # lint only
./scripts/ci --fix --no-test frontend # format files, skip tests
@ -32,14 +34,15 @@ Run from the repo root:
./scripts/ci --dry-run --all # preview what would run
```
Modules: `frontend backend common render-wasm exporter mcp plugins library`.
Modules: `frontend backend common render-wasm exporter mcp plugins library
media-processor`.
Flags:
- Default tasks: `lint`, `test`, `fmt` (format check; `--fix` formats
instead).
- `--lint` / `--test` / `--fmt` run one task only; `--no-lint` /
`--no-test` / `--no-fmt` drop one task from the default set.
instead). Build is **not** in the default set.
- `--lint` / `--test` / `--fmt` / `--build` run one task only; `--no-lint` /
`--no-test` / `--no-fmt` / `--no-build` drop one task from the default set.
- `--paren-repair` runs only the delimiter repair — it wraps
`scripts/paren-repair` over each module's Clojure/CLJS sources; see
`mem:scripts/paren-repair`.
@ -48,6 +51,49 @@ Flags:
output; `--dry-run` prints commands without running; `--clean` removes
the log directory.
## Build task
`--build` compiles each module the way production does, reusing caches
(`.shadow-cljs`, `target/`, `node_modules`) instead of clearing them. It
does not package bundles: `manage.sh build-bundle` remains the way to
produce deployable artifacts.
| Module | Command | Output |
|---|---|---|
| `frontend` | `NODE_ENV=production pnpm run build:app:main && pnpm run build:app:libs && pnpm run build:app:assets` | `frontend/resources/public/`, `frontend/target/` |
| `backend` | `clojure -T:build jar` | `backend/target/penpot.jar` |
| `common` | *(none; skipped)* | — |
| `render-wasm` | `./build` (targets `frontend` and `export`) | `render-wasm/target/` |
| `exporter` | `NODE_ENV=production pnpm run build:app` | `exporter/target/` |
| `mcp` | `pnpm run build` | `mcp/*/dist` |
| `plugins` | `pnpm run build:runtime && pnpm run build:plugins && pnpm run build:styles-example && pnpm run build:doc` | `plugins/dist/` |
| `library` | `NODE_ENV=production clojure -M:dev:shadow-cljs release library` | `library/target/library/` |
| `media-processor` | `pnpm run types:check && pnpm run build` | `media-processor/dist/` |
- Every output path above is gitignored, so a build leaves `git status`
clean.
- The module `build` scripts in each `scripts/build` are **not** used: they
delete `node_modules`, wipe `resources/public` and run `pnpm install`,
which belongs to the bundle pipeline, not to a local check.
- `frontend` and `library` have a `build` script that clears the shadow-cljs
cache first; the task calls the inner commands to stay incremental.
`exporter` uses `build:app` for the same reason.
- `common` has no artifact of its own: its compilation is exercised by its
`test` task and by the builds of `frontend`, `backend` and `exporter`.
- `media-processor` is the ninth module. It has no lint, so that task shows
as skipped; its build runs `tsc --noEmit` before esbuild because esbuild
does not type-check.
- Cold-cache cost measured on the devenv: `library` ~120 s, `frontend` ~120 s,
`exporter` ~80 s, `backend` ~35 s. With warm caches the whole set (8
builds) takes ~4 min. The first run of `clojure -T:build jar` downloads
`tools.build` if it is not in `~/.m2`.
- `pnpm run` may trigger a dependency check/install when `node_modules`
drifts from the lockfile (`verify-deps-before-run`), so the first run
after a dependency change can need network.
- `render-wasm/build` takes a lock (`_build_lock`): never run two builds at
once in the same checkout.
## Logs and exit codes
- Full output of every task: `.ci-logs/<module>-<task>.log`.
@ -59,12 +105,16 @@ Flags:
## Notes
- `mcp` has no lint task (shows as skipped). `render-wasm` uses `./lint`,
`./test`, and `cargo fmt`.
- `mcp` has no lint task and `media-processor` has no lint task; both show
as skipped. `render-wasm` uses `./lint`, `./test`, and `cargo fmt`.
- `scripts/test_ci.py` (unittest, `python3 scripts/test_ci.py`) covers the
flag wiring, one build command per module and the help text through
`--dry-run`; it executes no real build.
- Exports `PENPOT_FLAGS` with `enable-backend-asserts` appended to any
existing value, so backend test runs compile in and exercise
precondition asserts; see `mem:backend/testing`.
- Test tasks are long-running (backend: `clojure -M:dev:test`); use a
generous timeout when calling it from an agent shell.
- Test and build tasks are long-running (backend: `clojure -M:dev:test`;
frontend build: ~2 min warm); use a generous timeout when calling it from
an agent shell.
- Skill entry point: `.agents/skills/local-ci/SKILL.md`.
- Testing principles and output discipline: `mem:testing`.

6
.serena/memories/workflow/docker-images.md Normal file
View File

@ -0,0 +1,6 @@
# Non-JS dependencies in the production images
Node and pnpm pins: `mem:workflow/updating-node` and `mem:workflow/updating-pnpm`. Only the parts the Dockerfiles cannot show:
- JDK: the image tracks a non-LTS line, so there is no minor to pick — the last build of the line is the ceiling; moving line is a major and needs a real build to validate the `jlink` module list.
- ImageMagick: publish `penpotapp/imagemagick:<ver>` **before** bumping the `COPY --from` refs in the backend, exporter and devenv Dockerfiles; otherwise both builds break on the missing tag.

3
.serena/memories/workflow/updating-node.md
View File

@ -5,7 +5,7 @@ No single source of truth: nothing reads `.nvmrc` at build time, and the version
## Pin sites
- `.nvmrc` → `v<X.Y.Z>`, with the leading `v`.
- `docker/devenv/Dockerfile`, `setup-node` stage → `ENV NODE_VERSION=v<X.Y.Z>`; downloads `https://nodejs.org/dist/${NODE_VERSION}/node-${NODE_VERSION}-linux-{arm64,x64}.tar.gz`, one tarball per arch, and verifies each against a `NODE_SHA256` right below its `BINARY_URL`. Both hashes come from `SHASUMS256.txt` in that same dist directory, so a bump must recompute the two.
- `docker/devenv/Dockerfile`, `setup-node` stage → `ENV NODE_VERSION=v<X.Y.Z>`; downloads `https://nodejs.org/dist/${NODE_VERSION}/node-${NODE_VERSION}-linux-{arm64,x64}.tar.gz`, one tarball per arch, and verifies each against a `NODE_SHA256` right below its `BINARY_URL`. Both hashes come from `SHASUMS256.txt` in that same dist directory, so a bump must recompute the two; only the arch SHAs change, the structure stays.
- `docker/images/Dockerfile.mcp` → two stages: `FROM dhi.io/node:<X.Y.Z>-debian13-dev AS build` and `FROM dhi.io/node:<X.Y.Z>-debian13 AS image`. The release stage carries no `-dev`.
- `docker/images/Dockerfile.media-processor` and `docker/images/Dockerfile.exporter` → single `FROM dhi.io/node:<X.Y.Z>-debian13-dev`.
- `.github/workflows/plugins-deploy-api-doc.yml` and `.github/workflows/plugins-deploy-styles-doc.yml` → `runtime: node@<X.Y.Z>` in the `pnpm/setup` step. Its `working-directory: plugins` makes pnpm's own version come from the manifest, so this pin is the Node one; keep it equal to `.nvmrc` minus the `v`.
@ -18,6 +18,7 @@ No single source of truth: nothing reads `.nvmrc` at build time, and the version
- Node 24.x is the Krypton LTS line: take the newest patch of that major unless a major bump is the point.
- Renovate also opens these bumps, on `renovate-*` branches and with its config living outside this repo; a manual bump and Renovate's must not diverge on any of the six sites.
- A backport merge can deliver a newer Node into `docker/` and the plugins-deploy workflows while main's `.nvmrc` stays behind, because main receives partial backports of `.github/` and `docker/` from develop. Merging main into staging therefore conflicts on the pin lines: take main's set and finish the bump (`.nvmrc` plus the `packageManager` fields via `mem:workflow/updating-pnpm`), or the six sites drift.
- The newer version wins in both directions. A maintenance→main merge (`main-2.18.x` into `main`) can carry the newer Node while `.nvmrc` and the `packageManager` fields stay on the older pair; then adopt the newer set and finish the bump on all six sites plus the 35 `packageManager` fields.
- Both workflows must stay valid YAML. The `python3` in the devenv has no `yaml` module, so validate with `uv run --with pyyaml python3 -c ...` instead of a bare import.
## Verification

8
.serena/memories/workflow/updating-pnpm.md
View File

@ -27,8 +27,8 @@ file (never pipe tool output through filters).
members) must carry a `packageManager` field with the identical
`pnpm@<version>+sha512.<hash>` value. Do not let them drift.
`external/` (vendored trees with their own lifecycles), `.opencode/`,
`.pnpm-store/`, `bundles/` and `docker/images/bundle-*` copies are
never stamped.
`.pnpm-store/`, `bundles/`, `target/` build output and
`docker/images/bundle-*` copies are never stamped.
- pnpm is a system binary everywhere (devenv image, CI runners, Docker
images). Nothing may call corepack: it is gone from Node 25+. pnpm
auto-downloads the `packageManager` version on mismatch
@ -71,6 +71,7 @@ file (never pipe tool output through filters).
4. Run `scripts/sync-pnpm-version --install` (plain `pnpm install` in
each of the 11 workspace roots) to refresh lockfile metadata, then
fix any failing workspace (see gotchas) and re-run that directory.
For a version-only bump, `pnpm install --lockfile-only` in each root is enough: it rewrites only the pnpm self-reference entries and needs no node_modules. The repo-root `pnpm-lock.yaml` is rewritten by itself on the first `pnpm` call that self-installs the target version.
## Gotchas
@ -96,6 +97,9 @@ file (never pipe tool output through filters).
section in lockfiles last written by older pnpm. Large diffs mean
re-resolution; inspect them before accepting.
- A backport merge of main into staging can bring a newer `PNPM_VERSION` in `docker/` while every `packageManager` field stays behind, since main receives partial `.github/`+`docker/` backports from develop. Resolve those conflicts with main's version and run `scripts/sync-pnpm-version <version>` in the same merge.
- Direction does not decide the winner, the version does. A maintenance→main merge (`main-2.18.x` into `main`) can carry the newer Node and pnpm pins in `docker/` and the `plugins-deploy-*` workflows while main's `.nvmrc` and 35 `packageManager` fields stay on the older pair. Take the newer pair on every pin site (`docker/`, workflows, `.nvmrc`, `packageManager`) and run `scripts/sync-pnpm-version <version>` in the same merge; check with `--check` plus `pnpm install --lockfile-only --frozen-lockfile` per workspace.
- Those merges conflict on the pnpm self-reference block in all 11 lockfiles (importers `packageManagerDependencies`, `packages/@pnpm/exe.*@<ver>`, `pnpm@<ver>` and the matching `snapshots` entries). Resolve each workspace's lockfile keeping its own importer/package resolution and swapping only that block to the newer version. Do not start from the older side and regenerate with `pnpm install --lockfile-only`: pnpm re-resolves every changed range upward (this merge took root `@playwright/test` from 1.63.0 to 1.64.1 and `@modelcontextprotocol/server` from 2.3.1 to 2.4.0), which pollutes the merge with unrelated bumps. If a workspace later needs a real re-resolution after a manifest bump, `pnpm install --lockfile-only --fix-lockfile` accepts the hand-merged file and only fills what the manifests demand.
- `pnpm install` cannot run in `frontend` or `exporter` when `github.com` does not resolve: the `@penpot/svgo` git dependency triggers a `git fetch`. Frontend's lockfile entry carries no integrity, so pnpm always refetches; exporter's has one and still works. For frontend, resolve the self-reference hunks only.
## Verification

2
AGENTS.md
View File

@ -155,6 +155,6 @@ precision while maintaining a strong focus on maintainability and performance.
- `scripts/nrepl-eval.mjs` — Evaluate Clojure code via nREPL (backend + frontend).
- `scripts/check-commit` — Validate commit messages against Penpot's commit guidelines.
- `scripts/check-fmt-clj` — Check Clojure formatting without modifying files.
- `scripts/ci` — CI orchestration script for running lint, tests, and format checks across modules. See `mem:scripts/ci`.
- `scripts/ci` — CI orchestration script for running lint, tests, format checks and, on request (`--build`), production builds across modules. See `mem:scripts/ci`.
- `scripts/gh.py` — Multi-purpose GitHub CLI helper. Subcommands: `issues` (list issues in a milestone), `prs` (fetch PR details), `advisories` (list/inspect security advisories). See `python3 scripts/gh.py --help`.

2
backend/package.json
View File

@ -4,7 +4,7 @@
"license": "MPL-2.0",
"author": "Kaleidos INC Sucursal en España SL",
"private": true,
"packageManager": "pnpm@12.15.0+sha512.b3951d6d6ff4a9f13dc7cf56cd28d2b8eb37dbcc9c68e52e1e1191873ea9f82a017287ab50baadc5ccc494f036c67c0e47eb13608c2fa36f47711b61ea128e61",
"packageManager": "pnpm@12.16.1+sha512.091d1dee7927575661b25dab3c2ae31cafc1c54d6b71ed6a6600cf0c1cb10434a447eae14015f1b23e2e6bedeed79df94a932e2164d2832280dce3fb32f656d1",
"repository": {
"type": "git",
"url": "https://github.com/penpot/penpot"

122
backend/pnpm-lock.yaml generated
View File

@ -7,153 +7,153 @@ importers:
configDependencies: {}
packageManagerDependencies:
pnpm:
specifier: 12.15.0
version: 12.15.0
specifier: 12.16.1
version: 12.16.1
packages:
'@pnpm/exe.android-arm64@12.15.0':
resolution: {integrity: sha512-eVCqmscY70LGvgRzu3mi8IBWBFGix+a6mNZoWmXxESsBdeiKEF9xQSuaeel10yn+zI7TXy2jlI63vFLzETk+aQ==}
'@pnpm/exe.android-arm64@12.16.1':
resolution: {integrity: sha512-PKf78Ew+i0CBYf0Xc+eMcqQiqyBT+u8XCVg1F5roc98/6wWfdYlWhrUMmEBiKWaJ3JqHxrtt8l1NwZ7qfJt2/Q==}
cpu: [arm64]
os: [android]
'@pnpm/exe.android-x64@12.15.0':
resolution: {integrity: sha512-Gx/WbkFcdUFUg8g8AShezcS9EiQxfYvdAm2hfKLO8sfJmJvKOCt5fzlgHWDzmGhoclibgW+tUGZ/KF4F4wOTCA==}
'@pnpm/exe.android-x64@12.16.1':
resolution: {integrity: sha512-xdu7gMbB98pdvhwMeA6612Of515FDlRUtfA/1f7nWPZfPLnEdSRBO2u+1N0XBtQ/ennhPH/lrxB1gC6gnR/cdg==}
cpu: [x64]
os: [android]
'@pnpm/exe.darwin-arm64@12.15.0':
resolution: {integrity: sha512-N0ZykiDWCvqSBJvt71j7cSoBR993FqvYZFtmpCtqvW3pguiI+NAgraLPA5OTwu5mV+/d8hYpVcPktJA3xFDLtA==}
'@pnpm/exe.darwin-arm64@12.16.1':
resolution: {integrity: sha512-pVbmIIbhixiLvADLu1WA3TaW8FZy/D72R1De27WbbFx8/2mxvnsTyFVm4fO9kjpjMY7RzJd48CiQ96p8fO3ebQ==}
cpu: [arm64]
os: [darwin]
'@pnpm/exe.darwin-x64@12.15.0':
resolution: {integrity: sha512-7Ntr2HlBUxzwWOg7NwDxCbRW/3vXuqKO+hcXm+w3SBi9rrHY53li1wLqWVT7Gjxd+lVEHM1QJZo6WJEGFU8C6A==}
'@pnpm/exe.darwin-x64@12.16.1':
resolution: {integrity: sha512-xZvQBFqcZjO7vFKTK3XsJpqY6lnBL9EWSLCzVUPq3kZ94+D96gwJCa76xxGNK8Cj32f4eeM91Qg+yNRR4sRpDw==}
cpu: [x64]
os: [darwin]
'@pnpm/exe.freebsd-x64@12.15.0':
resolution: {integrity: sha512-btOiyL7fL7W4uQGH0aqFai2TNC3IoKcZ7gNHBVbEFZt2dWrnrD0SufL3iGs3fLlmb4OtuU35uf4Zpr9V9Jh9mA==}
'@pnpm/exe.freebsd-x64@12.16.1':
resolution: {integrity: sha512-zTtunfi9mBhRXiXEJYfwiJj0tk7MgTSfqDSRh+Az9FZ9THazVIiQiVNS8jpcsftDOqu7LKNffQdjmgwHDThfUg==}
cpu: [x64]
os: [freebsd]
'@pnpm/exe.linux-arm64-musl@12.15.0':
resolution: {integrity: sha512-pNC38k+O+90FOjbPNSnw0E7apq1PKTmz3fFe1amn+lys/U5kL++uzir8bRiho8ONcyA3d9EU7wdqcY0DKkj+JA==}
'@pnpm/exe.linux-arm64-musl@12.16.1':
resolution: {integrity: sha512-BJ3mOmcmQgcUo92Ee/WfEOt1pRiv3y2MMAkhEiYHd85UiPpHTfFhv+SpCbALmfExzXk3UlaRtMYwHlkQymc4VA==}
cpu: [arm64]
os: [linux]
libc: [musl]
'@pnpm/exe.linux-arm64@12.15.0':
resolution: {integrity: sha512-qML/8aCXslh8td/w4U+HJNqUcZ2+m6EfTbWScIzZRmyPsRFN+xB4LP1U/hymxc1iSJiKtG56HJx2fvUErWFIGw==}
'@pnpm/exe.linux-arm64@12.16.1':
resolution: {integrity: sha512-JaRd5gNxwdNGBBkrZFt8bknrK4YmHVJBW0JMhUQ0fJ0dEYp6C2GT9ExaCqOO8EwYEyqM+jpKgJIK+8WFaJy3ew==}
cpu: [arm64]
os: [linux]
libc: [glibc]
'@pnpm/exe.linux-ppc64@12.15.0':
resolution: {integrity: sha512-tjRDUUl7RCJ6T/6eoNPxOqkwU4Mzi5RtTXmSAxujyz37OTwwsMU7Ps087Zk4gHcUvRSeyF40ZFsew3vtE+nmUA==}
'@pnpm/exe.linux-ppc64@12.16.1':
resolution: {integrity: sha512-FnSV0Jv40S1cMv7vFNWwvu0X567Lec4L4HCRead3CFcD6zQDNbGw81s8N5bcKPahtPD9ApVuhsbmFCx4rw6RMw==}
cpu: [ppc64]
os: [linux]
libc: [glibc]
'@pnpm/exe.linux-riscv64@12.15.0':
resolution: {integrity: sha512-bF1uBWEfbwaeryz6lIiaJ8AWD082otZfvzGX5l+6LZRpRwUEpJHUsJrORaYP5/cNMv5ZR2p6TvvcJcQzwtDzmw==}
'@pnpm/exe.linux-riscv64@12.16.1':
resolution: {integrity: sha512-C1Sww4FN5IttD4atRRhAKmQtSGWVp04ZAKNxO8pfu2bkRPwOW+7v+2DH1Xs1W+kZYYpO86BYDvUcadefF+AgaQ==}
cpu: [riscv64]
os: [linux]
libc: [glibc]
'@pnpm/exe.linux-s390x@12.15.0':
resolution: {integrity: sha512-zKMhIzsexYMToeLmqV5jPsvV/f9vwsJb2kUH2NFYzalbxImeBrlA4kL7GwF8gD4pagV6jYYcJb8RjbZIdjHptg==}
'@pnpm/exe.linux-s390x@12.16.1':
resolution: {integrity: sha512-kn2fautsTcxIMODoovQVqZyfpDRdNgGkoeVqNdrKqbeBBvrEl+fXLkmZiq5xDht1LMr4sYiCNcsMfNMT6JPFmg==}
cpu: [s390x]
os: [linux]
libc: [glibc]
'@pnpm/exe.linux-x64-musl@12.15.0':
resolution: {integrity: sha512-A9J0Jg0Rdx+qQU4qXtwyST5tto9IOu1zi4fDk35nbc6DWahggbcKtFvZPKFwL2qgUXGXOX//hXv6z/sp6emO8A==}
'@pnpm/exe.linux-x64-musl@12.16.1':
resolution: {integrity: sha512-PM6ccHCOe/O9SsTflTJTYWfwogJZa6EmUvpnwZgiPguJBddh20wDQKgxUPXf48rDsPm9vMsIij0uHswwwbXL8g==}
cpu: [x64]
os: [linux]
libc: [musl]
'@pnpm/exe.linux-x64@12.15.0':
resolution: {integrity: sha512-yc+QlZR+9+nr29J4fRzhMoapgxTBDndq/+peyoq1XUufnQFnfbXUMFudDIKzHi545linGqmOmXfn0NoufNgcOg==}
'@pnpm/exe.linux-x64@12.16.1':
resolution: {integrity: sha512-RK//8ZLcXGW8A2k8bQOXZDBN1Qu92zN4dYnG1bzj1zoQ1fkZ6jNzZ1AvXtsfGVma795CJtvoaF5bLXf4l/FIUw==}
cpu: [x64]
os: [linux]
libc: [glibc]
'@pnpm/exe.win32-arm64@12.15.0':
resolution: {integrity: sha512-fPXZxuY1VclkOga9bc53qNCXcegfeoBR8+Ue+AospDwKzuGGSHll0oDxkLfkmpjyRqpe7bH5DyQPYp/xSMaIVA==}
'@pnpm/exe.win32-arm64@12.16.1':
resolution: {integrity: sha512-Ox3kNNVxtGw6pK7SVejmeOUgHhUTZgAM7NQQ6cU7frPw3ix9+j7d2MGbRg3fyEFAaKWq8ZAZLTQGcDyLnAu+qA==}
cpu: [arm64]
os: [win32]
'@pnpm/exe.win32-x64@12.15.0':
resolution: {integrity: sha512-nrd+Tp1We1DGj4DGG5Bea9lZNh9y1PjlLBdEwdInS4D0h0UIDtM7JaGGGDJhNzIwcHASyihWI7HLV+dtG+fhYg==}
'@pnpm/exe.win32-x64@12.16.1':
resolution: {integrity: sha512-k+FhRJ0ttphFoFIVB1Sk4v76YJAulafmA/Ly57cysesUhhIzVlApeOShUz0jXubKx317TThlEfpQrukldnqORA==}
cpu: [x64]
os: [win32]
pnpm@12.15.0:
resolution: {integrity: sha512-s5UdbW/0qfE9x89WzSjSuOs328ycaOUuHhGRhz6p+CoBcoerULqtxczElPA2xnwOR+sTYIwvo29HcRth6hKOYQ==}
pnpm@12.16.1:
resolution: {integrity: sha512-CR0d7nknV1Zhsl2rPCrjHK/BxU1rce1qZgDPDByxBDSkR+rhQBXxsj4ua+3u1535SpMuIWTSgyKA3OP7MvZW0Q==}
engines: {node: '>=18'}
hasBin: true
snapshots:
'@pnpm/exe.android-arm64@12.15.0':
'@pnpm/exe.android-arm64@12.16.1':
optional: true
'@pnpm/exe.android-x64@12.15.0':
'@pnpm/exe.android-x64@12.16.1':
optional: true
'@pnpm/exe.darwin-arm64@12.15.0':
'@pnpm/exe.darwin-arm64@12.16.1':
optional: true
'@pnpm/exe.darwin-x64@12.15.0':
'@pnpm/exe.darwin-x64@12.16.1':
optional: true
'@pnpm/exe.freebsd-x64@12.15.0':
'@pnpm/exe.freebsd-x64@12.16.1':
optional: true
'@pnpm/exe.linux-arm64-musl@12.15.0':
'@pnpm/exe.linux-arm64-musl@12.16.1':
optional: true
'@pnpm/exe.linux-arm64@12.15.0':
'@pnpm/exe.linux-arm64@12.16.1':
optional: true
'@pnpm/exe.linux-ppc64@12.15.0':
'@pnpm/exe.linux-ppc64@12.16.1':
optional: true
'@pnpm/exe.linux-riscv64@12.15.0':
'@pnpm/exe.linux-riscv64@12.16.1':
optional: true
'@pnpm/exe.linux-s390x@12.15.0':
'@pnpm/exe.linux-s390x@12.16.1':
optional: true
'@pnpm/exe.linux-x64-musl@12.15.0':
'@pnpm/exe.linux-x64-musl@12.16.1':
optional: true
'@pnpm/exe.linux-x64@12.15.0':
'@pnpm/exe.linux-x64@12.16.1':
optional: true
'@pnpm/exe.win32-arm64@12.15.0':
'@pnpm/exe.win32-arm64@12.16.1':
optional: true
'@pnpm/exe.win32-x64@12.15.0':
'@pnpm/exe.win32-x64@12.16.1':
optional: true
pnpm@12.15.0:
pnpm@12.16.1:
optionalDependencies:
'@pnpm/exe.android-arm64': 12.15.0
'@pnpm/exe.android-x64': 12.15.0
'@pnpm/exe.darwin-arm64': 12.15.0
'@pnpm/exe.darwin-x64': 12.15.0
'@pnpm/exe.freebsd-x64': 12.15.0
'@pnpm/exe.linux-arm64': 12.15.0
'@pnpm/exe.linux-arm64-musl': 12.15.0
'@pnpm/exe.linux-ppc64': 12.15.0
'@pnpm/exe.linux-riscv64': 12.15.0
'@pnpm/exe.linux-s390x': 12.15.0
'@pnpm/exe.linux-x64': 12.15.0
'@pnpm/exe.linux-x64-musl': 12.15.0
'@pnpm/exe.win32-arm64': 12.15.0
'@pnpm/exe.win32-x64': 12.15.0
'@pnpm/exe.android-arm64': 12.16.1
'@pnpm/exe.android-x64': 12.16.1
'@pnpm/exe.darwin-arm64': 12.16.1
'@pnpm/exe.darwin-x64': 12.16.1
'@pnpm/exe.freebsd-x64': 12.16.1
'@pnpm/exe.linux-arm64': 12.16.1
'@pnpm/exe.linux-arm64-musl': 12.16.1
'@pnpm/exe.linux-ppc64': 12.16.1
'@pnpm/exe.linux-riscv64': 12.16.1
'@pnpm/exe.linux-s390x': 12.16.1
'@pnpm/exe.linux-x64': 12.16.1
'@pnpm/exe.linux-x64-musl': 12.16.1
'@pnpm/exe.win32-arm64': 12.16.1
'@pnpm/exe.win32-x64': 12.16.1
---
lockfileVersion: '9.0'

40
backend/resources/climit.edn
View File

@ -6,72 +6,74 @@
;; 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.
;; waiter waits. Every entry sets a timeout and a queue: a command takes the
;; limits it declares before the root ones, so the queue of a limit is where
;; its own pile-up waits. The root limits bound what runs at the same time,
;; not what waits for it.
;; The production file lives outside this repository: mirror the shape there,
;; not these numbers. It has to list every id a command declares: an id without
;; an entry runs with no limiter at all.
{:update-file/global
{:permits 20 :timeout 60000}
{:permits 20 :queue 50 :timeout 60000}
:update-file/by-profile
{:permits 1 :queue 5 :timeout 60000}
:process-font/global
{:permits 4 :timeout 60000}
{:permits 4 :queue 10 :timeout 60000}
:process-font/by-profile
{:permits 1 :timeout 60000}
{:permits 1 :queue 5 :timeout 60000}
:process-image/global
{:permits 8 :timeout 60000}
{:permits 8 :queue 20 :timeout 60000}
:process-image/by-profile
{:permits 1 :timeout 60000}
{:permits 1 :queue 5 :timeout 60000}
:auth/global
{:permits 8 :timeout 30000}
{:permits 8 :queue 20 :timeout 30000}
:root/global
{:permits 40 :timeout 30000}
{:permits 40 :queue 100 :timeout 30000}
:root/by-profile
{:permits 10 :queue 30 :timeout 30000}
:file-thumbnail-ops/global
{:permits 20 :timeout 60000}
{:permits 20 :queue 50 :timeout 60000}
:file-thumbnail-ops/by-profile
{:permits 2 :timeout 60000}
{:permits 2 :queue 10 :timeout 60000}
:submit-audit-events/by-profile
{:permits 1 :queue 3 :timeout 30000}
:restore-file-snapshot/global
{:permits 3 :timeout 60000}
{:permits 3 :queue 5 :timeout 60000}
:restore-file-snapshot/by-profile
{:permits 1 :queue 2 :timeout 60000}
:create-file-snapshot/global
{:permits 3 :timeout 60000}
{:permits 3 :queue 5 :timeout 60000}
:create-file-snapshot/by-profile
{:permits 1 :queue 2 :timeout 60000}
:send-user-feedback/global
{:permits 4 :timeout 30000}
{:permits 4 :queue 10 :timeout 30000}
:send-user-feedback/by-profile
{:permits 1 :queue 3 :timeout 30000}
:import-binfile/global
{:permits 4 :timeout 60000}
{:permits 4 :queue 10 :timeout 60000}
:import-binfile/by-profile
{:permits 1 :queue 2 :timeout 60000}
:create-import-binfile-job/global
{:permits 4 :timeout 60000}
{:permits 4 :queue 10 :timeout 60000}
:create-import-binfile-job/by-profile
{:permits 1 :queue 2 :timeout 60000}
:profile-plugin-ops/global
{:permits 4 :timeout 30000}
:profile-plugin-ops/by-profile
{:permits 1 :queue 2 :timeout 30000}}

1
backend/scripts/_env
View File

@ -92,6 +92,7 @@ export JAVA_OPTS="\
-XX:+UseShenandoahGC \
-XX:+UseCompactObjectHeaders \
-XX:ShenandoahGCMode=generational \
-XX:NativeMemoryTracking=summary \
-XX:-OmitStackTraceInFastThrow \
--sun-misc-unsafe-memory-access=allow \
--enable-preview \

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

@ -239,24 +239,30 @@
(defn- migrate-file
[{:keys [::db/conn] :as cfg} {:keys [read-only?]} {:keys [id] :as file}]
(binding [pmap/*load-fn* (partial fdata/load-pointer cfg id)
pmap/*tracked* (pmap/create-tracked)]
(let [libs (delay (get-resolved-file-libraries cfg file))
;; For avoid unnecesary overhead of creating multiple
;; pointers and handly internally with objects map in their
;; worst case (when probably all shapes and all pointers
;; will be readed in any case), we just realize/resolve them
;; before applying the migration to the file.
file (-> (fdata/realize cfg file)
(fmg/migrate-file libs))]
(fdata/with-tracked-pointers cfg id
(let [libs (delay (get-resolved-file-libraries cfg file))
;; Capture the pointer layout before realizing: the migration
;; runs on plain data, and unchanged positions must keep their
;; original fragment ids instead of being re-wrapped with new
;; ones on persist.
original (fdata/original-pointers (:data file))
objects-map-before? (contains? (:features file) "fdata/objects-map")
realized (-> (fdata/realize cfg file)
(fmg/migrate-file libs))
objects-map-added? (and (not objects-map-before?)
(contains? (:features realized) "fdata/objects-map"))]
(if (or read-only? (db/read-only? conn))
file
(do ;; When file is migrated, we break the rule of no
;; perform mutations on get operations and update the
;; file with all migrations applied
realized
(let [file (if objects-map-added?
realized
(fdata/reattach-unchanged original realized))]
;; When the file is migrated, we break the rule of not
;; performing mutations on get operations and update the file
;; with all migrations applied. The caller still receives the
;; realized file: the read contract is plain data.
(update-file! cfg file)
(fmigr/resolve-applied-migrations cfg file))))))
(fmigr/resolve-applied-migrations cfg realized))))))
(defn- get-file*
[{:keys [::db/conn] :as cfg} id
@ -281,7 +287,7 @@
(assert (db/connection? conn) "expected cfg with valid connection")
(when (and (not load-data?)
(or lock-for-share? lock-for-share? skip-locked?))
(or lock-for-share? lock-for-update? skip-locked?))
(throw (IllegalArgumentException. "locking is incompatible when `load-data?` is false")))
(let [sql
@ -683,7 +689,8 @@
"Make the file its own tokens source when its tokens source is not one
of the given library-ids, as happens when the library was deleted. The
tokens lib of the source is copied while the library still exists, even
if deleted; otherwise the tokens source and status are removed."
if deleted; otherwise the tokens source is removed and the file gets back
the tokens status kept aside for its own tokens lib, if any."
[cfg data library-ids]
(let [source-id (cfo/get-tokens-source data)]
(if (and (some? source-id)
@ -692,7 +699,7 @@
:include-deleted? true
:throw-if-not-exists? false)]
(cfo/absorb-tokens-lib data (:data library))
(dissoc data :tokens-source :tokens-status))
(cfo/detach-tokens-source data))
data)))
(defn embed-assets
@ -943,7 +950,12 @@
(let [library-ids (->> (get-file-libraries conn (:id file))
(map :id)
(cons (:id file)))
load-fn #(get-file cfg % :migrate? false)]
;; Fragment rows are file-local and callers bind the loader of
;; the file they work on, so each library realizes its pointers
;; here, with its own id, before anything walks its data.
load-fn (fn [library-id]
(->> (get-file cfg library-id :migrate? false)
(fdata/realize-pointers cfg)))]
(weak/loadable-weak-value-map library-ids load-fn {id file})))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -1079,12 +1091,13 @@
:else :detach-libraries))
(defn export-cfg
"The domain cfg of an export: the frozen set of files and how their
libraries are handled."
[cfg {:keys [ids export-type]}]
"The domain cfg of an export: the frozen set of files, how their
libraries are handled, and where the package is written."
[cfg {:keys [file-ids export-type output]}]
(-> cfg
(assoc ::ids ids)
(assoc ::export-type export-type)))
(assoc ::file-ids file-ids)
(assoc ::export-type export-type)
(assoc ::output output)))
(defn import-cfg
"The domain cfg of an import: the destination team/profile/project, the

71
backend/src/app/binfile/jobs.clj
View File

@ -5,7 +5,7 @@
;; Copyright (c) KALEIDOS SUBSIDIARY SL
(ns app.binfile.jobs
"The binfile work a job runs.
"The progress bridge of the binfile jobs.
A job has no SSE channel, so the `:progress` points that `bf.v1` and
`bf.v3` emit become `progress` events of the job through
@ -17,20 +17,15 @@
so the adapter holds no state between taps. The ids the taps carry are
not part of the job event contract.
The adapter checks that the job is still active before it starts, and
the beat checks it on every write: a job that was cancelled, or that
The handlers in `app.tasks.export-binfile` and
`app.tasks.import-binfile` run the core through `run` and
guard it with `check-active`: a job that was cancelled, or that
already reached a terminal state, raises an `:interrupt` right there on
the run thread, so the work stops at its next event point and the
transaction of its handler rolls back with it. A run whose last tap
happened before the interruption is discarded once it returns, which is
what makes that transaction roll back too."
(:require
[app.binfile.common :as bfc]
[app.binfile.v1 :as bf.v1]
[app.binfile.v3 :as bf.v3]
[app.common.exceptions :as ex]
[app.common.time :as ct]
[app.db :as db]
[app.jobs :as jobs]
[app.util.events :as events]))
@ -39,7 +34,7 @@
The substrate owns both the check and the error; this is the adapter's
entry point to it, used by the two handlers before their run and by the
tests."
tests. Answers with the cfg, so a handler can thread it."
[cfg context]
(jobs/check-active cfg (:id context)))
@ -98,10 +93,13 @@
(assoc :counters (cond-> (or outer-counters {})
(some? own) (assoc stage own))))))
(defn- with-progress
(defn run
"Run `f` with the progress taps of the core turned into milestones of the
job.
`f` is called with the cfg, so the adapter forwards what it receives
and a caller can pass the core directly.
Every tap is reported: the substrate throttles the durable events, and
a milestone that does not fit loses no information because the next one
carries the same state.
@ -117,55 +115,6 @@
:job-id job-id
:progress (milestone data))))]
(binding [events/*sink* sink]
(let [result (f)]
(let [result (f cfg)]
(check-active cfg context)
result))))
(defn export-files
"Export a set of files into `output` as part of a job, reporting
progress as job events."
[cfg context {:keys [ids export-type output]}]
(check-active cfg context)
(with-progress cfg context
#(bf.v3/export-files! (bfc/export-cfg cfg {:ids ids
:export-type export-type})
output)))
(defn- touch-project
"Mark the destination project as modified.
An import adds files, and the triggers of the schema only touch the
project on an update, so a project that just received files keeps its
old date and stays where it was in the list."
[cfg project-id]
(db/update! cfg :project
{:modified-at (ct/now)}
{:id project-id}
{::db/return-keys false}))
(defn import-files
"Import the package at `input` as part of a job, reporting progress as
job events. The package was read from the resource of the job, so the
caller resolves the destination team and the adapter only fixes what
the legacy RPC and a job must share.
Both formats answer with the same shape: the version 1 reader returns
the set of files it created, and the version 3 one returns a map that
already carries them together with the resolution of the libraries."
[cfg context {:keys [profile-id project-id team name input version]}]
(check-active cfg context)
(let [cfg (bfc/import-cfg cfg {:profile-id profile-id
:project-id project-id
:team team
:name name
:input input})]
(with-progress cfg context
#(let [result (case (int version)
1 (bf.v1/import-files! cfg)
3 (bf.v3/import-files! cfg)
(ex/raise :type :validation
:code :unsupported-version
:hint "unsupported binfile version"
:version version))]
(touch-project cfg project-id)
result))))

20
backend/src/app/binfile/v1.clj
View File

@ -329,13 +329,13 @@
[:v1/metadata :v1/files :v1/rels :v1/sobjects]))))
(defmethod write-section :v1/metadata
[{:keys [::output ::bfc/ids ::bfc/include-libraries] :as cfg}]
(if-let [fids (get-files cfg ids)]
[{:keys [::output ::bfc/file-ids ::bfc/include-libraries] :as cfg}]
(if-let [fids (get-files cfg file-ids)]
(let [lids (when include-libraries
(bfc/get-libraries cfg ids))
ids (into fids lids)]
(write-obj! output {:version cf/version :files ids})
(vswap! bfc/*state* assoc :files ids))
(bfc/get-libraries cfg file-ids))
file-ids (into fids lids)]
(write-obj! output {:version cf/version :files file-ids})
(vswap! bfc/*state* assoc :files file-ids))
(ex/raise :type :not-found
:code :files-not-found
:hint "unable to retrieve files for export")))
@ -689,12 +689,12 @@
`::bfc/embed-assets`: instead of including the libraries, embed in the
same file library all assets used from external libraries."
[{:keys [::bfc/ids] :as cfg} output]
[{:keys [::bfc/file-ids] :as cfg} output]
(dm/assert!
"expected a set of uuid's for `::bfc/ids` parameter"
(and (set? ids)
(every? uuid? ids)))
"expected a set of uuid's for `::bfc/file-ids` parameter"
(and (set? file-ids)
(every? uuid? file-ids)))
(dm/assert!
"expected instance of jio/IOFactory for `input`"

36
backend/src/app/binfile/v3.clj
View File

@ -454,14 +454,15 @@
(write-entry! output path encoded-status)))))
(defn- export-files
[{:keys [::bfc/ids ::bfc/export-type ::output] :as cfg}]
[{:keys [::bfc/file-ids ::bfc/export-type ::output] :as cfg}]
(let [original-ids ids
ids (into ids (when (= export-type :include-libraries) (bfc/get-libraries cfg ids)))
rels (if (= export-type :include-libraries)
(->> (bfc/get-files-rels cfg ids)
(mapv (juxt :file-id :library-file-id)))
[])
(let [original-ids file-ids
file-ids (into file-ids (when (= export-type :include-libraries)
(bfc/get-libraries cfg file-ids)))
rels (if (= export-type :include-libraries)
(->> (bfc/get-files-rels cfg file-ids)
(mapv (juxt :file-id :library-file-id)))
[])
;; Compute external libraries: referenced by original files but
;; not included in the export set. Only relevant for :link-later.
@ -486,11 +487,11 @@
(vswap! bfc/*state* assoc :files (d/ordered-map))
;; Write all the exporting files
(doseq [[index file-id] (d/enumerate ids)]
(doseq [[index file-id] (d/enumerate file-ids)]
(-> cfg
(assoc ::file-id file-id)
(with-outer-counter :files {:current (inc index)
:total (count ids)})
:total (count file-ids)})
(export-file)))
;; Write manifest file
@ -1384,24 +1385,25 @@
(defn export-files!
"Do the exportation of a specified file in custom penpot binary
format. There are some options available for customize the output:
format. The cfg carries what `bfc/export-cfg` froze: `::bfc/file-ids`
(the files to export), `::bfc/export-type` (how linked libraries are
handled) and `::bfc/output` (where the package is written).
`::bfc/export-type`: determines how linked libraries are handled.
Valid values:
`:include-libraries` (include linked libraries),
`::bfc/export-type` determines how linked libraries are handled.
Valid values: `:include-libraries` (include linked libraries),
`:merge-libraries` (embed library assets in the file),
`:detach-libraries` (treat assets as basic objects),
`:link-later` (preserve component metadata for relinking on import)."
[{:keys [::bfc/ids] :as cfg} output]
[{:keys [::bfc/file-ids ::bfc/output] :as cfg}]
(assert
(and (set? ids) (every? uuid? ids))
"expected a set of uuid's for `::bfc/ids` parameter")
(and (set? file-ids) (every? uuid? file-ids))
"expected a set of uuid's for `::bfc/file-ids` parameter")
(assert
(satisfies? jio/IOFactory output)
"expected instance of jio/IOFactory for `input`")
"expected instance of jio/IOFactory for `::bfc/output`")
(let [id (uuid/next)
tp (ct/tpoint)

1
backend/src/app/config.clj
View File

@ -206,6 +206,7 @@
[:allow-demo-users {:optional true} ::sm/boolean]
[:error-report-webhook {:optional true} :string]
[:user-feedback-destination {:optional true} :string]
[:mcp-feedback-email {:optional true} ::sm/email]
[:default-rpc-rlimit {:optional true} [::sm/vec :string]]
[:rpc-rlimit-config {:optional true} ::fs/path]

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

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

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

@ -48,11 +48,19 @@
AND fd.type = 'snapshot')
WHERE c.label IS NOT NULL")
;; `:migrations` is an ordered set everywhere (see `common.types.file`),
;; and `need-migration?`/`migrate` use set semantics on it: the pgarray
;; must never surface as a vector, where `contains?`/`set/difference`
;; would compare indexes instead of names.
(defn- decode-migrations
[value]
(into (d/ordered-set) (db/decode-pgarray value [])))
(defn- decode-snapshot
[snapshot]
(some-> snapshot
(-> (d/update-when :metadata fdata/decode-metadata)
(d/update-when :migrations db/decode-pgarray [])
(d/update-when :migrations decode-migrations)
(d/update-when :features db/decode-pgarray #{}))))
(def ^:private sql:get-minimal-file
@ -376,8 +384,13 @@
:snapshot-id (str (:id snapshot)))
;; In the same way, on reseting the file data, we need to restore
;; the applied migrations on the moment of taking the snapshot
(bfc/update-file! cfg file ::bfc/reset-migrations? true)
;; the applied migrations on the moment of taking the snapshot.
;; The snapshot data may hold shared pointer-mapped pages; the
;; loader stays bound while persisting so any page the encode
;; path does load keeps working (`enable-objects-map` skips the
;; unloaded ones).
(fdata/with-pointers cfg file-id
(bfc/update-file! cfg file ::bfc/reset-migrations? true))
;; FIXME: this should be separated functions, we should not have
;; inline sql here.
@ -441,7 +454,12 @@
(defn reduce-snapshots
"Process the file snapshots using efficient reduction; the file
reduction comes with all snapshots, including maked as deleted"
reduction comes with all snapshots, including maked as deleted.
Snapshot data may hold pointer-mapped pages, so the fragment loader
is bound while reducing: consumers that walk page content (media
refs, stats) transparently load fragments, consumers that only read
pointer ids never trigger a load."
[cfg file-id xform f init]
(let [conn (db/get-connection cfg)
xform (comp
@ -449,5 +467,6 @@
(map (partial fdata/decode-file-data cfg))
xform)]
(->> (db/plan conn [sql:get-snapshots file-id] {:fetch-size 1})
(transduce xform f init))))
(fdata/with-pointers cfg file-id
(->> (db/plan conn [sql:get-snapshots file-id] {:fetch-size 1})
(transduce xform f init)))))

7
backend/src/app/http.clj
View File

@ -19,6 +19,7 @@
[app.http.errors :as errors]
[app.http.link-preview :as-alias link-preview]
[app.http.management :as mgmt]
[app.http.mcp-oauth :as-alias mcp-oauth]
[app.http.middleware :as mw]
[app.http.security :as sec]
[app.http.session :as session]
@ -236,6 +237,7 @@
[::ws/routes schema:routes]
[::rpc/routes schema:routes]
[::oidc/routes schema:routes]
[::mcp-oauth/routes schema:routes]
[::assets/routes schema:routes]
[::link-preview/routes schema:routes]
[::debug/routes schema:routes]
@ -278,4 +280,7 @@
(::ws/routes cfg)
(::oidc/routes cfg)
(::rpc/routes cfg)]]))
(::rpc/routes cfg)]
;; OAuth owns form parsing, protocol JSON names and cross-origin handling;
;; it must not inherit the RPC transformations and session middleware above.
(::mcp-oauth/routes cfg)]))

74
backend/src/app/http/access_token.clj
View File

@ -14,14 +14,20 @@
[app.setup :as-alias setup]
[app.tokens :as tokens]))
(def mcp-token-issuer "urn:penpot:mcp-token")
(def ^:private valid-issuers
#{"access-token" mcp-token-issuer})
(defn decode-token
[cfg token]
(try
(tokens/verify cfg {:token token :iss "access-token"})
(catch Throwable cause
(l/trc :hint "exception on decoding token"
:token token
:cause cause))))
(let [claims (tokens/verify cfg {:token token})]
(when (contains? valid-issuers (:iss claims))
claims))
;; The cause is not logged because its data carries the token
(catch Throwable _
(l/trc :hint "exception on decoding token"))))
(def sql:get-token-data
"SELECT perms, profile_id, expires_at, type
@ -34,32 +40,48 @@
[pool claims]
(when-not (db/read-only? pool)
(when-let [token-id (get claims :tid)]
(some-> (db/exec-one! pool [sql:get-token-data token-id])
(update :perms db/decode-pgarray #{})))))
(let [token (db/exec-one! pool [sql:get-token-data token-id])
mcp-claims? (= mcp-token-issuer (:iss claims))
mcp-token? (= "mcp" (:type token))]
(when (and (= (:uid claims) (:profile-id token))
(= mcp-claims? mcp-token?))
(update token :perms db/decode-pgarray #{}))))))
(defn- wrap-authz
[handler {:keys [::db/pool]}]
(fn [request]
(let [{:keys [type claims]} (get request ::http/auth-data)]
(if (= :token type)
(let [{:keys [perms profile-id expires-at type]} (some->> claims (get-token-data pool))
token-id (get claims :tid)]
(handler (cond-> request
(some? perms)
(assoc ::perms perms)
(some? profile-id)
(assoc ::profile-id profile-id)
(some? expires-at)
(assoc ::expires-at expires-at)
(some? token-id)
(assoc ::id token-id)
(some? type)
(assoc ::type type))))
"Authenticate requests carrying an access token. Personal tokens need the
`access-tokens` flag. MCP tokens are restricted to specific commands, so
only RPC routes opt in (the RPC wrapper enforces those restrictions); they
need either the `mcp` or the `access-tokens` flag."
[handler {:keys [::db/pool ::allow-mcp]}]
(let [personal-enabled? (contains? cf/flags :access-tokens)
mcp-enabled? (and allow-mcp
(or personal-enabled?
(contains? cf/flags :mcp)))]
(fn [request]
(let [{:keys [type claims]} (get request ::http/auth-data)]
(if (and (= :token type)
(if (= mcp-token-issuer (:iss claims))
mcp-enabled?
personal-enabled?))
(let [{:keys [perms profile-id expires-at type]} (some->> claims (get-token-data pool))
token-id (get claims :tid)]
(handler (cond-> request
(some? perms)
(assoc ::perms perms)
(some? profile-id)
(assoc ::profile-id profile-id)
(some? expires-at)
(assoc ::expires-at expires-at)
(some? token-id)
(assoc ::id token-id)
(some? type)
(assoc ::type type))))
(handler request)))))
(handler request))))))
(def authz
{:name ::authz
:compile (fn [& _]
(when (contains? cf/flags :access-tokens)
(when (or (contains? cf/flags :access-tokens)
(contains? cf/flags :mcp))
wrap-authz))})

4
backend/src/app/http/assets.clj
View File

@ -100,7 +100,7 @@
headers (cond-> {"location" (str url)
"x-host" (cond-> host port (str ":" port))
"x-mtype" (-> obj meta :content-type)
"cache-control" (str "max-age=" (inst-ms cch-max-age))}
"cache-control" (str "max-age=" (ct/seconds cch-max-age))}
(not public?)
(assoc "content-disposition" "attachment"))]
{::yres/status 307
@ -115,7 +115,7 @@
bucket (:bucket mdata)
headers (cond-> {"x-accel-redirect" (:path purl)
"content-type" (:content-type mdata)
"cache-control" (str "max-age=" (inst-ms cch-max-age))}
"cache-control" (str "max-age=" (ct/seconds cch-max-age))}
(not (public-bucket? bucket))
(assoc "content-disposition" "attachment"))]
{::yres/status 204

13
backend/src/app/http/debug.clj
View File

@ -359,10 +359,11 @@
(let [path (tmp/tempfile :prefix "penpot.export." :min-age "30m")]
(with-open [output (io/output-stream path)]
(-> cfg
(assoc ::bfc/ids file-ids)
(assoc ::bfc/file-ids file-ids)
(assoc ::bfc/embed-assets embed?)
(assoc ::bfc/include-libraries libs?)
(bf.v3/export-files! output)))
(assoc ::bfc/output output)
(bf.v3/export-files!)))
(if clone?
(let [profile (profile/get-profile pool profile-id)
@ -784,8 +785,12 @@
(db/tx-run! (assoc cfg ::db/rollback true)
(fn [cfg]
(let [file (bfc/get-file cfg file-id)
libs (bfc/get-resolved-file-libraries cfg file-id)]
;; Validation walks every page and component, so the
;; file is read realized; the library map is built
;; from the file (not its id) and its own loader
;; resolves each library's pointers.
(let [file (bfc/get-file cfg file-id :realize? true)
libs (bfc/get-resolved-file-libraries cfg file)]
(if file
(let [errors (cfv/validate-file file libs)]
{::yres/status 200

353
backend/src/app/http/mcp_oauth.clj Normal file
View File

@ -0,0 +1,353 @@
;; 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.http.mcp-oauth
"MCP-specific OAuth authorization server.
The authorize endpoint stages a request; the existing Penpot session identifies
the user on the approval page. Approval creates a one-use code, and token
exchange returns the existing fixed MCP user token after verifying PKCE.
Client registration, login sessions, and authorization codes are distinct."
(:require
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
[app.http.errors :as errors]
[app.http.middleware :as mw]
[app.http.session :as session]
[app.mcp.oauth-clients :as clients]
[app.mcp.oauth-state :as state]
[app.rpc.commands.access-token :as access-token]
[app.util.json :as json]
[clojure.string :as str]
[integrant.core :as ig]
[yetti.request :as yreq]
[yetti.response :as yres])
(:import
java.io.InputStream
java.net.URI
java.net.URLDecoder
java.net.URLEncoder
java.nio.charset.StandardCharsets
java.util.Base64))
(defn issuer [] (str (cf/get-public-uri "api/mcp/oauth")))
(defn resource [] (str (cf/get-public-uri "mcp/stream")))
(defn authorization-metadata
"OAuth capabilities and endpoints advertised to MCP clients."
[]
{:issuer (issuer)
:authorization_endpoint (str (issuer) "/authorize")
:token_endpoint (str (issuer) "/token")
:registration_endpoint (str (issuer) "/register")
:response_types_supported ["code"]
:grant_types_supported ["authorization_code"]
:code_challenge_methods_supported ["S256"]
:token_endpoint_auth_methods_supported ["none" "client_secret_basic" "client_secret_post"]
:scopes_supported ["mcp"]
:authorization_response_iss_parameter_supported true
:client_id_metadata_document_supported true})
(defn resource-metadata
"Protected-resource metadata referenced by the MCP server's 401 challenge."
[]
{:resource (resource)
:authorization_servers [(issuer)]
:scopes_supported ["mcp"]
:bearer_methods_supported ["header"]
:resource_name "Penpot MCP"})
(defn- response
([body] (response 200 body))
([status body]
{::yres/status status
::yres/headers {"content-type" "application/json"
"cache-control" "no-store"
"pragma" "no-cache"
"referrer-policy" "no-referrer"}
::yres/body (json/encode-str body)}))
(defn- redirect
[url]
{::yres/status 303
::yres/headers {"location" url "cache-control" "no-store"
"referrer-policy" "no-referrer"}
::yres/body ""})
(defn- encode [^String value] (URLEncoder/encode value StandardCharsets/UTF_8))
(defn- decode
[^String value]
(try (URLDecoder/decode value StandardCharsets/UTF_8)
(catch IllegalArgumentException _ (clients/invalid! "invalid_request"))))
(defn- parse-form
"Bounded OAuth form/query parser preserving protocol parameter names.
Rejects duplicate keys so validation never depends on which value wins."
[query]
(when (> (count query) 16384) (clients/invalid! "invalid_request"))
(reduce (fn [result part]
(let [[key value] (str/split part #"=" 2)
key (keyword (decode key))]
(when (contains? result key) (clients/invalid! "invalid_request"))
(assoc result key (decode (or value "")))))
{}
(remove str/blank? (str/split (or query "") #"&"))))
(defn- read-body
[request content-type]
(when-not (str/starts-with? (or (yreq/get-header request "content-type") "") content-type)
(clients/invalid! "invalid_request"))
(with-open [^InputStream body (yreq/body request)]
(when-not body (clients/invalid! "invalid_request"))
(let [bytes (.readNBytes body 16385)]
(when (> (alength bytes) 16384) (clients/invalid! "invalid_request"))
(String. bytes StandardCharsets/UTF_8))))
(defn- append-query
[url params]
(str url (if (str/includes? url "?") "&" "?")
(str/join "&" (for [[key value] params :when (some? value)]
(str (encode (name key)) "=" (encode value))))))
(defn- limit!
[cfg request kind limit]
(when-not (state/allow-request! cfg kind (str (yreq/remote-addr request)) limit)
(clients/invalid! "temporarily_unavailable" 429)))
(defn- authorize
"Validate and stage an authorization request before user login or consent.
The browser receives only an opaque handle to the ten-minute Redis record."
[cfg request]
(limit! cfg request :authorize-rate 60)
(let [params (parse-form (yreq/query request))
client (clients/resolve-client cfg (:client_id params))
callback (:redirect_uri params)]
;; Never redirect until the client and its callback have been checked.
(when-not (clients/redirect-matches? client callback)
(clients/invalid! "invalid_request"))
(when-not (and (= "code" (:response_type params))
(= "S256" (:code_challenge_method params))
(string? (:code_challenge params))
(re-matches #"[A-Za-z0-9_-]{43}" (:code_challenge params))
(= "mcp" (get params :scope "mcp"))
(= (resource) (get params :resource (resource)))
(<= (count (:state params)) 2048))
(clients/invalid! "invalid_request"))
(let [handle (state/create! cfg :request
{:client-id (:client_id client)
:client-name (:client_name client)
:logo-uri (:logo_uri client)
:redirect-uri callback
:challenge (:code_challenge params)
:state (:state params)
:resource (resource)
:scope "mcp"}
600)]
(redirect (append-query (str (cf/get-public-uri))
{:screen "mcp-authorize" :request handle})))))
(defn- session-binding
"Profile and login-session identity used to bind one approval request."
[request]
(let [session (session/get-session request)]
(when-not (:profile-id session) (clients/invalid! "login_required" 401))
{:profile-id (str (:profile-id session))
:session-id (state/digest (str (:id session)))}))
(defn- approval-request
"Bind a pending request to its first authenticated session and return UI data.
Compare-and-replace prevents another session from taking over that request."
[cfg request]
(let [binding (session-binding request)
handle (:request (parse-form (yreq/query request)))
record (state/read! cfg :request handle)]
(when-not record (clients/invalid! "invalid_request"))
(let [value (:value record)]
(if (:session-id value)
(when-not (= binding (select-keys value [:profile-id :session-id]))
(clients/invalid! "access_denied" 403))
(state/replace! cfg :request handle record
(merge value binding {:csrf (state/random-secret)}))))
;; Another GET may have won the binding race. Read the winning record so
;; same-session retries share its CSRF value; other sessions cannot proceed.
(let [value (:value (state/read! cfg :request handle))]
(when-not (= binding (select-keys value [:profile-id :session-id]))
(clients/invalid! "invalid_request"))
(response (select-keys value [:client-id :client-name :logo-uri :csrf :scope])))))
(defn- same-origin?
[request]
(let [public (URI. (str (cf/get-public-uri)))
origin (str (.getScheme public) "://" (.getRawAuthority public))]
(= origin (yreq/get-header request "origin"))))
(defn- decision
"Accept one session-bound approval/denial and return the client callback.
Origin and CSRF checks protect the cookie-authenticated decision endpoint."
[cfg request]
(when-not (same-origin? request) (clients/invalid! "access_denied" 403))
(let [binding (session-binding request)
params (parse-form (read-body request "application/x-www-form-urlencoded"))
handle (:request params)
record (state/read! cfg :request handle)
value (:value record)]
(when-not (and record
(= binding (select-keys value [:profile-id :session-id]))
(state/secret= (:csrf value) (:csrf params))
(contains? #{"approve" "deny"} (:decision params)))
(clients/invalid! "invalid_request"))
;; Consume before provisioning: concurrent clicks must not issue two codes.
;; A later failure requires a fresh authorization attempt.
(when-not (state/consume! cfg :request handle record)
(clients/invalid! "invalid_request"))
(let [result (if (= "deny" (:decision params))
{:error "access_denied"}
(let [token (db/tx-run! cfg access-token/ensure-mcp-access!
(uuid/parse (:profile-id value)))
;; Retain the token row ID, never the fixed token itself.
code (state/create! cfg :code
(-> value
(dissoc :csrf :session-id :client-name)
(assoc :token-id (str (:id token))))
120)]
{:code code}))]
(response {:redirect-uri (append-query (:redirect-uri value)
(merge result {:state (:state value)
:iss (issuer)}))}))))
(defn- client-authentication
"Extract one OAuth client-authentication method, rejecting mixed credentials.
Basic credentials are form-decoded after splitting the decoded header."
[request params]
(let [header (yreq/get-header request "authorization")]
(if header
(do
(when (or (:client_secret params) (not (str/starts-with? header "Basic ")))
(clients/invalid! "invalid_client" 401))
(let [decoded (try (String. (.decode (Base64/getDecoder) (subs header 6))
StandardCharsets/UTF_8)
(catch IllegalArgumentException _
(clients/invalid! "invalid_client" 401)))
[id secret] (str/split decoded #":" 2)
id (decode id)]
(when (or (nil? secret)
(and (:client_id params) (not= id (:client_id params))))
(clients/invalid! "invalid_client" 401))
{:id id :secret (decode secret) :method "client_secret_basic"}))
{:id (:client_id params) :secret (:client_secret params)
:method (if (:client_secret params) "client_secret_post" "none")})))
(defn- token
"Exchange a code for the fixed MCP token after client and PKCE verification."
[cfg request]
(limit! cfg request :token-rate 120)
(let [params (parse-form (read-body request "application/x-www-form-urlencoded"))
auth (client-authentication request params)
record (state/read! cfg :code (:code params))
value (:value record)]
(when-not (= "authorization_code" (:grant_type params))
(clients/invalid! "unsupported_grant_type"))
;; Compare the exact client ID, not decoded metadata: a self-contained ID
;; edited after approval identifies a different client for this exchange.
(when-not (and record
(= (:id auth) (:client-id value))
(= (:redirect_uri params) (:redirect-uri value))
(= (:resource value) (get params :resource (:resource value)))
(string? (:code_verifier params))
(re-matches #"[A-Za-z0-9._~-]{43,128}" (:code_verifier params))
(state/secret= (:challenge value) (state/digest (:code_verifier params))))
(clients/invalid! "invalid_grant"))
;; Resolve again because an HTTPS metadata document may have changed
;; since approval; its current callback and authentication method apply.
(let [client (clients/resolve-client cfg (:id auth))]
(when-not (and (= (:method auth) (:token_endpoint_auth_method client))
(clients/redirect-matches? client (:redirect-uri value))
(or (= "none" (:method auth))
(and (string? (:secret auth))
(state/secret= (:secret-hash client)
(state/digest (:secret auth))))))
(clients/invalid! "invalid_client" 401)))
;; Validate before consuming so an invalid verifier/secret cannot burn the
;; code. Atomic consumption allows only one valid exchange to succeed.
(when-not (state/consume! cfg :code (:code params) record)
(clients/invalid! "invalid_grant"))
;; Regeneration deletes the old token row. Never substitute the profile's
;; latest token for the one this approval authorized, nor return it expired.
(let [row (db/exec-one! (::db/pool cfg)
[(str "SELECT token FROM access_token"
" WHERE id = ? AND profile_id = ? AND type = 'mcp'"
" AND (expires_at IS NULL OR expires_at > now())")
(uuid/parse (:token-id value))
(uuid/parse (:profile-id value))])]
(when-not row (clients/invalid! "invalid_grant"))
(response {:access_token (:token row) :token_type "Bearer" :scope "mcp"}))))
(defn- register
"Issue a self-contained client registration; does not grant user access."
[cfg request]
(limit! cfg request :registration-rate 10)
(let [body (read-body request "application/json")
metadata (try (json/decode body)
(catch Exception _ (clients/invalid! "invalid_request")))]
(response 201 (clients/register! cfg metadata))))
(defn- wrap-errors
"Answer every failure with an OAuth error body. Unexpected failures also go
through the shared HTTP error handler, only for its logging; these routes
never set request params, so codes and credentials stay out of the log."
[handler]
(fn [request]
(try (handler request)
(catch Exception cause
(let [{:keys [oauth-error status]} (ex-data cause)
status (or status (if (and oauth-error (not= oauth-error "temporarily_unavailable")) 400 503))]
(when-not oauth-error
(errors/handle cause request))
(cond-> (response status {:error (or oauth-error "temporarily_unavailable")})
(and (= status 401) (= oauth-error "invalid_client"))
(assoc-in [::yres/headers "www-authenticate"] "Basic realm=\"Penpot MCP\"")))))))
(defn- wrap-public
"CORS for discovery, registration and exchange without browser credentials.
Cookie-authenticated approval endpoints must not use this wrapper."
[handler]
(fn [request]
(let [response (if (= :options (yreq/method request))
{::yres/status 204}
(handler request))]
(update response ::yres/headers merge
{"access-control-allow-origin" "*"
"access-control-allow-methods" "GET, POST, OPTIONS"
"access-control-allow-headers" "Content-Type, Authorization"
"access-control-expose-headers" "WWW-Authenticate"}))))
(defn- endpoint
[cfg handler method public?]
{:handler (partial handler cfg)
:middleware (into (if public? [{:compile (constantly wrap-public)}] [])
[{:compile (constantly wrap-errors)} [mw/restrict-methods]])
:allowed-methods (cond-> #{method} public? (conj :options))})
;; OAuth endpoints parse forms and emit snake_case JSON independently of RPC
;; middleware. Only the approval UI endpoints require a Penpot login session.
(defmethod ig/init-key ::routes
[_ cfg]
[""
["/.well-known/oauth-authorization-server/api/mcp/oauth"
(endpoint cfg (fn [_ _] (response (authorization-metadata))) :get true)]
["/api/mcp/oauth"
["/resource" (endpoint cfg (fn [_ _] (response (resource-metadata))) :get true)]
["/authorize" (endpoint cfg authorize :get false)]
["/register" (endpoint cfg register :post true)]
["/token" (endpoint cfg token :post true)]
;; Error handling wraps the session middleware too, so its failures also
;; get OAuth error bodies and logging.
["" {:middleware [{:compile (constantly wrap-errors)}
[mw/auth {:cookie (partial session/decode-token cfg)}]
[session/authz cfg]]}
["/request" (endpoint cfg approval-request :get false)]
["/decision" (endpoint cfg decision :post false)]]]])

6
backend/src/app/jobs.clj
View File

@ -847,7 +847,8 @@
The interrupt is an internal signal, not an error: the caller is a task
that must stop the work in course. `heartbeat` calls this when one of
its writes finds the job gone, and a caller can also ask explicitly,
which is what the binfile adapter does before and after its run."
which is what the binfile adapter does before and after its run.
Answers with the cfg, so a caller can thread the check into its run."
[cfg job-id]
(let [job (get-job cfg job-id)]
(when-not (and (some? job) (contains? active-statuses (:status job)))
@ -855,7 +856,8 @@
:code :job-interrupted
:hint "the job is no longer active"
:job-id job-id
:status (or (:status job) "gone")))))
:status (or (:status job) "gone")))
cfg))
(defn heartbeat
"Keep a running job alive and, optionally, report its progress.

2
backend/src/app/loggers/audit/consumer_task.clj
View File

@ -213,6 +213,7 @@
"accept-team-invitation-from"
"add-member-to-organization"
"add-team-to-organization"
"assign-organization-attribute"
"auditlog-exported"
"auditlog-guide-downloaded"
"cancel-organization-invitation"
@ -253,6 +254,7 @@
"sso-config-tested"
"success-activate-organization-sso"
"success-apply-organization-sso-changes"
"unassign-organization-attribute"
"update-organization-invitation"
"update-organization-permissions"
"update-team-invitation"

15
backend/src/app/main.clj
View File

@ -22,6 +22,7 @@
[app.http.debug :as-alias http.debug]
[app.http.link-preview :as-alias http.link-preview]
[app.http.management :as mgmt]
[app.http.mcp-oauth :as-alias http.mcp-oauth]
[app.http.session :as session]
[app.http.websocket :as http.ws]
[app.jobs :as-alias jobs]
@ -94,6 +95,12 @@
::mdef/help "Saves that passed the revision check with a revn behind the stored head."
::mdef/type :counter}
:update-file-repair
{::mdef/name "penpot_rpc_update_file_repair_total"
::mdef/help "update-file auto-repair attempts by outcome (repaired or unrepaired)."
::mdef/labels ["outcome"]
::mdef/type :counter}
:rpc-main-timing
{::mdef/name "penpot_rpc_main_timing"
::mdef/help "RPC command method call timing for main"
@ -551,9 +558,17 @@
::http.debug/routes (ig/ref ::http.debug/routes)
::http.assets/routes (ig/ref ::http.assets/routes)
::http.link-preview/routes (ig/ref ::http.link-preview/routes)
::http.mcp-oauth/routes (ig/ref ::http.mcp-oauth/routes)
::http.ws/routes (ig/ref ::http.ws/routes)
::http.awsns/routes (ig/ref ::http.awsns/routes)}
::http.mcp-oauth/routes
{::db/pool (ig/ref ::db/pool)
::rds/pool (ig/ref ::rds/pool)
::setup/props (ig/ref ::setup/props)
::session/manager (ig/ref ::session/manager)
::http.client/client (ig/ref ::http.client/client)}
::http.link-preview/routes
{::db/pool (ig/ref ::db/pool)}

220
backend/src/app/mcp/oauth_clients.clj Normal file
View File

@ -0,0 +1,220 @@
;; 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.mcp.oauth-clients
"Client metadata from self-contained registrations or HTTPS documents.
Registration describes an application; it does not authorize a Penpot user.
Both sources resolve to the same metadata shape without a client database."
(:require
[app.http.client :as http]
[app.mcp.oauth-state :as state]
[app.util.cache :as cache]
[app.util.json :as json]
[clojure.string :as str])
(:import
java.io.InputStream
java.net.URI
java.util.Base64))
(defn invalid!
([error] (invalid! error 400))
([error status]
(throw (ex-info "MCP OAuth request rejected" {:oauth-error error :status status}))))
(defn uri
[value]
(when (and (string? value) (<= 1 (count value) 2048))
(try (URI. value) (catch Exception _ nil))))
(defn- loopback?
[^URI uri]
(and (= "http" (.getScheme uri))
(contains? #{"127.0.0.1" "[::1]" "localhost"} (.getHost uri))))
(defn redirect-uri?
[value]
(when-let [uri (uri value)]
(and (nil? (.getFragment uri))
(nil? (.getUserInfo uri))
(or (and (= "https" (.getScheme uri)) (some? (.getHost uri)))
(loopback? uri)
;; Native applications use a reverse-domain scheme.
(and (some? (.getScheme uri))
(str/includes? (.getScheme uri) ".")
(not (.isOpaque uri)))))))
(defn redirect-matches?
"Exact callback match, except for the port of loopback HTTP URLs.
Native applications may allocate a different local port for each login."
[registered requested]
(and (redirect-uri? requested)
(some (fn [value]
(or (= value requested)
(let [a (uri value)
b (uri requested)]
(and (loopback? a) (loopback? b)
(= (.getHost a) (.getHost b))
(= (.getRawPath a) (.getRawPath b))
(= (.getRawQuery a) (.getRawQuery b))))))
(:redirect_uris registered))))
(defn- logo-uri?
[value]
(when-let [uri (uri value)]
(and (= "https" (.getScheme uri))
(some? (.getHost uri))
(nil? (.getUserInfo uri))
(nil? (.getFragment uri)))))
(defn validate-metadata
"Validate untrusted metadata and retain the fields this server supports.
CIMD selects public-client authentication from the advertised methods;
dynamic registration also supports Basic and form-post client secrets."
[metadata cimd?]
(let [redirects (:redirect_uris metadata)
grants (get metadata :grant_types ["authorization_code"])
methods (if cimd?
(or (:token_endpoint_auth_methods_supported metadata)
[(get metadata :token_endpoint_auth_method "none")])
[(get metadata :token_endpoint_auth_method "client_secret_basic")])
method (if cimd? "none" (first methods))]
(when-not (and (map? metadata)
(vector? redirects) (<= 1 (count redirects) 20)
(every? redirect-uri? redirects)
(or (nil? (:client_name metadata))
(and (string? (:client_name metadata))
(<= 1 (count (:client_name metadata)) 200)))
;; Published metadata describes client capabilities across
;; servers. Extra grants do not require us to issue them.
(if cimd?
(and (vector? grants) (every? string? grants)
(some #{"authorization_code"} grants))
(= ["authorization_code"] grants))
(= ["code"] (get metadata :response_types ["code"]))
(or (nil? (:scope metadata)) (= "mcp" (:scope metadata)))
(if cimd?
(and (vector? methods) (some #{"none"} methods))
(contains? #{"none" "client_secret_basic" "client_secret_post"} method)))
(invalid! "invalid_client_metadata"))
(cond-> {:redirect_uris redirects
:grant_types ["authorization_code"]
:response_types ["code"]
:scope "mcp"
:token_endpoint_auth_method method}
(:client_name metadata) (assoc :client_name (:client_name metadata))
;; Logos are optional browser-loaded images. Ignore unusable URLs
;; instead of preventing authorization because of cosmetic metadata.
(logo-uri? (:logo_uri metadata)) (assoc :logo_uri (:logo_uri metadata)))))
(defn register!
"Issue a reusable client ID and, when applicable, a separate client secret.
No client record is stored. The public ID carries only the secret hash;
the random nonce distinguishes registrations with otherwise equal metadata."
[_cfg metadata]
(let [metadata (validate-metadata metadata false)
secret (when-not (= "none" (:token_endpoint_auth_method metadata))
(state/random-secret))
;; Omit fixed protocol values to keep IDs short; validation restores
;; them on resolution. The version prefix defines the payload format.
payload (cond-> (-> metadata
(dissoc :grant_types :response_types :scope)
(assoc :nonce (state/random-secret)))
secret (assoc :secret-hash (state/digest secret)))
id (str "penpot-mcp-v1."
(.encodeToString (.withoutPadding (Base64/getUrlEncoder))
(json/encode payload)))]
;; Enforce the resolver's size cap here rather than issue an unusable ID.
(when (> (count id) 2048)
(invalid! "invalid_client_metadata"))
(cond-> (assoc metadata :client_id id
:client_id_issued_at (quot (System/currentTimeMillis) 1000))
secret (assoc :client_secret secret :client_secret_expires_at 0))))
(defn- decode-client-id
[client-id]
;; Open registration accepts client-supplied metadata, not a trusted identity.
;; Changing these details changes the ID; codes are bound to the exact ID
;; approved by the user, so an edited ID cannot redeem an existing code.
(try
(let [[_ encoded] (re-matches #"penpot-mcp-v1\.([A-Za-z0-9_-]+)" client-id)
_ (when-not encoded (invalid! "invalid_client"))
payload (json/decode (.decode (Base64/getUrlDecoder) ^String encoded))
metadata (validate-metadata payload false)
nonce (:nonce payload)
secret-hash (:secret-hash payload)]
(when-not (and (string? nonce) (re-matches #"[A-Za-z0-9_-]{43}" nonce)
(if (= "none" (:token_endpoint_auth_method metadata))
(nil? secret-hash)
(and (string? secret-hash)
(re-matches #"[A-Za-z0-9_-]{43}" secret-hash))))
(invalid! "invalid_client"))
(cond-> (assoc metadata :client_id client-id)
secret-hash (assoc :secret-hash secret-hash)))
(catch Exception _
(invalid! "invalid_client"))))
(defonce ^:private metadata-cache
(cache/create :expire "1m" :max-size 256))
(defn- fetch-metadata
"Fetch a client's own HTTPS metadata document with bounded size and freshness.
The shared HTTP client checks SSRF targets and does not follow redirects."
[cfg client-id]
(let [response (http/req cfg {:method :get :uri client-id :timeout 5000
:headers {"accept" "application/json"}}
{:response-type :input-stream})]
(with-open [^InputStream body (:body response)]
(when-not (and (= 200 (:status response))
(str/starts-with? (get-in response [:headers "content-type"] "")
"application/json"))
(invalid! "invalid_client"))
;; Bound both bytes read and time spent receiving the response body.
(let [reader (future (.readNBytes body 65537))
bytes (deref reader 5000 ::timeout)]
(when (= ::timeout bytes)
(future-cancel reader)
(invalid! "invalid_client"))
(when (> (alength ^bytes bytes) 65536)
(invalid! "invalid_client"))
(let [metadata (json/decode bytes)
control (get-in response [:headers "cache-control"] "")
;; The local cache ceiling never extends the publisher's TTL.
;; Missing cache lifetime is treated as immediately stale.
max-age (some-> (re-find #"(?i)max-age=(\d+)" control) second parse-long)
ttl (if (re-find #"(?i)no-store|no-cache" control)
0
(min 60 (or max-age 0)))]
(when-not (= client-id (:client_id metadata))
(invalid! "invalid_client"))
{:client (assoc (validate-metadata metadata true) :client_id client-id)
:expires (+ (System/currentTimeMillis) (* ttl 1000))})))))
(defn resolve-client
"Resolve a client ID to validated metadata for authorization or exchange.
HTTPS IDs use the document cache; versioned IDs decode locally without
PostgreSQL or Redis. Neither form establishes user approval."
[cfg client-id]
(when-not (and (string? client-id) (<= 1 (count client-id) 2048))
(invalid! "invalid_client"))
(if-let [url (when (str/starts-with? client-id "https://") (uri client-id))]
(do
(when-not (and (.getHost url)
(nil? (.getUserInfo url))
(nil? (.getFragment url))
(not (str/blank? (.getPath url))))
(invalid! "invalid_client"))
(try
(let [cached (cache/get metadata-cache client-id)
entry (if (and cached (> (:expires cached) (System/currentTimeMillis)))
cached
(fetch-metadata cfg client-id))]
(when-not (identical? cached entry)
(cache/invalidate metadata-cache client-id)
(cache/get metadata-cache client-id (constantly entry)))
(:client entry))
(catch Exception _
(invalid! "invalid_client"))))
(decode-client-id client-id)))

5
backend/src/app/mcp/oauth_rate.lua Normal file
View File

@ -0,0 +1,5 @@
-- Copyright (c) KALEIDOS SUBSIDIARY SL
-- MPL-2.0
local count = redis.call('INCR', KEYS[1])
if count == 1 then redis.call('EXPIRE', KEYS[1], ARGV[1]) end
return {count}

105
backend/src/app/mcp/oauth_state.clj Normal file
View File

@ -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 app.mcp.oauth-state
"Temporary approval requests and authorization codes in Redis/Valkey.
Handles are opaque; tenant, record kind and handle hash form the key.
Mutations compare the exact record that the HTTP handler validated."
(:require
[app.config :as cf]
[app.redis :as rds]
[app.redis.script :as-alias script]
[app.util.json :as json])
(:import
java.nio.charset.StandardCharsets
java.security.MessageDigest
java.security.SecureRandom
java.util.Base64))
(defn random-secret
"32 random bytes encoded as a 43-character, unpadded base64url string."
[]
(let [bytes (byte-array 32)]
(.nextBytes (SecureRandom.) bytes)
(.encodeToString (.withoutPadding (Base64/getUrlEncoder)) bytes)))
(defn digest
"Unpadded base64url SHA-256 digest, also used for PKCE S256 challenges."
[^String value]
(-> (.digest (MessageDigest/getInstance "SHA-256")
(.getBytes value StandardCharsets/UTF_8))
(#(.encodeToString (.withoutPadding (Base64/getUrlEncoder)) %))))
(defn secret=
[a b]
(and (string? a) (string? b)
(MessageDigest/isEqual (.getBytes ^String a StandardCharsets/UTF_8)
(.getBytes ^String b StandardCharsets/UTF_8))))
(defn- state-key
[kind handle]
(str "penpot:" (cf/get :tenant) ":mcp-oauth:" (name kind) ":" (digest handle)))
(defn create!
"Store a new record for ttl seconds and return its random handle.
The handle is returned only after Redis confirms SET NX EX succeeded."
[cfg kind value ttl]
(let [handle (random-secret)
result (rds/run! cfg
(fn [{::rds/keys [conn]}]
(rds/set conn (state-key kind handle)
(json/encode-str value) {:ex ttl :nx true})))]
(when-not (= "OK" result)
(throw (ex-info "Unable to store OAuth state" {:oauth-error "temporarily_unavailable"})))
handle))
(defn read!
"Read an unexpired record, or nil for a missing/malformed handle.
Return both decoded :value for validation and original :raw for atomic
comparison; serializing the decoded map again is not an equivalent check."
[cfg kind handle]
(when (and (string? handle) (re-matches #"[A-Za-z0-9_-]{43}" handle))
(when-let [raw (rds/run! cfg (fn [{::rds/keys [conn]}]
(rds/get conn (state-key kind handle))))]
{:raw raw :value (json/decode raw)})))
(defn- compare-and-update!
"Atomically change only the exact record the caller read and validated.
Lua deletes for nil replacement, or replaces while preserving the TTL.
False means the record expired or another request changed/consumed it."
[cfg kind handle record replacement]
(let [result (rds/run! cfg
(fn [{::rds/keys [conn]}]
(rds/eval conn
{::script/name ::compare-and-update
::script/path "app/mcp/oauth_state.lua"
::script/keys [(state-key kind handle)]
::script/vals [(:raw record) (or replacement "")]})))]
(= [1] result)))
(defn consume!
"Delete a validated record once; true only for the request that consumes it."
[cfg kind handle record]
(compare-and-update! cfg kind handle record nil))
(defn replace!
"Replace a validated record without extending its original expiration."
[cfg kind handle record value]
(compare-and-update! cfg kind handle record (json/encode-str value)))
(defn allow-request!
"Limit requests per endpoint kind, tenant and remote address.
The one-minute window begins with the first request; subsequent requests
increment the count without extending that window."
[cfg kind remote-address limit]
(let [[count] (rds/run! cfg
(fn [{::rds/keys [conn]}]
(rds/eval conn
{::script/name ::rate
::script/path "app/mcp/oauth_rate.lua"
::script/keys [(state-key kind (or remote-address "unknown"))]
::script/vals [60]})))]
(and (number? count) (<= count limit))))

11
backend/src/app/mcp/oauth_state.lua Normal file
View File

@ -0,0 +1,11 @@
-- Copyright (c) KALEIDOS SUBSIDIARY SL
-- MPL-2.0
if redis.call('GET', KEYS[1]) ~= ARGV[1] then
return {0}
end
if ARGV[2] == '' then
redis.call('DEL', KEYS[1])
else
redis.call('SET', KEYS[1], ARGV[2], 'KEEPTTL')
end
return {1}

18
backend/src/app/rpc.clj
View File

@ -124,7 +124,8 @@
(cond-> (and (not (uuid? session-pid))
(uuid? token-pid))
(-> (assoc ::auth-type :token)
(assoc ::token-perms (set (::actoken/perms request #{})))))
(assoc ::token-perms (set (::actoken/perms request #{})))
(assoc ::token-type (::actoken/type request))))
(cond-> key-id
(assoc ::auth-key-id key-id))
;; Server-side only: request bodies cannot forge
@ -171,10 +172,12 @@
[_ f mdata]
(let [required-auth? (::auth mdata true)
required-auth-type (::auth-type mdata)
required-token-type (::token-type mdata)
required-perms (into #{} (::perms mdata))]
(fn [cfg params]
(let [profile-id (::profile-id params)
auth-type (::auth-type params)
token-type (::token-type params)
token-perms (set (::token-perms params #{}))]
(cond
(and required-auth? (not (uuid? profile-id)))
@ -182,8 +185,13 @@
:code :authentication-required
:hint "authentication required for this endpoint")
(and (= required-auth-type :token)
(not= auth-type :token))
(or (and (= required-auth-type :token)
(not= auth-type :token))
(and required-token-type
(or (not= auth-type :token)
(not= required-token-type token-type)))
(and (= token-type "mcp")
(not= required-token-type "mcp")))
(ex/raise :type :authorization
:code :token-auth-required
:hint "access token authentication required for this endpoint")
@ -522,7 +530,7 @@
{:middleware [[mw/cors]
[sec/client-header-check]
[session/authz cfg]
[actoken/authz cfg]]
[actoken/authz (assoc cfg ::actoken/allow-mcp true)]]
:handler (make-rpc-handler methods)}]
(doc/routes :methods methods
@ -540,5 +548,5 @@
{:middleware [[mw/cors]
[sec/client-header-check]
[session/authz cfg]
[actoken/authz cfg]]
[actoken/authz (assoc cfg ::actoken/allow-mcp true)]]
:handler (make-rpc-handler methods)}]])

174
backend/src/app/rpc/climit.clj
View File

@ -5,7 +5,16 @@
;; Copyright (c) KALEIDOS SUBSIDIARY SL
(ns app.rpc.climit
"Concurrencly limiter for RPC."
"Concurrencly limiter for RPC.
A command declares its limits in its `::climit/id` metadata and takes them
before the root ones, so a request waiting for its own limits does not hold
the root permits of its profile.
Every acquisition goes through this wrapper, so every path takes the
limiters in the same order. A command that calls another command from
inside its handler would take them twice: the second call waits for a
permit the first one holds, and answers 429 when the timeout runs out."
(:refer-clojure :exclude [run!])
(:require
[app.common.exceptions :as ex]
@ -221,16 +230,6 @@
(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 counters cache config handler]
(let [limit-id (::id config)
@ -249,69 +248,57 @@
: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)]
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)))]
(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))
(try
;; The increment lives inside the `try`, so a throwable from the
;; publishing path unwinds through the `finally`: the count comes back
;; down instead of staying up for good.
(waiting-inc metrics counters limit-name)
(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)))]
(let [stats (pbh/get-stats limiter)]
(log limit "enqueued" req-id stats nil nil nil))
(.add held limiter)
(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))))
(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)
(catch ExceptionInfo cause
(let [{:keys [type code] :as data} (ex-data cause)]
(if (= :bulkhead-error type)
(let [elapsed (tpoint)
stats (pbh/get-stats limiter)]
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))))
(log limit "finished" req-id stats elapsed nil nil))))))))
(finally
(stop-waiting)
(let [elapsed (tpoint)
stats (pbh/get-stats limiter)]
(log limit "finished" req-id stats elapsed nil nil))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; MIDDLEWARE
@ -340,6 +327,16 @@
:else
(throw (IllegalArgumentException. "unable to normalize limit")))))
(defn- resolve-limit-key
"The key of a limit, resolved the same way in every path: a keyword is
looked up in the params, a function is applied to them, any other value is
the key itself."
[key params]
(cond
(keyword? key) (get params key)
(fn? key) (key params)
:else key))
(defn wrap
[cfg handler {label ::sv/name :as mdata}]
(if-let [climit (::rpc/climit cfg)]
@ -363,7 +360,7 @@
(fn [cfg params]
(let [config (-> config
(assoc ::key (key-fn params))
(assoc ::key (resolve-limit-key key-fn params))
(assoc ::label label)
;; NOTE: only used for debugging output
(assoc ::params params))]
@ -373,40 +370,11 @@
(l/wrn :hint "no config found for specified queue" :id (id->str limit-id))
handler)))
handler
;; 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))
;; The root limiters go first so they end up innermost: a command
;; takes the limits it declares before the root ones. Every path
;; meets the limiters in the same order, because every acquisition
;; goes through this wrapper.
(concat global-limits (get-limits mdata)))
handler))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PUBLIC API
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- build-exec-chain
[{:keys [::label ::rpc/climit] :as cfg} f]
(reduce (fn [handler [limit-id limit-key]]
(if-let [config (get-config climit limit-id)]
(let [config (-> config
(assoc ::key limit-key)
(assoc ::label label))]
(fn [cfg params]
(let [config (assoc config ::params params)]
(invoke climit config (partial handler cfg params)))))
(do
(l/wrn :hint "config not found" :label label :id limit-id)
f)))
f
(get-limits cfg)))
(defn invoke!
"Run a function in context of climit."
[{:keys [::rpc/climit] :as cfg} f params]
(let [f (if climit
(build-exec-chain cfg f)
f)]
(f cfg params)))

37
backend/src/app/rpc/commands/access_token.clj
View File

@ -6,12 +6,15 @@
(ns app.rpc.commands.access-token
(:require
[app.common.exceptions :as ex]
[app.common.schema :as sm]
[app.common.time :as ct]
[app.common.uuid :as uuid]
[app.db :as db]
[app.http.access-token :as actoken]
[app.main :as-alias main]
[app.rpc :as-alias rpc]
[app.rpc.commands.profile :as profile]
[app.rpc.doc :as-alias doc]
[app.rpc.quotes :as quotes]
[app.setup :as-alias setup]
@ -28,16 +31,27 @@
AND id != ?
AND type = 'mcp'")
(def ^:private sql:get-valid-mcp-token
"SELECT * FROM access_token
WHERE profile_id = ?
AND type = 'mcp'
AND (expires_at IS NULL OR expires_at > now())
ORDER BY created_at DESC
LIMIT 1")
(defn create-access-token
"Create an access token with empty perms.
Elevated permissions (e.g. error-reports:read) are not assignable via
the public API; grant them with SQL or `repl:grant-access-token-perm`."
[{:keys [::db/conn] :as cfg} profile-id name expiration type]
;; Serialize regeneration with OAuth provisioning for the same profile.
(when (= type "mcp")
(db/get-by-id conn :profile profile-id {::db/for-update true}))
(let [token-id (uuid/next)
expires-at (some-> expiration (ct/in-future))
created-at (ct/now)
token-iss (if (= type "mcp") "urn:penpot:mcp-token" "access-token")
token-iss (if (= type "mcp") actoken/mcp-token-issuer "access-token")
token (tokens/generate cfg {:iss token-iss
:uid profile-id
:iat created-at
@ -62,6 +76,27 @@
(decode-row token)))
(defn ensure-mcp-access!
"Enable MCP and return the profile's unexpired token, creating it if absent.
Must run in a transaction. Lock the profile even when no token exists, so
concurrent approvals and settings regeneration use the same lock. Enabling
MCP must not regenerate a token already held by a connected client; an
expired token is replaced because no client can use it, and so is a token
issued before MCP tokens had their own issuer, or one this instance cannot
decrypt, because the backend rejects both."
[{:keys [::db/conn] :as cfg} profile-id]
(let [profile (profile/get-profile conn profile-id ::db/for-update true)
token (db/exec-one! conn [sql:get-valid-mcp-token profile-id])
;; A token this instance cannot decrypt is as unusable as an expired one
token (when (= actoken/mcp-token-issuer
(ex/ignoring (:iss (tokens/decode cfg (:token token)))))
token)]
(when-not (:mcp-enabled (:props profile))
(profile/update-profile-props cfg profile-id {:mcp-enabled true}))
(if token
(decode-row token)
(create-access-token cfg profile-id "MCP" nil "mcp"))))
(defn repl:create-access-token
[cfg profile-id name expiration]
(db/tx-run! cfg create-access-token profile-id name expiration))

53
backend/src/app/rpc/commands/binfile.clj
View File

@ -50,9 +50,10 @@
(let [output (tmp/tempfile*)]
(try
(-> (bfc/export-cfg cfg {:ids #{file-id}
:export-type (bfc/resolve-export-type params)})
(bf.v3/export-files! output))
(-> (bfc/export-cfg cfg {:file-ids #{file-id}
:export-type (bfc/resolve-export-type params)
:output output})
(bf.v3/export-files!))
(let [data (sto/content output)
object (sto/put-object! storage
@ -126,6 +127,35 @@
result))
(defn- prepare-import-event
"Build the audit event of an import. The RPC layer cannot emit it
because the import runs later, inside the SSE response, and the
event must carry the ids of the files it creates."
[params manifest]
(-> (audit/event-from-rpc-params params)
(assoc :type "command")
(assoc :name "import-binfile")
(assoc :props (-> params
(dissoc :file)
(assoc :generated-by (:generated-by manifest))
(assoc :referer (:referer manifest))
(audit/clean-props)))
(assoc ::webhooks/event? true)))
(defn- import-binfile-and-audit
[cfg params event]
(try
(let [result (import-binfile cfg params)
file-ids (:file-ids result)]
(audit/submit cfg (update event :props assoc
:file-ids (vec file-ids)
:file-count (count file-ids)
:status "completed"))
result)
(catch Throwable cause
(audit/submit cfg (assoc-in event [:props :status] "failed"))
(throw cause))))
(def ^:private schema:import-binfile
[:and
[:map {:title "import-binfile" :closed true}
@ -151,6 +181,7 @@
["2.15" "Add upload-id param for chunked upload support"]]
::webhooks/event? true
::audit/skip true
::sse/stream? true
::sm/params schema:import-binfile
::rpc/multipart-only-params [:file]
@ -168,10 +199,6 @@
:binfile-v1 1
:binfile-v3 3))
params (-> params
(assoc :profile-id profile-id)
(assoc :version version))
manifest
(case (int version)
1 nil
@ -179,10 +206,10 @@
(throw (ex-info (str "Unsupported binfile version: " version)
{:type :validation
:code :unsupported-version
:version version})))]
:version version})))
(with-meta
(sse/response (partial import-binfile cfg params))
{::audit/props {:file nil
:generated-by (:generated-by manifest)
:referer (:referer manifest)}})))
params (assoc params :version version)
event (prepare-import-event params manifest)
params (assoc params :profile-id profile-id)]
(sse/response (partial import-binfile-and-audit cfg params event))))

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

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

48
backend/src/app/rpc/commands/feedback.clj
View File

@ -13,11 +13,57 @@
[app.config :as cf]
[app.db :as db]
[app.email :as eml]
[app.loggers.audit :as-alias audit]
[app.rpc :as-alias rpc]
[app.rpc.climit :as-alias climit]
[app.rpc.commands.profile :as profile]
[app.rpc.doc :as-alias doc]
[app.util.services :as sv]))
[app.rpc.helpers :as rph]
[app.util.services :as sv]
[clojure.string :as str]))
(def schema:send-mcp-feedback
[:map {:title "send-mcp-feedback" :closed true}
[:subject [:and [:string {:min 1 :max 120}]
[:fn #(and (not (str/blank? %))
(not (re-find #"\p{Cc}" %)))]]]
;; Line breaks and tabs are the only control characters allowed
[:feedback [:and [:string {:min 1 :max 5000}]
[:fn #(and (not (str/blank? %))
(not (re-find #"[\p{Cc}&&[^\t\n\r]]" %)))]]]])
(sv/defmethod ::send-mcp-feedback
{::rpc/token-type "mcp"
::db/transaction true
::doc/added "2.20"
::sm/params schema:send-mcp-feedback}
[cfg {:keys [::rpc/profile-id subject feedback]}]
(let [profile (profile/get-profile cfg profile-id)
destination (cf/get :mcp-feedback-email)]
;; Blocking a profile invalidates its sessions but not its access tokens
(when (:is-blocked profile)
(ex/raise :type :authorization
:code :profile-blocked
:hint "profile is marked as blocked"))
(when-not (:is-active profile)
(ex/raise :type :authorization
:code :profile-not-active
:hint "profile is not active"))
(when (str/blank? destination)
(ex/raise :type :restriction
:code :feedback-disabled
:hint "MCP feedback is not configured"))
(eml/send cfg {::eml/reuse-conn true
:to destination
:reply-to (:email profile)
:subject (str "[MCP feedback] " subject)
:body {"text/plain" (str "Submitted by: " (:fullname profile)
" <" (:email profile) ">\n"
"Profile ID: " (:id profile) "\n\n"
"Feedback:\n\n" feedback)}})
;; The audit event keeps who sent feedback, not its text
(rph/with-meta {:status "queued"}
{::audit/replace-props {}})))
(declare ^:private send-user-feedback!)

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

@ -431,7 +431,7 @@
(cfeat/check-client-features! (:features params))
(cfeat/check-file-features! (:features file)))
page (binding [pmap/*load-fn* (partial feat.fdata/load-pointer cfg file-id)]
page (feat.fdata/with-pointers cfg file-id
(let [page (dm/get-in file [:data :pages-index resolved-page-id])]
(if (pmap/pointer-map? page)
(deref page)
@ -561,7 +561,7 @@
calculate-from-db
(fn []
(let [file (bfc/get-file cfg id)
result (binding [pmap/*load-fn* (partial feat.fdata/load-pointer cfg id)]
result (feat.fdata/with-pointers cfg id
(calculate-library-summary file))]
(-> file
(assoc :library-summary result)
@ -685,7 +685,7 @@
(defn- get-file-stats
[{:keys [::db/conn] :as cfg} file-id]
(let [file (bfc/get-file cfg file-id)
base (binding [pmap/*load-fn* (partial feat.fdata/load-pointer cfg file-id)]
base (feat.fdata/with-pointers cfg file-id
(cfs/calc-file-stats (:data file)))
lib-cnt (get-file-stats-library-counts conn file-id)]
(-> base
@ -774,7 +774,7 @@
(bfc/check-file-exists cfg file-id)
(check-read-permissions! cfg profile-id file-id)
(let [{:keys [data]} (bfc/get-file cfg file-id)]
(binding [pmap/*load-fn* (partial feat.fdata/load-pointer cfg file-id)]
(feat.fdata/with-pointers cfg file-id
(when-let [tokens-lib (cfo/get-tokens-lib data)]
(ctob/export-dtcg-json tokens-lib (cfo/get-tokens-status data))))))
@ -993,8 +993,7 @@
(assert (db/connection-map? cfg)
"expected cfg with valid connection")
(binding [pmap/*load-fn* (partial feat.fdata/load-pointer cfg file-id)
pmap/*tracked* (pmap/create-tracked)]
(feat.fdata/with-tracked-pointers cfg file-id
(let [file (-> (bfc/get-file cfg file-id
:include-deleted? true
:lock-for-update? true)
@ -1009,6 +1008,7 @@
:file-id (str file-id))
(bfc/update-file! cfg {:id file-id
:features (:features file)
:migrations (:migrations file)
:revn (inc (:revn file))
:data (:data file)
@ -1418,38 +1418,46 @@
WHERE file_id = ANY(?::uuid[])")
(def ^:private sql:restore-storage-objects
"WITH ids AS (SELECT unnest(?::uuid[]) AS file_id)
UPDATE storage_object
;; Collect referenced storage ids first (UUID set), then join by PK.
;; Casting `storage_object.id` to text (or OR-ing that with `id IN`) forces
;; a scan of deleted rows; cast the JSON side instead.
"WITH ids AS (SELECT unnest(?::uuid[]) AS file_id),
refs AS (
SELECT fmo.media_id AS 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 fmo.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
UNION
SELECT (fd.metadata->>'storage-ref-id')::uuid
FROM file_data AS fd
JOIN ids ON (ids.file_id = fd.file_id)
WHERE fd.deleted_at IS NULL
AND (fd.metadata->>'storage-ref-id') IS NOT NULL
)
UPDATE storage_object AS so
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))")
FROM refs
WHERE so.id = refs.id
AND so.deleted_at IS NOT NULL")
(defn- restore-files
[conn file-ids]

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

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

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

@ -9,10 +9,12 @@
[app.binfile.common :as bfc]
[app.common.exceptions :as ex]
[app.common.features :as-alias cfeat]
[app.common.files.migrations :as fmg]
[app.common.schema :as sm]
[app.common.time :as ct]
[app.db :as db]
[app.db.sql :as-alias sql]
[app.features.fdata :as fdata]
[app.features.file-snapshots :as fsnap]
[app.features.logical-deletion :as ldel]
[app.main :as-alias main]
@ -53,7 +55,7 @@
::sm/params schema:get-file-snapshot
::sm/result files/schema:file-with-permissions
::db/transaction true}
[cfg {:keys [::rpc/profile-id file-id id] :as params}]
[cfg {:keys [::rpc/profile-id file-id id features] :as params}]
(let [perms (perms/get-file-read-permissions cfg profile-id file-id)]
(files/check-read-permissions! perms)
(let [snapshot (fsnap/get-snapshot cfg file-id id)]
@ -66,12 +68,41 @@
;; Load current file metadata only (no data decoding) then overlay
;; the snapshot data so the client receives the same shape as a
;; normal get-file response but with historical page/object content.
(let [base-file (bfc/get-file cfg file-id :load-data? false)]
;; Snapshots may hold pointer-mapped pages shared with the live
;; file, so materialize them here: the preview UI applies the
;; response straight into state and cannot resolve pointers.
;; NOTE: the loader binds the live file-id, not the snapshot id.
;;
;; A snapshot taken while a migration was pending stores the old
;; format. Apply the pending migrations in memory, the same pure
;; step a normal read runs, and never persist them: the stored
;; version keeps its data and restoring it re-migrates on the
;; next read. `decode-snapshot` hands an ordered set, which is
;; what `need-migration?`/`migrate` require; a stored NULL is
;; regenerated from the snapshot's version.
(let [base-file (bfc/get-file cfg file-id :load-data? false)
snapshot (assoc snapshot :id file-id)
file (if (fmg/need-migration? snapshot)
(let [file (fdata/realize cfg snapshot)]
(fmg/migrate-file
file
(delay (bfc/get-resolved-file-libraries cfg file))))
(update snapshot :data
#(fdata/realize-pointers cfg file-id %)))
;; Works like in `get-file`: a client that does not declare
;; `fdata/objects-map` gets plain objects. The historical
;; feature set is deliberately not checked against the
;; enabled one: a version may predate a feature change.
file (if (and (contains? (:features file) "fdata/objects-map")
(not (contains? features "fdata/objects-map")))
(fdata/realize-objects cfg file)
file)]
(-> base-file
(assoc :data (:data snapshot))
(assoc :version (:version snapshot))
(assoc :features (:features snapshot))
(assoc :revn (:revn snapshot))
(assoc :data (:data file))
(assoc :version (:version file))
(assoc :features (:features file))
(assoc :migrations (:migrations file))
(assoc :revn (:revn file))
(assoc :vern (rand-int 100000))
(assoc :permissions perms))))))
@ -84,10 +115,22 @@
{::doc/added "1.20"
::sm/params schema:create-file-snapshot
::climit/id [[:create-file-snapshot/by-profile ::rpc/profile-id]
[:create-file-snapshot/global]]}
[:create-file-snapshot/global]]
::db/transaction true}
[cfg {:keys [::rpc/profile-id file-id label]}]
(files/check-edition-permissions! cfg profile-id file-id)
(let [file (bfc/get-file cfg file-id :realize? true)
;; NOTE: the file is intentionally NOT realized here: the snapshot
;; shares fragment rows with the live file (same as automatic
;; snapshots) instead of storing a materialized copy. file-gc treats
;; every unpurged snapshot as a liveness root, and readers
;; (get-file-snapshot, restore!, reduce-snapshots) resolve pointers
;; on demand.
;; NOTE: the file is read with FOR SHARE inside this transaction so
;; snapshot creation serializes with a concurrent :file-gc pass
;; (which takes FOR UPDATE + SKIP LOCKED on the same row). Without
;; the lock, a version pinned mid-pass could reference fragment rows
;; the pass is recreating.
(let [file (bfc/get-file cfg file-id :lock-for-share? true)
project (db/get-by-id cfg :project (:project-id file))]
(-> cfg
@ -115,37 +158,50 @@
[:restore-file-snapshot/global]]}
[{:keys [::db/pool ::mbus/msgbus] :as cfg} {:keys [::rpc/profile-id ::rpc/session-id file-id id] :as params}]
;; Check permissions and read current file state (short-lived, outside restore transaction)
;; Check permissions
(files/check-edition-permissions! pool profile-id file-id)
(let [file (bfc/get-file cfg file-id)
team (teams/get-team pool
(let [team (teams/get-team pool
:profile-id profile-id
:file-id file-id)
delay (ldel/get-deletion-delay team)
file-revn (:revn file)]
;; Create backup snapshot of the current state (committed immediately
;; independently of the restore outcome)
(fsnap/create! cfg file
{:profile-id profile-id
:deleted-at (ct/in-future delay)
:created-by "system"})
;; Create backup snapshot of the current state (committed immediately
;; independent of the restore outcome). The read takes FOR SHARE so a
;; concurrent :file-gc pass (which holds FOR UPDATE + SKIP LOCKED on the
;; file row) either finishes first -- and we snapshot the new fragments --
;; or skips the file and retries later. Without the lock, the backup
;; could reference fragments the pass is about to mark as deleted,
;; breaking the backup permanently.
;;
;; The backup read also provides the revn the guard below compares
;; against. An edit committed before this read is captured in the
;; backup and no longer aborts the restore; only edits committed
;; after the backup conflict.
backup-revn
(db/tx-run! cfg
(fn [cfg]
(let [file (bfc/get-file cfg file-id :lock-for-share? true)]
(fsnap/create! cfg file
{:profile-id profile-id
:deleted-at (ct/in-future delay)
:created-by "system"})
(:revn file))))]
;; Restore snapshot inside its own transaction; the revn check
;; ensures no data is lost if the file was edited concurrently
(db/tx-run! cfg
(fn [{:keys [::db/conn] :as cfg}]
(let [current (bfc/get-minimal-file conn file-id {::db/for-update true})]
(when (not= (:revn current) file-revn)
(when (not= (:revn current) backup-revn)
(ex/raise :type :conflict
:code :file-modified
:hint "the file was modified during the restore process, please retry")))
(let [vern (fsnap/restore! cfg file-id id)]
(mbus/pub! msgbus
:topic (:id file)
:topic file-id
:message {:type :file-restored
:session-id session-id
:file-id (:id file)
:file-id file-id
:vern vern})
nil)))))

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

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

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

@ -12,6 +12,7 @@
[app.common.features :as cfeat]
[app.common.files.changes :as cpc]
[app.common.files.migrations :as fmg]
[app.common.files.repair :as cfr]
[app.common.files.validate :as val]
[app.common.logging :as l]
[app.common.schema :as sm]
@ -41,6 +42,7 @@
(declare ^:private get-lagged-changes)
(declare ^:private send-notifications!)
(declare ^:private send-repair-notifications)
(declare ^:private update-file)
(declare ^:private update-file*)
(declare ^:private process-changes-and-validate)
@ -164,6 +166,25 @@
(nil? (:validate-schema-ms timings)) "referential"
:else "schema"))
;; Not a real editor session: file-change messages with this id are
;; delivered to every connected session, including the saver.
(def repair-session-id
#uuid "a11c0de5-0000-4000-8000-000000000001")
(defn- referential-integrity-error?
[cause]
(= :referential-integrity (:code (ex-data cause))))
(defn- record-repair-outcome
[cfg outcome]
(record-metric! cfg {:id :update-file-repair
:labels [(name outcome)]
:inc 1}))
(defn- error-codes
[errors]
(into [] (keep :code) errors))
;; If features are specified from params and the final feature
;; set is different than the persisted one, update it on the
;; database.
@ -274,7 +295,9 @@
:soft-validate-affected-ms (get timings :soft-validate-affected-ms)
:soft-validate-schema-ms (get timings :soft-validate-schema-ms)
:validate-affected-ms (get timings :validate-affected-ms)
:validate-schema-ms (get timings :validate-schema-ms)))))
:validate-schema-ms (get timings :validate-schema-ms)
:repair-ms (get timings :repair-ms)
:reprocess-changes-ms (get timings :reprocess-changes-ms)))))
(catch Throwable cause
;; NOTE: `with-defer` hooks only run on the success path
;; (`handle-response`), so timings collected before a hard
@ -294,7 +317,9 @@
:soft-validate-affected-ms (get timings :soft-validate-affected-ms)
:soft-validate-schema-ms (get timings :soft-validate-schema-ms)
:validate-affected-ms (get timings :validate-affected-ms)
:validate-schema-ms (get timings :validate-schema-ms)))
:validate-schema-ms (get timings :validate-schema-ms)
:repair-ms (get timings :repair-ms)
:reprocess-changes-ms (get timings :reprocess-changes-ms)))
(throw cause))))))
(defn- update-file*
@ -308,8 +333,7 @@
[{:keys [::db/conn ::timestamp] :as cfg}
{:keys [profile-id file team features changes session-id skip-validate] :as params}]
(binding [pmap/*tracked* (pmap/create-tracked)
pmap/*load-fn* (partial fdata/load-pointer cfg (:id file))]
(fdata/with-tracked-pointers cfg (:id file)
(let [file (assoc file :features
(-> features
@ -328,27 +352,65 @@
changes skip-validate))
deleted-at
(ct/plus timestamp (ct/duration {:hours 1}))]
(ct/plus timestamp (ct/duration {:hours 1}))
(when-let [file (::snapshot file)]
(let [deleted-at (ct/plus timestamp (ldel/get-deletion-delay team))
label (str "internal/snapshot/" revn)]
repair
(::repair file)
(fsnap/create! cfg file
{:label label
snapshot-deleted-at
(ct/plus timestamp (ldel/get-deletion-delay team))
change-created-at
(cond-> timestamp
repair
(ct/plus (ct/duration {:millis 1})))]
(if repair
(let [snapshot-file (or (::snapshot file)
(fdata/realize cfg (:original repair)))]
(fsnap/create! cfg snapshot-file
{:label (str "internal/repair/" revn)
:created-by "system"
:deleted-at deleted-at
:deleted-at snapshot-deleted-at
:profile-id profile-id
:session-id repair-session-id}))
(when-let [file (::snapshot file)]
(fsnap/create! cfg file
{:label (str "internal/snapshot/" revn)
:created-by "system"
:deleted-at snapshot-deleted-at
:profile-id profile-id
:session-id session-id})))
(when repair
(db/insert! conn :file-change
{:id (uuid/next)
:session-id repair-session-id
:profile-id profile-id
:created-at timestamp
:updated-at timestamp
:deleted-at deleted-at
:file-id (:id file)
:revn (:revn repair)
:version (:version file)
:features (into-array (:features file))
:changes (blob/encode (:changes repair))}
{::db/return-keys false})
(l/wrn :hint "file auto-repaired"
:file-id (str (:id file))
:error-codes (error-codes (:errors repair))
:error-count (count (:errors repair))
:change-count (count (:changes repair)))
(record-repair-outcome cfg :repaired))
;; Insert change (xlog) with deleted_at in a future data for
;; make them automatically eleggible for GC once they expires
(db/insert! conn :file-change
{:id (uuid/next)
:session-id session-id
:profile-id profile-id
:created-at timestamp
:updated-at timestamp
:created-at change-created-at
:updated-at change-created-at
:deleted-at deleted-at
:file-id (:id file)
:revn (:revn file)
@ -357,12 +419,14 @@
:changes (blob/encode changes)}
{::db/return-keys false})
(persist-file! cfg file)
(persist-file! cfg (dissoc file ::repair))
(when (contains? cf/flags :redis-cache)
(invalidate-caches! cfg file))
;; Send asynchronous notifications
(when repair
(send-repair-notifications cfg params file repair))
(send-notifications! cfg params file)
(with-meta {:revn revn :lagged (get-lagged-changes conn params)}
@ -416,11 +480,13 @@
(rds/del conn key)))))
(defn- attach-snapshot
"Attach snapshot data to the file. This should be called before the
upcoming file operations are applied to the file."
[cfg migrated? file]
(let [snapshot (if migrated? file (fdata/realize cfg file))]
(assoc file ::snapshot snapshot)))
"Attach snapshot data to the file. Snapshots share fragment rows with
the live file, so the snapshot is kept as-is (with pointers); it is
NOT realized/materialized here. The file-gc liveness set unions main
and snapshots, so shared fragments survive while any of them needs
them."
[file]
(assoc file ::snapshot file))
(defn- update-file-data!
"Perform a file data transformation in with all update context setup.
@ -428,8 +494,9 @@
This function expected not-decoded file and transformation function. Returns
an encoded file.
This function is not responsible of saving the file. It only saves
fdata/pointer-map modified fragments."
This function is not responsible of saving the file. Fragment rows are
persisted later by `persist-file!` (via `bfc/update-file!` inside the
same transaction); nothing is written to `file_data` here."
[cfg {:keys [id] :as file} update-fn & args]
(let [file (update file :data (fn [data]
@ -444,6 +511,11 @@
take-snapshot?
(take-snapshot? file)
;; Attach the snapshot before migrating: a migration can rebuild a
;; page and give its PointerMap a new id with `modified?` set, and a
;; snapshot taken after that would keep the very pointer the save
;; then rewrites, ending up with post-save content.
;;
;; For avoid unnecesary overhead of creating multiple
;; pointers and handly internally with objects map in their
;; worst case (when probably all shapes and all pointers
@ -454,11 +526,11 @@
;; need-migration?
;; (->> (fdata/realize cfg))
need-migration?
(fmg/migrate-file libs)
take-snapshot?
(->> (attach-snapshot cfg need-migration?)))]
(->> (attach-snapshot))
need-migration?
(fmg/migrate-file libs))]
(apply update-fn cfg file args)))
@ -534,9 +606,105 @@
:shape-id (some-> error :shape-id str)
:cause cause)))))
(defn- apply-changes
[cfg file changes]
(let [state (atom {})
file (binding [cpc/*state* state]
(-> file
(update :data cpc/process-changes changes)
(update :data d/without-nils)))]
(if-let [media-refs (-> @state :media-refs not-empty)]
(bfc/update-media-references! cfg file media-refs)
file)))
(defn- fail-repair
[cfg file errors cause]
(l/wrn :hint "file auto-repair did not recover the file"
:file-id (str (:id file))
:error-codes (error-codes errors)
:error-count (count errors))
(record-repair-outcome cfg :unrepaired)
(throw cause))
(defn- repair-preexisting-damage
"Repair damage that was already in `original` on the pages/components
the client's `changes` touch, then re-apply those changes. Throws
`cause` when the client's changes are at fault or the repair cannot
fix the file."
[cfg original libs changes tracked tracked-0 cause]
(let [libs (or libs {})]
(try
(let [pre-errors
(binding [pmap/*tracked* nil]
(val/validate-file-affected original libs changes))]
(when (empty? pre-errors)
(throw cause))
(when tracked
(reset! tracked tracked-0))
(let [trepair (ct/tpoint)
result
(try
(binding [pmap/*tracked* tracked]
(cfr/repair-file-until-valid
original libs
(fn [file applied]
(binding [pmap/*tracked* nil]
(val/validate-file-affected file libs (into applied changes))))
:initial-errors pre-errors))
(finally
(record-validation-timing cfg :repair-ms "repair" (inst-ms (trepair)))))
repair-changes (:changes result)]
(when (seq (:errors result))
(fail-repair cfg original (:errors result) cause))
(let [treprocess (ct/tpoint)
repaired (try
(binding [pmap/*tracked* tracked]
(apply-changes cfg (:file result) changes))
(finally
(record-validation-timing cfg :reprocess-changes-ms "reprocess-changes"
(inst-ms (treprocess)))))
scope (into repair-changes changes)]
(binding [pmap/*tracked* nil]
(val/validate-file-affected! repaired libs scope)
(when (contains? cf/flags :file-schema-validation)
(let [t (ct/tpoint)]
(try
(val/validate-file-schema! repaired)
(finally
(record-validation-timing cfg :validate-schema-ms "validate-schema" (inst-ms (t))))))))
(-> repaired
(assoc :revn (+ (:revn original) 2))
(assoc ::repair {:changes repair-changes
:errors pre-errors
:revn (inc (:revn original))
:original (dissoc original ::snapshot)})))))
(catch Throwable inner
(if (identical? inner cause)
(throw cause)
(do
(l/wrn :hint "file auto-repair failed"
:file-id (str (:id original))
:cause inner)
(record-repair-outcome cfg :unrepaired)
(throw cause)))))))
(defn- process-changes-and-validate
[cfg file changes skip-validate]
(let [should-resolve-libs?
(let [original file
tracked pmap/*tracked*
tracked-0 (some-> tracked deref)
should-resolve-libs?
(and (or (contains? cf/flags :file-validation)
(contains? cf/flags :soft-file-validation))
(not skip-validate))
@ -552,35 +720,22 @@
(when should-resolve-libs?
(record-validation-timing cfg :resolve-libs-ms "resolve-libs" (inst-ms (tlibs))))))
;; The main purpose of this atom is provide a contextual state
;; for the changes subsystem where optionally some hints can
;; be provided for the changes processing. Right now we are
;; using it for notify about the existence of media refs when
;; a new shape is added.
state
(atom {})
tproc
(ct/tpoint)
file
(try
(let [file
(binding [cpc/*state* state]
(-> (files/check-version! file)
(update :revn inc)
(update :data cpc/process-changes changes)
(update :data d/without-nils)))
file
(if-let [media-refs (-> @state :media-refs not-empty)]
(bfc/update-media-references! cfg file media-refs)
file)]
file)
(apply-changes cfg
(-> (files/check-version! file)
(update :revn inc))
changes)
(finally
(record-validation-timing cfg :process-changes-ms "process-changes" (inst-ms (tproc)))))]
(record-validation-timing cfg :process-changes-ms "process-changes" (inst-ms (tproc)))))
(binding [pmap/*tracked* nil]
pending-repair
(atom nil)]
(fdata/with-untracked
(when (contains? cf/flags :soft-file-validation)
(let [t (ct/tpoint)]
(try
@ -600,18 +755,25 @@
(let [t (ct/tpoint)]
(try
(val/validate-file-affected! file libs changes)
(catch Throwable cause
(reset! pending-repair cause)
(when-not (referential-integrity-error? cause)
(throw cause)))
(finally
(record-validation-timing cfg :validate-affected-ms "validate-affected" (inst-ms (t)))))))
(when (and (contains? cf/flags :file-schema-validation)
(not skip-validate))
(not skip-validate)
(nil? @pending-repair))
(let [t (ct/tpoint)]
(try
(val/validate-file-schema! file)
(finally
(record-validation-timing cfg :validate-schema-ms "validate-schema" (inst-ms (t))))))))
file))
(if-let [cause @pending-repair]
(repair-preexisting-damage cfg original libs changes tracked tracked-0 cause)
file)))
(defn- take-snapshot?
"Defines the rule when file `data` snapshot should be saved."
@ -641,6 +803,34 @@
(mapv (fn [row]
(update row :changes blob/decode)))))
(defn- send-repair-notifications
[cfg {:keys [team session-id] :as params} file repair]
(let [changes (:changes repair)
lchanges (filter library-change? changes)
msgbus (::mbus/msgbus cfg)]
(mbus/pub! msgbus
:topic (:id file)
:message {:type :file-change
:profile-id (:profile-id params)
:file-id (:id file)
:session-id repair-session-id
:revn (:revn repair)
:vern (:vern file)
:changes changes
:repaired true})
(when (and (:is-shared file) (seq lchanges))
(mbus/pub! msgbus
:topic (:id team)
:message {:type :library-change
:profile-id (:profile-id params)
:file-id (:id file)
:session-id session-id
:revn (:revn repair)
:modified-at (ct/now)
:changes lchanges}))))
(defn- send-notifications!
[cfg {:keys [team changes session-id] :as params} file]
(let [lchanges (filter library-change? changes)

13
backend/src/app/rpc/commands/media.clj
View File

@ -239,6 +239,8 @@
(sv/defmethod ::create-file-media-object-from-url
{::doc/added "1.17"
::doc/changes [["2.19" "The optional :id param is rejected with a params-validation error; the server always generates the identifier"]]
::climit/id [[:process-image/by-profile ::rpc/profile-id]
[:process-image/global]]
::sm/params schema:create-file-media-object-from-url}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id file-id] :as params}]
(files/check-edition-permissions! pool profile-id file-id)
@ -262,16 +264,7 @@
(assoc :from-url? true)
(assoc :content content)
(assoc :name (d/nilv name "unknown")))]
;; NOTE: we use the climit here in a dynamic invocation because we
;; don't want saturate the process-image limit with IO (download
;; of external image)
(-> cfg
(assoc ::climit/id [[:process-image/by-profile (:profile-id params)]
[:process-image/global]])
(assoc ::climit/label "create-file-media-object-from-url")
(climit/invoke! #(db/run! %1 create-file-media-object %2) params))))
(db/run! cfg create-file-media-object params)))
;; --- Clone File Media object (Upload and create from url)

6
backend/src/app/rpc/commands/plugins.clj
View File

@ -34,8 +34,7 @@
(sv/defmethod ::add-profile-plugin
{::doc/added "2.18"
::climit/id [[:profile-plugin-ops/by-profile ::rpc/profile-id]
[:profile-plugin-ops/global]]
::climit/id [[:profile-plugin-ops/by-profile ::rpc/profile-id]]
::sm/params schema:add-profile-plugin
::sm/result ctp/schema:registry-entry
::db/transaction true}
@ -69,8 +68,7 @@
(sv/defmethod ::remove-profile-plugin
{::doc/added "2.18"
::climit/id [[:profile-plugin-ops/by-profile ::rpc/profile-id]
[:profile-plugin-ops/global]]
::climit/id [[:profile-plugin-ops/by-profile ::rpc/profile-id]]
::sm/params schema:remove-profile-plugin
::sm/result :nil
::db/transaction true}

15
backend/src/app/rpc/commands/profile.clj
View File

@ -306,6 +306,8 @@
(sv/defmethod ::update-profile-photo
{:doc/added "1.1"
::climit/id [[:process-image/by-profile ::rpc/profile-id]
[:process-image/global]]
::sm/params schema:update-profile-photo
::rpc/multipart-only-params [:file]
::sm/result :nil}
@ -355,13 +357,12 @@
:content-type (:mtype thumb)}))
(defn upload-photo
[{:keys [::sto/storage] :as cfg} {:keys [file] :as params}]
(let [params (-> cfg
(assoc ::climit/id [[:process-image/by-profile (:profile-id params)]
[:process-image/global]])
(assoc ::climit/label "upload-photo")
(climit/invoke! generate-thumbnail file))]
(sto/put-object! storage params)))
"Generate the thumbnail of a photo and store it.
The caller declares the `process-image` limits: this helper runs inside
them, so a command that calls it has to take them."
[{:keys [::sto/storage] :as cfg} {:keys [file]}]
(sto/put-object! storage (generate-thumbnail cfg file)))
;; --- MUTATION: Delete Photo

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

@ -27,6 +27,7 @@
[app.msgbus :as mbus]
[app.nitrate :as nitrate]
[app.rpc :as-alias rpc]
[app.rpc.climit :as-alias climit]
[app.rpc.commands.profile :as profile]
[app.rpc.doc :as-alias doc]
[app.rpc.helpers :as rph]
@ -1094,6 +1095,8 @@
(sv/defmethod ::update-team-photo
{::doc/added "1.17"
::climit/id [[:process-image/by-profile ::rpc/profile-id]
[:process-image/global]]
::sm/params schema:update-team-photo
::rpc/multipart-only-params [:file]}
[cfg {:keys [::rpc/profile-id file] :as params}]

51
backend/src/app/rpc/management/nitrate.clj
View File

@ -17,7 +17,7 @@
[app.common.time :as ct]
[app.common.types.organization :as cto]
[app.common.types.profile :refer [schema:profile, schema:basic-profile]]
[app.common.types.team :refer [schema:team]]
[app.common.types.team :as ctt :refer [schema:team]]
[app.common.uri :as u]
[app.common.uuid :as uuid]
[app.config :as cf]
@ -562,6 +562,55 @@ RETURNING id, deleted_at;")
(db/exec! conn [sql:get-organization-member-team-counts ids-array])))))))
;; ---- API: get-organization-member-teams
(def ^:private sql:get-organization-member-teams
"SELECT t.id, t.name, t.photo_id,
CASE WHEN tpr.is_owner THEN 'owner'
WHEN tpr.is_admin THEN 'admin'
WHEN tpr.can_edit THEN 'editor'
ELSE 'viewer'
END AS role
FROM team_profile_rel AS tpr
JOIN team AS t ON t.id = tpr.team_id
WHERE tpr.profile_id = ?
AND t.id = ANY(?)
AND t.deleted_at IS NULL
AND t.is_default IS FALSE;")
(def ^:private schema:get-organization-member-teams-params
[:map
[:profile-id ::sm/uuid]
[:team-ids [:or ::sm/uuid [:vector ::sm/uuid]]]])
(def ^:private schema:get-organization-member-teams-result
[:vector [:map
[:id ::sm/uuid]
[:name ::sm/text]
[:photo-url {:optional true} ::sm/uri]
[:role ctt/schema:role]]])
(sv/defmethod ::get-organization-member-teams
"Get the non-default teams a profile belongs to within a set of teams,
with the profile's role in each one."
{::doc/added "2.18"
::sm/params schema:get-organization-member-teams-params
::sm/result schema:get-organization-member-teams-result
::nitrate/sso false}
[cfg {:keys [profile-id team-ids]}]
(let [team-ids (if (uuid? team-ids) [team-ids] team-ids)]
(if (empty? team-ids)
[]
(db/run! cfg (fn [{:keys [::db/conn]}]
(let [ids-array (db/create-array conn "uuid" team-ids)]
(->> (db/exec! conn [sql:get-organization-member-teams profile-id ids-array])
(mapv (fn [{:keys [photo-id role] :as row}]
(cond-> (-> row
(dissoc :photo-id)
(assoc :role (keyword role)))
photo-id (assoc :photo-url (files/resolve-public-uri photo-id))))))))))))
;; API: invite-to-organization
(defn- get-invitation-organization

83
backend/src/app/srepl/main.clj
View File

@ -170,6 +170,89 @@
(db/get-update-count)
(pos?)))))))
(defn update-profile-email!
"Support helper: change a profile's email address.
Looks up the profile by its current email. Rejects with
`:email-already-exists` when the new address is already used by
another non-deleted profile. Does not clear bounce/complaint
reports; call `clear-email-complaint-reports!` for that."
[& {:keys [email new-email]}]
(assert (string? email) "expected email")
(assert (string? new-email) "expected new-email")
(let [email (profile/clean-email email)
new-email (profile/clean-email new-email)]
(db/tx-run! sys/system
(fn [{:keys [::db/conn] :as system}]
(let [profile (profile/get-profile-by-email conn email)]
(when-not profile
(ex/raise :type :not-found
:code :profile-not-found
:hint "profile not found for email"
:email email))
(if (= email new-email)
:unchanged
(do
(when (profile/get-profile-by-email conn new-email)
(ex/raise :type :validation
:code :email-already-exists))
(db/update! conn :profile
{:email new-email}
{:id (:id profile)}
{::db/return-keys false})
(audit/insert system
{:name "update-profile-email"
:type "action"
:props {:id (:id profile)
:email email
:new-email new-email}
:context {:triggered-by "srepl"
:cause "explicit call to update-profile-email!"}})
:updated)))))))
(defn clear-email-complaint-reports!
"Support helper: delete bounce and complaint reports for an email
from `global_complaint_report` and, when a profile owns that email,
from `profile_complaint_report`. Also unmutes that profile so mail
can be sent again after a false-positive bounce or complaint."
[email]
(assert (string? email) "expected email")
(let [email (profile/clean-email email)]
(db/tx-run! sys/system
(fn [{:keys [::db/conn] :as system}]
(let [profile (db/get* conn :profile {:email email})
global-deleted
(-> (db/delete! conn :global-complaint-report {:email email})
(db/get-update-count))
profile-deleted
(if profile
(-> (db/delete! conn :profile-complaint-report
{:profile-id (:id profile)})
(db/get-update-count))
0)]
(when profile
(db/update! conn :profile
{:is-muted false}
{:id (:id profile)}
{::db/return-keys false}))
(when (or profile (pos? global-deleted))
(audit/insert system
{:name "clear-email-complaint-reports"
:type "action"
:props (cond-> {:email email
:global-deleted global-deleted
:profile-deleted profile-deleted}
profile (assoc :id (:id profile)))
:context {:triggered-by "srepl"
:cause "explicit call to clear-email-complaint-reports!"}})
:cleared))))))
(defn parse-emails
"Parse the emails into a seq of cleaned emails. Accepts a single
email, a comma separated list of emails or a coll of emails.

45
backend/src/app/srepl/procs/file_repair.clj
View File

@ -6,7 +6,6 @@
(ns app.srepl.procs.file-repair
(:require
[app.common.files.changes :as cfc]
[app.common.files.repair :as cfr]
[app.common.files.validate :as cfv]
[app.common.logging :as l]))
@ -17,44 +16,28 @@
(defn repair-file
"Internal helper for validate and repair the file. The operation is
applied multiple times untile file is fixed or max iteration counter
applied multiple times until file is fixed or max iteration counter
is reached (default 10).
This function should not be used directly, it is used throught the
This function should not be used directly, it is used through the
app.srepl.main/repair-file! helper. In practical terms this function
is private and implementation detail."
[file libs & {:keys [max-iterations] :or {max-iterations 10}}]
(let [validate-and-repair
(fn [file libs iteration]
(when-let [errors (not-empty (cfv/validate-file file libs))]
(l/trc :hint "repairing file"
:file-id (str (:id file))
:iteration iteration
:errors (count errors))
(let [changes (cfr/repair-file file libs errors)]
(-> file
(update :revn inc)
(update :data cfc/process-changes changes)))))
(let [orig-revn (:revn file)
result (cfr/repair-file-until-valid
file libs
(fn [file _]
(cfv/validate-file file libs))
:max-iterations max-iterations)
file' (update (:file result) :revn (fnil + 0) (:iterations result))]
process-file
(fn [file libs]
(loop [file file
iteration 0]
(if (< iteration max-iterations)
(if-let [file (validate-and-repair file libs iteration)]
(recur file (inc iteration))
file)
(do
(l/wrn :hint "max retry num reached on repairing file"
:file-id (str (:id file))
:iteration iteration)
file))))
(when (>= (:iterations result) max-iterations)
(l/wrn :hint "max retry num reached on repairing file"
:file-id (str (:id file))
:iteration (:iterations result)))
file'
(process-file file libs)]
(when (not= (:revn file) (:revn file'))
(when (not= orig-revn (:revn file'))
(l/trc :hint "file repaired" :file-id (str (:id file))))
file'))

19
backend/src/app/tasks/export_binfile.clj
View File

@ -8,7 +8,9 @@
"The `:export-binfile` job: it produces the `.penpot` artifact of the
set of files frozen in its params."
(:require
[app.binfile.common :as bfc]
[app.binfile.jobs :as bfj]
[app.binfile.v3 :as bf.v3]
[app.common.schema :as sm]
[app.db :as db]
[app.jobs :as jobs]
@ -64,14 +66,17 @@
(doseq [file-id file-ids]
(files/check-read-permissions! cfg profile-id file-id))
(let [output (tmp/tempfile* :suffix ".penpot")]
(let [output (tmp/tempfile* :suffix ".penpot")
cfg (bfc/export-cfg cfg {:file-ids file-ids
:export-type (:export-type params)
:output output})]
(try
(bfj/export-files cfg context {:ids file-ids
:export-type (:export-type params)
:output output})
(let [resource (js/put-resource cfg profile-id
(assoc artifact :content (sto/content output)))]
{:result (check-result (dissoc resource :resource-id))
(bfj/check-active cfg context)
(bfj/run cfg context bf.v3/export-files!)
(let [resource (->> (assoc artifact :content (sto/content output))
(js/put-resource cfg profile-id))
result (check-result (dissoc resource :resource-id))]
{:result result
:resource-id (:resource-id resource)})
(finally
(fs/delete output))))))

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

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

74
backend/src/app/tasks/import_binfile.clj
View File

@ -8,9 +8,13 @@
"The `:import-binfile` job: it imports the package the job owns as a
resource into the project frozen in its params."
(:require
[app.binfile.common :as bfc]
[app.binfile.jobs :as bfj]
[app.binfile.v1 :as bf.v1]
[app.binfile.v3 :as bf.v3]
[app.common.exceptions :as ex]
[app.common.schema :as sm]
[app.common.time :as ct]
[app.db :as db]
[app.jobs :as jobs]
[app.jobs.storage :as js]
@ -101,6 +105,18 @@
:type :validation
:code :invalid-result))
(defn- touch-project
"Mark the destination project as modified.
An import adds files, and the triggers of the schema only touch the
project on an update, so a project that just received files keeps its
old date and stays where it was in the list."
[cfg project-id]
(db/update! cfg :project
{:modified-at (ct/now)}
{:id project-id}
{::db/return-keys false}))
(defn execute-import
"Plain handler, importable and testable without integrant.
@ -124,32 +140,38 @@
(try
(projects/check-edition-permissions! cfg profile-id project-id)
(let [team (or (teams/get-team cfg
:profile-id profile-id
:project-id project-id)
(ex/raise :type :not-found
:code :project-not-found
:hint "the destination project is not available"
:profile-id profile-id
:project-id project-id))
result (db/tx-run! cfg
(fn [tx-cfg]
;; the core joins this transaction: it
;; is the one that decides whether the
;; whole import is kept or rolled back
(check-result
(assoc (bfj/import-files tx-cfg context
{:profile-id profile-id
:project-id project-id
:team team
:name (:name params)
:input input
:version (:version params)})
:name (:name params)
:version (:version params)))))]
result)
(let [team (or (teams/get-team cfg
:profile-id profile-id
:project-id project-id)
(ex/raise :type :not-found
:code :project-not-found
:hint "the destination project is not available"
:profile-id profile-id
:project-id project-id))]
(db/tx-run! cfg (fn [tx-cfg]
;; the core joins this transaction: it
;; is the one that decides whether the
;; whole import is kept or rolled back
(-> (bfc/import-cfg tx-cfg {:profile-id profile-id
:project-id project-id
:team team
:name (:name params)
:input input})
(bfj/check-active context)
(bfj/run context
(fn [cfg]
(let [result (case (int (:version params))
1 (bf.v1/import-files! cfg)
3 (bf.v3/import-files! cfg)
(ex/raise :type :validation
:code :unsupported-version
:hint "unsupported binfile version"
:version (:version params)))]
(touch-project cfg project-id)
result)))
(assoc :name (:name params))
(assoc :version (:version params))
(check-result)))))
(finally
(fs/delete input)
(js/release-input cfg context)))))

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

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

112
backend/test/backend_tests/binfile_jobs_test.clj
View File

@ -10,6 +10,7 @@
(:require
[app.binfile.common :as bfc]
[app.binfile.jobs :as bfj]
[app.binfile.v1 :as v1]
[app.binfile.v3 :as v3]
[app.common.time :as ct]
[app.common.uuid :as uuid]
@ -59,6 +60,37 @@
[job-id]
(jobs/make-context (jobs/get-job th/*system* job-id)))
(defn- run-export!
"Run an export through the adapter, as the job handler does: the
frozen cfg in, the progress out as job events."
[cfg context file-ids export-type output]
(let [cfg (bfc/export-cfg cfg {:file-ids file-ids
:export-type export-type
:output output})]
(bfj/check-active cfg context)
(bfj/run cfg context v3/export-files!)))
(defn- run-import!
"Run an import through the adapter, as the job handler does: the
frozen cfg in, the progress out as job events. The project touch
stays in the handler, covered by its own tests."
[cfg context {:keys [profile-id project-id team name input version]}]
(bfj/check-active cfg context)
(let [cfg (bfc/import-cfg cfg {:profile-id profile-id
:project-id project-id
:team team
:name name
:input input})]
(bfj/run cfg context
(fn [cfg]
(case (int version)
1 (v1/import-files! cfg)
3 (v3/import-files! cfg)
(throw (ex-info "unsupported binfile version"
{:type :validation
:code :unsupported-version
:version version})))))))
(defn- progress-events
"The progress events of a job, oldest first, with decoded payloads."
[job-id]
@ -88,9 +120,9 @@
:library-file-id (:id library)})
(v3/export-files! (-> th/*system*
(assoc ::bfc/ids #{(:id file)})
(assoc ::bfc/export-type :link-later))
(io/output-stream output))
(assoc ::bfc/file-ids #{(:id file)})
(assoc ::bfc/export-type :link-later)
(assoc ::bfc/output (io/output-stream output))))
(db/update! th/*system* :file
{:deleted-at (ct/now)}
@ -118,10 +150,8 @@
job-id (th/create-job* :export-binfile {:profile-id (:id profile)})
output (tmp/tempfile* :suffix ".penpot")]
(bfj/export-files (job-cfg) (job-context job-id)
{:ids #{file-id}
:export-type :detach-libraries
:output output})
(run-export! (job-cfg) (job-context job-id)
#{file-id} :detach-libraries output)
(t/testing "the artifact is a penpot file with its manifest"
(t/is (fs/exists? output))
@ -150,13 +180,13 @@
job-id (th/create-job* :import-binfile {:profile-id (:id profile)
:resource-id (:resource-id staged)})
context (job-context job-id)
result (bfj/import-files (job-cfg) context
{:profile-id (:id profile)
:project-id (:default-project-id profile)
:team team
:name "imported"
:input (js/load-input th/*system* context)
:version 3})]
result (run-import! (job-cfg) context
{:profile-id (:id profile)
:project-id (:default-project-id profile)
:team team
:name "imported"
:input (js/load-input th/*system* context)
:version 3})]
(t/testing "the package is imported in the destination project"
(t/is (= 1 (count (:file-ids result)))))
@ -175,10 +205,9 @@
(with-redefs [jobs/heartbeat (fn [_cfg & {:as options}]
(swap! reports conj (:progress options))
1)]
(bfj/export-files (job-cfg) (job-context job-id)
{:ids #{file-id}
:export-type :detach-libraries
:output (tmp/tempfile* :suffix ".penpot")}))
(run-export! (job-cfg) (job-context job-id)
#{file-id} :detach-libraries
(tmp/tempfile* :suffix ".penpot")))
(t/testing "the file opens the run with its position"
(let [event (first @reports)]
@ -207,10 +236,9 @@
;; the taps themselves, before the adapter turns them into events
(with-redefs [events/tap (fn [_type data] (swap! taps conj data))]
(bfj/export-files (job-cfg) (job-context job-id)
{:ids #{file-id}
:export-type :detach-libraries
:output (tmp/tempfile* :suffix ".penpot")}))
(run-export! (job-cfg) (job-context job-id)
#{file-id} :detach-libraries
(tmp/tempfile* :suffix ".penpot")))
(t/testing "the tap that opens the file carries the outer counters"
(let [tap (first (filter #(= :file (:section %)) @taps))]
@ -269,13 +297,13 @@
(with-redefs [jobs/heartbeat (fn [_cfg & {:as options}]
(swap! reports conj (:progress options))
1)]
(bfj/import-files (job-cfg) context
{:profile-id (:id profile)
:project-id (:default-project-id profile)
:team team
:name "imported"
:input (js/load-input th/*system* context)
:version 3}))
(run-import! (job-cfg) context
{:profile-id (:id profile)
:project-id (:default-project-id profile)
:team team
:name "imported"
:input (js/load-input th/*system* context)
:version 3}))
(t/testing "the run opens with the manifest, which has no units to count"
(let [event (first @reports)]
@ -301,8 +329,8 @@
job-id (th/create-job* :export-binfile {:profile-id (:id profile)})
context (job-context job-id)]
(t/testing "a running job is active"
(t/is (nil? (bfj/check-active th/*system* context))))
(t/testing "a running job is active, and answers with the cfg to thread it"
(t/is (identical? th/*system* (bfj/check-active th/*system* context))))
(t/testing "a cancelled job is not"
(th/db-update! :job {:status "cancelled"} {:id job-id})
@ -314,10 +342,8 @@
(t/testing "so the export stops at its next progress point"
(let [output (tmp/tempfile* :suffix ".penpot")
cause (try
(bfj/export-files (job-cfg) context
{:ids #{file-id}
:export-type :detach-libraries
:output output})
(run-export! (job-cfg) context
#{file-id} :detach-libraries output)
nil
(catch Throwable raised raised))]
(t/is (= :interrupt (th/ex-type cause)))
@ -342,14 +368,14 @@
cause (ex-info "the job is no longer active"
{:type :interrupt :code :job-interrupted})]
(with-redefs [jobs/heartbeat (fn [& _] (throw cause))]
(let [raised (try (@#'bfj/with-progress th/*system* context
(fn []
(swap! steps conj :before)
;; the sink calls the beat
;; inline, so its interrupt
;; aborts the run here
(events/tap :progress {:section :file})
(swap! steps conj :after)))
(let [raised (try (bfj/run th/*system* context
(fn [_cfg]
(swap! steps conj :before)
;; the sink calls the beat
;; inline, so its interrupt
;; aborts the run here
(events/tap :progress {:section :file})
(swap! steps conj :after)))
nil
(catch Throwable stopped stopped))]
(t/is (= :interrupt (:type (ex-data raised))))

8
backend/test/backend_tests/binfile_svg_test.clj
View File

@ -246,10 +246,10 @@
(let [bundle (tmp/tempfile :prefix "penpot-export-" :suffix ".zip")]
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{(:id file)})
(assoc ::bfc/file-ids #{(:id file)})
(assoc ::bfc/embed-assets false)
(assoc ::bfc/include-libraries false))
(io/output-stream bundle))
(assoc ::bfc/include-libraries false)
(assoc ::bfc/output (io/output-stream bundle))))
(let [evil (tmp/tempfile :prefix "penpot-evil-" :suffix ".zip")
_ (tamper-svg-entry! bundle evil media-id (utf8bytes evil-text) :content-type content-type)
@ -364,7 +364,7 @@
(let [bundle (tmp/tempfile :prefix "penpot-export-v1-" :suffix ".bin")]
(v1/export-files!
(-> th/*system*
(assoc ::bfc/ids #{(:id file)})
(assoc ::bfc/file-ids #{(:id file)})
(assoc ::bfc/embed-assets false)
(assoc ::bfc/include-libraries false))
(io/output-stream bundle))

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

@ -284,9 +284,9 @@
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{(:id file)})
(assoc ::bfc/export-type :detach-libraries))
(io/output-stream output))
(assoc ::bfc/file-ids #{(:id file)})
(assoc ::bfc/export-type :detach-libraries)
(assoc ::bfc/output (io/output-stream output))))
(let [result (-> th/*system*
(assoc ::bfc/project-id (:default-project-id profile))
@ -373,9 +373,9 @@
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{(:id file)})
(assoc ::bfc/export-type :detach-libraries))
(io/output-stream output))
(assoc ::bfc/file-ids #{(:id file)})
(assoc ::bfc/export-type :detach-libraries)
(assoc ::bfc/output (io/output-stream output))))
(let [result (-> th/*system*
(assoc ::bfc/project-id (:default-project-id profile))
@ -407,9 +407,9 @@
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{(:id file)})
(assoc ::bfc/export-type :detach-libraries))
(io/output-stream output))
(assoc ::bfc/file-ids #{(:id file)})
(assoc ::bfc/export-type :detach-libraries)
(assoc ::bfc/output (io/output-stream output))))
(let [result (-> th/*system*
(assoc ::bfc/project-id (:default-project-id profile))
@ -473,9 +473,9 @@
(let [output (tmp/tempfile :suffix ".zip")]
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{(:id file)})
(assoc ::bfc/export-type :link-later))
(io/output-stream output))
(assoc ::bfc/file-ids #{(:id file)})
(assoc ::bfc/export-type :link-later)
(assoc ::bfc/output (io/output-stream output))))
;; Read the manifest and check external-libraries
(let [manifest (v3/get-manifest th/*system* output)]
@ -508,9 +508,9 @@
(let [output (tmp/tempfile :suffix ".zip")]
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{(:id file)})
(assoc ::bfc/export-type :detach-libraries))
(io/output-stream output))
(assoc ::bfc/file-ids #{(:id file)})
(assoc ::bfc/export-type :detach-libraries)
(assoc ::bfc/output (io/output-stream output))))
;; Only the file is exported, not the library
(let [manifest (v3/get-manifest th/*system* output)
@ -569,9 +569,9 @@
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{(:id file)})
(assoc ::bfc/export-type :merge-libraries))
(io/output-stream output))
(assoc ::bfc/file-ids #{(:id file)})
(assoc ::bfc/export-type :merge-libraries)
(assoc ::bfc/output (io/output-stream output))))
;; Only the file is exported, not the library
(let [manifest (v3/get-manifest th/*system* output)
@ -645,9 +645,9 @@
(v3/export-files!
(assoc th/*system*
::bfc/ids #{(:id file)}
::bfc/export-type :detach-libraries)
(io/output-stream output))
::bfc/file-ids #{(:id file)}
::bfc/export-type :detach-libraries
::bfc/output (io/output-stream output)))
(let [names (zip-entry-names output)]
(t/is (contains? names (str "files/" (:id file) "/tokens.json")))
@ -696,9 +696,9 @@
(v3/export-files!
(assoc th/*system*
::bfc/ids #{(:id file)}
::bfc/export-type :include-libraries)
(io/output-stream output))
::bfc/file-ids #{(:id file)}
::bfc/export-type :include-libraries
::bfc/output (io/output-stream output)))
(let [files (import-output profile output)
library' (get files (:name library))
@ -733,9 +733,9 @@
(v3/export-files!
(assoc th/*system*
::bfc/ids #{(:id file)}
::bfc/export-type :include-libraries)
(io/output-stream output))
::bfc/file-ids #{(:id file)}
::bfc/export-type :include-libraries
::bfc/output (io/output-stream output)))
(t/is (contains? (zip-entry-names output)
(str "files/" (:id file) "/tokens.json")))
@ -769,9 +769,9 @@
(v3/export-files!
(assoc th/*system*
::bfc/ids #{(:id file)}
::bfc/export-type :include-libraries)
(io/output-stream output))
::bfc/file-ids #{(:id file)}
::bfc/export-type :include-libraries
::bfc/output (io/output-stream output)))
(let [files (import-output profile output)
file-data (:data (get files (:name file)))]
@ -801,9 +801,9 @@
(let [output (tmp/tempfile :suffix ".zip")]
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{(:id file)})
(assoc ::bfc/export-type :link-later))
(io/output-stream output))
(assoc ::bfc/file-ids #{(:id file)})
(assoc ::bfc/export-type :link-later)
(assoc ::bfc/output (io/output-stream output))))
;; Remove the source library to simulate a cross-environment import
;; where the original library does not exist in the target team.
@ -865,9 +865,9 @@
(let [output (tmp/tempfile :suffix ".zip")]
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{(:id file)})
(assoc ::bfc/export-type :detach-libraries))
(io/output-stream output))
(assoc ::bfc/file-ids #{(:id file)})
(assoc ::bfc/export-type :detach-libraries)
(assoc ::bfc/output (io/output-stream output))))
;; Remove the source library to simulate a cross-environment import
;; where no matching library exists in the target team.
@ -907,9 +907,9 @@
(let [output (tmp/tempfile :suffix ".zip")]
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{(:id file)})
(assoc ::bfc/export-type :link-later))
(io/output-stream output))
(assoc ::bfc/file-ids #{(:id file)})
(assoc ::bfc/export-type :link-later)
(assoc ::bfc/output (io/output-stream output))))
;; Remove the source library to simulate a cross-environment import
;; where the original library does not exist in the target team.
@ -985,9 +985,9 @@
(let [output (tmp/tempfile :suffix ".zip")]
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{(:id file)})
(assoc ::bfc/export-type :link-later))
(io/output-stream output))
(assoc ::bfc/file-ids #{(:id file)})
(assoc ::bfc/export-type :link-later)
(assoc ::bfc/output (io/output-stream output))))
;; Remove the source library and recreate a matching one owned by owner
(db/update! th/*system* :file
@ -1067,9 +1067,9 @@
(let [output (tmp/tempfile :suffix ".zip")]
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{(:id file1) (:id file2)})
(assoc ::bfc/export-type :link-later))
(io/output-stream output))
(assoc ::bfc/file-ids #{(:id file1) (:id file2)})
(assoc ::bfc/export-type :link-later)
(assoc ::bfc/output (io/output-stream output))))
;; Remove the source library and recreate a matching one
(db/update! th/*system* :file
@ -1168,9 +1168,9 @@
;; Export file with link-later
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{file-id})
(assoc ::bfc/export-type :link-later))
(io/output-stream output))
(assoc ::bfc/file-ids #{file-id})
(assoc ::bfc/export-type :link-later)
(assoc ::bfc/output (io/output-stream output))))
;; Verify manifest has external-libraries
(let [manifest (v3/get-manifest th/*system* output)
@ -1205,9 +1205,9 @@
;; Export file with link-later
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{file-id})
(assoc ::bfc/export-type :link-later))
(io/output-stream output))
(assoc ::bfc/file-ids #{file-id})
(assoc ::bfc/export-type :link-later)
(assoc ::bfc/output (io/output-stream output))))
;; First import
(let [result1 (-> th/*system*
@ -1238,9 +1238,9 @@
;; Export file with link-later
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{file-id})
(assoc ::bfc/export-type :link-later))
(io/output-stream output))
(assoc ::bfc/file-ids #{file-id})
(assoc ::bfc/export-type :link-later)
(assoc ::bfc/output (io/output-stream output))))
;; Import with overwrite (file-id set)
(let [result (-> th/*system*
@ -1267,9 +1267,9 @@
;; Export file with link-later from team 1
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{file-id})
(assoc ::bfc/export-type :link-later))
(io/output-stream output))
(assoc ::bfc/file-ids #{file-id})
(assoc ::bfc/export-type :link-later)
(assoc ::bfc/output (io/output-stream output))))
;; Import in team 2 (where library with same name exists)
(let [result (-> th/*system*
@ -1300,9 +1300,9 @@
;; Export file with link-later
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{file-id})
(assoc ::bfc/export-type :link-later))
(io/output-stream output))
(assoc ::bfc/file-ids #{file-id})
(assoc ::bfc/export-type :link-later)
(assoc ::bfc/output (io/output-stream output))))
;; Import in team 2 (no library exists)
(let [result (-> th/*system*
@ -1325,9 +1325,9 @@
;; Export file with link-later
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{file-id})
(assoc ::bfc/export-type :link-later))
(io/output-stream output))
(assoc ::bfc/file-ids #{file-id})
(assoc ::bfc/export-type :link-later)
(assoc ::bfc/output (io/output-stream output))))
;; Import in team 2 (library with different name)
(let [result (-> th/*system*
@ -1356,9 +1356,9 @@
;; Export file with link-later
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{file-id})
(assoc ::bfc/export-type :link-later))
(io/output-stream output))
(assoc ::bfc/file-ids #{file-id})
(assoc ::bfc/export-type :link-later)
(assoc ::bfc/output (io/output-stream output))))
;; Import in team 2 (library exists but not shared)
(let [result (-> th/*system*
@ -1381,9 +1381,9 @@
;; Export file with link-later
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{file-id})
(assoc ::bfc/export-type :link-later))
(io/output-stream output))
(assoc ::bfc/file-ids #{file-id})
(assoc ::bfc/export-type :link-later)
(assoc ::bfc/output (io/output-stream output))))
;; Delete the library in team 2
(db/update! th/*system* :file
@ -1433,9 +1433,9 @@
(let [output (tmp/tempfile :suffix ".zip")]
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{(:id file)})
(assoc ::bfc/export-type :link-later))
(io/output-stream output))
(assoc ::bfc/file-ids #{(:id file)})
(assoc ::bfc/export-type :link-later)
(assoc ::bfc/output (io/output-stream output))))
;; Delete original libraries
(db/update! th/*system* :file {:deleted-at (ct/now)} {:id (:id lib1)})
@ -1494,9 +1494,9 @@
(let [output (tmp/tempfile :suffix ".zip")]
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{(:id file)})
(assoc ::bfc/export-type :link-later))
(io/output-stream output))
(assoc ::bfc/file-ids #{(:id file)})
(assoc ::bfc/export-type :link-later)
(assoc ::bfc/output (io/output-stream output))))
;; Delete both libraries
(db/update! th/*system* :file {:deleted-at (ct/now)} {:id (:id lib1)})
@ -1546,9 +1546,9 @@
(let [output (tmp/tempfile :suffix ".zip")]
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{(:id file)})
(assoc ::bfc/export-type :link-later))
(io/output-stream output))
(assoc ::bfc/file-ids #{(:id file)})
(assoc ::bfc/export-type :link-later)
(assoc ::bfc/output (io/output-stream output))))
;; Delete original libraries
(db/update! th/*system* :file {:deleted-at (ct/now)} {:id (:id lib1)})
@ -1614,9 +1614,9 @@
(let [output (tmp/tempfile :suffix ".zip")]
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{(:id file)})
(assoc ::bfc/export-type :link-later))
(io/output-stream output))
(assoc ::bfc/file-ids #{(:id file)})
(assoc ::bfc/export-type :link-later)
(assoc ::bfc/output (io/output-stream output))))
;; Delete original libraries
(db/update! th/*system* :file {:deleted-at (ct/now)} {:id (:id lib1)})
@ -1680,9 +1680,9 @@
(let [output (tmp/tempfile :suffix ".zip")]
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{(:id file1) (:id file2)})
(assoc ::bfc/export-type :link-later))
(io/output-stream output))
(assoc ::bfc/file-ids #{(:id file1) (:id file2)})
(assoc ::bfc/export-type :link-later)
(assoc ::bfc/output (io/output-stream output))))
;; Delete original library and recreate
(db/update! th/*system* :file {:deleted-at (ct/now)} {:id (:id lib)})
@ -1726,9 +1726,9 @@
(let [output (tmp/tempfile :suffix ".zip")]
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{(:id file1) (:id file2)})
(assoc ::bfc/export-type :link-later))
(io/output-stream output))
(assoc ::bfc/file-ids #{(:id file1) (:id file2)})
(assoc ::bfc/export-type :link-later)
(assoc ::bfc/output (io/output-stream output))))
;; Delete original library and recreate
(db/update! th/*system* :file {:deleted-at (ct/now)} {:id (:id lib)})
@ -1778,9 +1778,9 @@
(let [output (tmp/tempfile :suffix ".zip")]
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{(:id file1) (:id file2)})
(assoc ::bfc/export-type :link-later))
(io/output-stream output))
(assoc ::bfc/file-ids #{(:id file1) (:id file2)})
(assoc ::bfc/export-type :link-later)
(assoc ::bfc/output (io/output-stream output))))
;; Delete original libraries and recreate
(db/update! th/*system* :file {:deleted-at (ct/now)} {:id (:id lib-icons)})
@ -1837,9 +1837,9 @@
(let [output (tmp/tempfile :suffix ".zip")]
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{(:id file)})
(assoc ::bfc/export-type :link-later))
(io/output-stream output))
(assoc ::bfc/file-ids #{(:id file)})
(assoc ::bfc/export-type :link-later)
(assoc ::bfc/output (io/output-stream output))))
;; Import as viewer (no edit permission on library)
(let [result (-> th/*system*
@ -1879,9 +1879,9 @@
(let [output (tmp/tempfile :suffix ".zip")]
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{(:id file)})
(assoc ::bfc/export-type :link-later))
(io/output-stream output))
(assoc ::bfc/file-ids #{(:id file)})
(assoc ::bfc/export-type :link-later)
(assoc ::bfc/output (io/output-stream output))))
;; Import as editor (has edit permission)
(let [result (-> th/*system*
@ -1919,9 +1919,9 @@
(let [output (tmp/tempfile :suffix ".zip")]
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{(:id file)})
(assoc ::bfc/export-type :link-later))
(io/output-stream output))
(assoc ::bfc/file-ids #{(:id file)})
(assoc ::bfc/export-type :link-later)
(assoc ::bfc/output (io/output-stream output))))
;; Verify slug in manifest
(let [manifest (v3/get-manifest th/*system* output)
@ -1946,9 +1946,9 @@
(let [output (tmp/tempfile :suffix ".zip")]
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{(:id file)})
(assoc ::bfc/export-type :link-later))
(io/output-stream output))
(assoc ::bfc/file-ids #{(:id file)})
(assoc ::bfc/export-type :link-later)
(assoc ::bfc/output (io/output-stream output))))
;; Library with empty slug should be dropped from external-libraries
(let [manifest (v3/get-manifest th/*system* output)
@ -1966,9 +1966,9 @@
;; Export file with no libraries
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{(:id file)})
(assoc ::bfc/export-type :link-later))
(io/output-stream output))
(assoc ::bfc/file-ids #{(:id file)})
(assoc ::bfc/export-type :link-later)
(assoc ::bfc/output (io/output-stream output))))
;; Manifest should have no external-libraries
(let [manifest (v3/get-manifest th/*system* output)]
@ -2000,9 +2000,9 @@
(let [output (tmp/tempfile :suffix ".zip")]
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{(:id file)})
(assoc ::bfc/export-type :link-later))
(io/output-stream output))
(assoc ::bfc/file-ids #{(:id file)})
(assoc ::bfc/export-type :link-later)
(assoc ::bfc/output (io/output-stream output))))
;; Delete original and create with different case
(db/update! th/*system* :file {:deleted-at (ct/now)} {:id (:id lib)})
@ -2037,9 +2037,9 @@
;; Export file with link-later
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{file-id})
(assoc ::bfc/export-type :link-later))
(io/output-stream output))
(assoc ::bfc/file-ids #{file-id})
(assoc ::bfc/export-type :link-later)
(assoc ::bfc/output (io/output-stream output))))
;; Re-import in same team
(let [result (-> th/*system*
@ -2075,9 +2075,9 @@
;; Export file with link-later
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{file-id})
(assoc ::bfc/export-type :link-later))
(io/output-stream output))
(assoc ::bfc/file-ids #{file-id})
(assoc ::bfc/export-type :link-later)
(assoc ::bfc/output (io/output-stream output))))
;; Import in team 2 (no library exists)
(let [result (-> th/*system*
@ -2127,9 +2127,9 @@
(let [output (tmp/tempfile :suffix ".zip")]
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{(:id file)})
(assoc ::bfc/export-type :link-later))
(io/output-stream output))
(assoc ::bfc/file-ids #{(:id file)})
(assoc ::bfc/export-type :link-later)
(assoc ::bfc/output (io/output-stream output))))
;; Delete and recreate library
(db/update! th/*system* :file {:deleted-at (ct/now)} {:id (:id lib)})
@ -2182,9 +2182,9 @@
(let [output (tmp/tempfile :suffix ".zip")]
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{(:id file)})
(assoc ::bfc/export-type :link-later))
(io/output-stream output))
(assoc ::bfc/file-ids #{(:id file)})
(assoc ::bfc/export-type :link-later)
(assoc ::bfc/output (io/output-stream output))))
;; Delete and create two libraries with same name
(db/update! th/*system* :file {:deleted-at (ct/now)} {:id (:id lib)})
@ -2240,9 +2240,9 @@
;; Export file with link-later
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{file-id})
(assoc ::bfc/export-type :link-later))
(io/output-stream output))
(assoc ::bfc/file-ids #{file-id})
(assoc ::bfc/export-type :link-later)
(assoc ::bfc/output (io/output-stream output))))
;; Re-import in same team
(let [result (-> th/*system*
@ -2292,9 +2292,9 @@
;; Export file with link-later
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{file-id})
(assoc ::bfc/export-type :link-later))
(io/output-stream output))
(assoc ::bfc/file-ids #{file-id})
(assoc ::bfc/export-type :link-later)
(assoc ::bfc/output (io/output-stream output))))
;; Create a viewer profile (no edit permission on the library)
(let [viewer (th/create-profile* th/*system* 2 {})
@ -2342,10 +2342,10 @@
;; type should win
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{file-id})
(assoc ::bfc/file-ids #{file-id})
(assoc ::bfc/export-type :link-later)
(assoc ::bfc/include-libraries true))
(io/output-stream output))
(assoc ::bfc/include-libraries true)
(assoc ::bfc/output (io/output-stream output))))
;; Verify manifest has external-libraries (only produced by link-later)
(let [manifest (v3/get-manifest th/*system* output)
@ -2362,9 +2362,9 @@
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{(:id file)})
(assoc ::bfc/export-type :detach-libraries))
(io/output-stream output))
(assoc ::bfc/file-ids #{(:id file)})
(assoc ::bfc/export-type :detach-libraries)
(assoc ::bfc/output (io/output-stream output))))
;; Import with max-zip-entries=1 — the exported ZIP has more entries
(let [cfg (-> th/*system*
@ -2419,9 +2419,9 @@
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{(:id file)})
(assoc ::bfc/export-type :detach-libraries))
(io/output-stream output))
(assoc ::bfc/file-ids #{(:id file)})
(assoc ::bfc/export-type :detach-libraries)
(assoc ::bfc/output (io/output-stream output))))
;; Import with max-binary-entry-size=1 — the media object will exceed this
(let [cfg (-> th/*system*
@ -2504,10 +2504,10 @@
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{(:id file)})
(assoc ::bfc/file-ids #{(:id file)})
(assoc ::bfc/embed-assets false)
(assoc ::bfc/include-libraries false))
(io/output-stream exported))
(assoc ::bfc/include-libraries false)
(assoc ::bfc/output (io/output-stream exported))))
(let [bombed (tmp/tempfile :suffix ".zip")]
(replace-zip-entry! exported bombed
@ -2550,10 +2550,10 @@
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{(:id file)})
(assoc ::bfc/file-ids #{(:id file)})
(assoc ::bfc/embed-assets false)
(assoc ::bfc/include-libraries false))
(io/output-stream output))
(assoc ::bfc/include-libraries false)
(assoc ::bfc/output (io/output-stream output))))
(let [cfg (-> th/*system*
(assoc ::bfc/project-id (:default-project-id profile))
@ -2597,10 +2597,10 @@
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{(:id file)})
(assoc ::bfc/file-ids #{(:id file)})
(assoc ::bfc/embed-assets false)
(assoc ::bfc/include-libraries false))
(io/output-stream exported))
(assoc ::bfc/include-libraries false)
(assoc ::bfc/output (io/output-stream exported))))
(let [sizes (text-entries-sizes exported)
max-single (apply max 0 sizes)
@ -2795,10 +2795,10 @@
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{(:id simple) (:id svg)})
(assoc ::bfc/file-ids #{(:id simple) (:id svg)})
(assoc ::bfc/embed-assets false)
(assoc ::bfc/include-libraries false))
(io/output-stream output))
(assoc ::bfc/include-libraries false)
(assoc ::bfc/output (io/output-stream output))))
;; import returns the imported file ids plus the library link
;; resolution; the test only needs the ids
@ -2874,10 +2874,10 @@
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{(:id file)})
(assoc ::bfc/file-ids #{(:id file)})
(assoc ::bfc/embed-assets false)
(assoc ::bfc/include-libraries false))
(io/output-stream output))
(assoc ::bfc/include-libraries false)
(assoc ::bfc/output (io/output-stream output))))
;; import returns the imported file ids plus the library link
;; resolution; the test only needs the ids
@ -2903,3 +2903,15 @@
(t/is (= (str (first result) "/" thumb-page-id "/" thumb-frame-id "/" thumb-tag)
(:object-id thumb)))
(t/is (some? (:media-id thumb)))))))
(t/deftest get-file-without-data-rejects-locks
;; Locking is incompatible with `load-data? false`: the guard fires
;; before any query, so no DB row is needed. Regression test for the
;; `lock-for-share?`/`lock-for-share?` typo that left `lock-for-update?`
;; unchecked. NOTE: the guard is an unconditional `when`/`throw` in
;; `get-file*` (not an `assert`), so this test is not flag-dependent:
;; it behaves the same with or without `enable-backend-asserts`.
(doseq [opt [:lock-for-share? :lock-for-update? :skip-locked?]]
(t/is (thrown? IllegalArgumentException
(bfc/get-file th/*system* (uuid/random)
:load-data? false opt true)))))

314
backend/test/backend_tests/climit_test.clj
View File

@ -38,20 +38,16 @@
(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- invoke!
"Run `f` under the limits the cfg declares, the way a command does: the key
of each limit comes from the params, and the root limiters come after the
ones the cfg declares."
[cfg f params]
(let [wrapped (climit/wrap cfg
f
{::sv/name "test-command"
::climit/id (::climit/id cfg)})]
(wrapped cfg params)))
(defn- failed-type
"Run `f` and return its value, or the type of the error it raised."
@ -101,11 +97,10 @@
;; 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.
(t/deftest acquires-the-command-own-limits-before-the-root-limits
;; A command declaring its own limits must meet them before the root
;; limiters. No command enters climit from inside its handler any more, so
;; every path takes the limiters in the same order.
(record-metrics
(fn []
(th/with-climit [climit test-config]
@ -113,124 +108,57 @@
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"]
(t/is (= ["process-image/by-profile"
"process-image/global"
"root/by-profile"
"root/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.
(t/deftest the-key-of-a-limit-comes-from-the-params
;; The key of a limit is a function of the params: a keyword is looked up in
;; them, and that is what tells one profile from another. Two calls with the
;; same key share the limiter, and two calls with a different key do not.
(th/with-climit [climit {:test-key/by-profile {:permits 1 :timeout 2000}}]
(let [pid (uuid/next)
limits [[:test-key/by-profile ::rpc/profile-id]]
cfg {::rpc/climit climit
::climit/id limits}
gate (promise)
entered (promise)
wrapped (climit/wrap cfg
(fn [_ params]
;; only the call of the first profile waits
(when (= pid (::rpc/profile-id params))
(deliver entered true)
@gate)
:ok)
{::sv/name "test-command" ::climit/id limits})
holder (future (wrapped cfg {::rpc/profile-id pid}))]
;; The call of the same profile waits for the permit this thread holds.
(t/is (true? (deref entered 5000 false)))
(t/is (= :timeout (deref (future (wrapped cfg {::rpc/profile-id pid})) 300 :timeout)))
;; The call of another profile takes the permit of its own key.
(t/is (= :ok (deref (future (wrapped cfg {::rpc/profile-id (uuid/next)})) 5000 :timeout)))
(deliver gate true)
(t/is (= :ok (deref holder 5000 :timeout))))))
(t/deftest a-command-without-limits-takes-the-root-limits
;; A command that declares no limits of its own still takes the root ones,
;; and in the same order as the ones of a command that declares them.
(record-metrics
(fn []
(th/with-climit [climit test-config]
(let [pid (uuid/next)
gate (promise)
entered (promise)
(let [mdata {::sv/name "test-command"}
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"]
(acquired-in-order))))))))
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
@ -239,14 +167,19 @@
(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.
;; silent 429s. Every entry of the shipped config must carry one. A limiter
;; without `:queue` lets its waiters pile up without bound, and a command
;; takes its own limits before the root ones, so the queue of a limit is
;; where its own pile-up waits.
(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"))))))
(str id " must declare a timeout"))
(t/is (int? (:queue config))
(str id " must declare a queue"))))))
(t/deftest warns-when-a-limiter-has-no-timeout
;; The config that production loads lives outside the repository and is
@ -321,17 +254,17 @@
(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)
{}))]
holder (future (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)
{}))]
(let [waiter (future (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)))
@ -350,30 +283,30 @@
(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)}
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])]
:future (future (invoke! (limiter-cfg climit :test-waiting-keys/by-profile k)
(fn [_ _]
(deliver entered true)
@(gates k)
:held)
{}))}])))
["a" "b"])]
(doseq [k [: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])]
[k (future (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
@ -381,9 +314,9 @@
;; contract, the value is.
(t/is (some #(= 2 %) (waiting-value-of name)))
(doseq [k [:a :b]] (deliver (gates k) true))
(doseq [k ["a" "b"]] (deliver (gates k) true))
(doseq [k [:a :b]]
(doseq [k ["a" "b"]]
(t/is (= :waited (deref (waiters k) 5000 :timeout)))
(t/is (= :held (deref (:future (holders k)) 5000 :timeout))))
@ -413,17 +346,17 @@
cfg (limiter-cfg climit :test-rejected/by-profile "a")
entered (promise)
gate (promise)
holder (future (climit/invoke! cfg
(fn [_ _] (deliver entered true) @gate :held)
{}))]
holder (future (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) {})))]
(let [queued (future (failed-type #(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 (= :concurrency-limit (failed-type #(invoke! cfg (fn [_ _] :extra) {}))))
(t/is (= [[name "queue-full"]] (rejections)))
(deliver gate true)
@ -436,13 +369,13 @@
cfg (limiter-cfg climit :test-timeout/by-profile "a")
entered (promise)
gate (promise)
holder (future (climit/invoke! cfg
(fn [_ _] (deliver entered true) @gate :held)
{}))]
holder (future (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 (= :concurrency-limit (failed-type #(invoke! cfg (fn [_ _] :late) {}))))
(t/is (= [[name "timeout"]] (rejections)))
(deliver gate true)
@ -458,14 +391,14 @@
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)
{}))]
holder (future (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 (= :concurrency-limit (failed-type #(invoke! cfg (fn [_ _] :extra) {}))))
(t/is (= 0 (waiting-count climit name)))
(t/is (true? (wait-until #(= 0 (waiting-last name)) 5000)))
@ -482,7 +415,7 @@
(reset! calls [])
(t/is (thrown? clojure.lang.ExceptionInfo
(climit/invoke! cfg (fn [_ _] (throw (ex-info "boom" {}))) {})))
(invoke! cfg (fn [_ _] (throw (ex-info "boom" {}))) {})))
(t/is (= 0 (waiting-count climit name)))
(t/is (true? (wait-until #(= 0 (waiting-last name)) 5000))))))))
@ -510,21 +443,24 @@
(reset! calls [])
(with-redefs [mtx/run! (failing-first-waiting-publish calls)]
(t/is (thrown? clojure.lang.ExceptionInfo
(climit/invoke! cfg (fn [_ _] :never) {}))))
(invoke! cfg (fn [_ _] :never) {}))))
;; the count came back down instead of staying up for good
;; the count came back down instead of staying up for good. Only the
;; last publication is asserted, not the exact list: the sampler
;; republishes the same count when its first tick lands inside the
;; window.
(t/is (= 0 (waiting-count climit name)))
(t/is (= [0] (waiting-value-of name)))
(t/is (= 0 (waiting-last 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)
{}))]
holder (future (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) {}))))
(t/is (= :concurrency-limit (failed-type #(invoke! cfg (fn [_ _] :inline) {}))))
(deliver gate true)
(t/is (= :held (deref holder 5000 :timeout)))))))
@ -549,13 +485,13 @@
(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)
{}))]
holder (future (invoke! cfg
(fn [_ _] (deliver entered true) @gate :held)
{}))]
(t/is (true? (deref entered 5000 false)))
(let [waiter (future (climit/invoke! cfg (fn [_ _] :waited) {}))]
(let [waiter (future (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)))
@ -592,20 +528,20 @@
cfg (limiter-cfg climit :test-log/by-profile "a")
entered (promise)
gate (promise)
holder (future (climit/invoke! cfg
(fn [_ _] (deliver entered true) @gate :held)
{}))]
holder (future (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) {}))]
(let [q1 (future (invoke! cfg (fn [_ _] :q1) {}))
q2 (future (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) {}))))
(t/is (= :concurrency-limit (failed-type #(invoke! cfg (fn [_ _] :x) {}))))
(let [props (::l/props (rejected-record records "queue-full"))]
(t/is (= 1 (get props :permits)))
@ -630,14 +566,14 @@
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)
{}))]
holder (future (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 (= :concurrency-limit (failed-type #(invoke! cfg (fn [_ _] :late) {}))))
(t/is (= [["rejected" :capacity-limit-reached "timeout"]]
(filterv #(= "rejected" (first %)) @lines))))

20
backend/test/backend_tests/db_test.clj
View File

@ -18,6 +18,24 @@
(t/use-fixtures :once th/state-init)
(defn- get-consistent-pool-stats
"Read pool stats until total equals active + idle, or attempts run out.
Hikari exposes each counter through a separate MXBean call, so a borrow
or return between the reads can leave a single snapshot inconsistent
(total off by one). Retrying until the pool is quiescent keeps the test
deterministic without weakening the invariant."
[pool]
(loop [attempt 20]
(let [stats (db/pool-stats pool)
total (:total-connections stats)
active (:active-connections stats)
idle (:idle-connections stats)]
(if (or (= total (+ active idle))
(zero? attempt))
stats
(do (Thread/sleep 10)
(recur (dec attempt)))))))
(t/deftest pool-requires-metrics
;; Metrics is required by the pool schema: a pool wired without it
;; fails at the boundary (AssertionError when asserts are enabled) or
@ -28,7 +46,7 @@
{::db/uri (java.net.URI. "postgresql://localhost/test")}))))
(t/deftest pool-stats-returns-expected-keys
(let [stats (db/pool-stats th/*pool*)]
(let [stats (get-consistent-pool-stats th/*pool*)]
(t/testing "all expected keys are present"
(t/is (contains? stats :active-connections))
(t/is (contains? stats :idle-connections))

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

File diff suppressed because it is too large Load Diff

59
backend/test/backend_tests/files_update_refusal_test.clj
View File

@ -90,6 +90,33 @@
:name "Page 1"
:objects {uuid/zero root}}}}}))
(defn- valid-file
"A file with one valid page: a root frame that lists its only child."
[]
(let [page-id (uuid/next)
child-id (uuid/next)
child (cts/setup-shape {:id child-id
:type :rect
:name "rect"
:x 0 :y 0 :width 10 :height 10
:parent-id uuid/zero
:frame-id uuid/zero})
root (-> (cts/setup-shape {:id uuid/zero
:type :frame
:name "Root"
:x 0 :y 0 :width 100 :height 100
:parent-id uuid/zero
:frame-id uuid/zero})
(assoc :shapes [child-id]))]
{:id (uuid/next)
:revn 0
:version 0
:features #{"components/v2"}
:data {:pages [page-id]
:pages-index {page-id {:id page-id
:name "Page 1"
:objects {uuid/zero root child-id child}}}}}))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Tests
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -144,17 +171,27 @@
["check" "reason"] ["affected" "child-not-found"])))))
(t/deftest referential-refusal-reports-the-gate-stage-and-code
(let [cfg (validation-cfg (metrics))
file (broken-referential-file)
page-id (first (:pages (:data file)))
changes [{:type :mod-obj :page-id page-id :id uuid/zero :operations []}]
cause (binding [cf/flags #{:file-validation}]
(with-redefs [bfc/get-resolved-file-libraries (fn [_ _] {})]
(try
(@#'files-update/process-changes-and-validate cfg file changes nil)
nil
(catch Throwable cause
cause))))]
;; The damage has to come from the changes. A file damaged before the
;; save is repairable, and the save then goes through instead of
;; refusing.
(let [cfg (validation-cfg (metrics))
file (valid-file)
page-id (first (:pages (:data file)))
shape-id (first (remove #{uuid/zero}
(keys (get-in file [:data :pages-index page-id :objects]))))
changes [{:type :mod-obj
:page-id page-id
:id shape-id
:operations [{:type :set
:attr :parent-id
:val (uuid/next)}]}]
cause (binding [cf/flags #{:file-validation}]
(with-redefs [bfc/get-resolved-file-libraries (fn [_ _] {})]
(try
(@#'files-update/process-changes-and-validate cfg file changes nil)
nil
(catch Throwable cause
cause))))]
(t/is (some? cause))
(t/is (= "referential"
(@#'files-update/refusal-stage

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

@ -627,13 +627,19 @@
(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)."
`metrics-stub` by default, where every `run!` is a no-op).
The root limiters are added with permits that no test reaches: every
request goes through them, and a test that does not list them would log a
warning per request."
([config]
(init-climit config (metrics-stub)))
([config metrics]
(let [file (doto (java.io.File/createTempFile "climit" ".edn")
(.deleteOnExit))]
(spit file (pr-str config))
(spit file (pr-str (merge {:root/global {:permits 1000 :timeout 3000}
:root/by-profile {:permits 1000 :timeout 3000}}
config)))
(ig/init-key ::rpc/climit
{::climit/enabled true
::climit/config (.getAbsolutePath file)

8
backend/test/backend_tests/http_assets_test.clj
View File

@ -31,7 +31,9 @@
io.prometheus.client.Counter
io.prometheus.client.Counter$Child))
(t/use-fixtures :once th/state-init)
(t/use-fixtures :once (t/compose-fixtures
(partial th/init-config [:enable-access-tokens])
th/init-system))
(t/use-fixtures :each (th/serial
th/database-reset
th/clean-storage))
@ -464,7 +466,7 @@
;; 2. actoken/authz reads ::http/auth-data and sets ::actoken/profile-id
request {::http/auth-data {:type :token
:token (:token atoken)
:claims {:tid (:id atoken)}}
:claims (actoken/decode-token th/*system* (:token atoken))}
:path-params {:id (str (:id object))}}
;; Apply actoken/authz middleware
@ -517,7 +519,7 @@
(t/testing "access token auth sets ::actoken/profile-id"
(let [request {::http/auth-data {:type :token
:token (:token atoken)
:claims {:tid (:id atoken)}}}
:claims (actoken/decode-token th/*system* (:token atoken))}}
result (with-session request)]
(t/is (= (:id profile) (::actoken/profile-id result)))))

29
backend/test/backend_tests/http_debug_test.clj Normal file
View File

@ -0,0 +1,29 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS SUBSIDIARY SL
(ns backend-tests.http-debug-test
"The /dbg validate action walks the whole file and its libraries: it
must hand `get-resolved-file-libraries` the file (not its id) and
resolve the pointer-mapped pages with the file's own loader."
(:require
[app.http.debug :as debug]
[backend-tests.helpers :as th]
[clojure.test :as t]
[yetti.response :as-alias yres]))
(t/use-fixtures :once th/state-init)
(t/use-fixtures :each th/database-reset)
(t/deftest validate-file-action-resolves-pointer-mapped-data
(let [profile (th/create-profile* 1)
file (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared false})
handler (deref #'debug/validate-file)
result (handler th/*system* {:params {:file-id (str (:id file))}})]
(t/is (= 200 (::yres/status result)))
(t/is (= "NO VALIDATION ERRORS FOUND" (::yres/body result)))))

40
backend/test/backend_tests/http_middleware_test.clj
View File

@ -34,7 +34,9 @@
io.prometheus.client.CollectorRegistry
io.undertow.server.RequestTooBigException))
(t/use-fixtures :once th/state-init)
(t/use-fixtures :once (t/compose-fixtures
(partial th/init-config [:enable-access-tokens])
th/init-system))
(t/use-fixtures :each th/database-reset)
(t/deftest auth-middleware-1
@ -106,7 +108,8 @@
(let [response (handler nil)]
(t/is (nil? response)))
(let [response (handler {::http/auth-data {:type :token :token "foobar" :claims {:tid (:id token)}}})]
(let [response (handler {::http/auth-data {:type :token :token (:token token)
:claims (tokens/verify th/*system* {:token (:token token)})}})]
(t/is (= #{} (:app.http.access-token/perms response)))
(t/is (= (:id profile) (:app.http.access-token/profile-id response))))))
@ -114,9 +117,14 @@
(let [profile (th/create-profile* 1)
token (db/tx-run! th/*system* app.rpc.commands.access-token/create-access-token
(:id profile) "test" nil "mcp")
handler (#'app.http.access-token/wrap-authz identity th/*system*)
request {::http/auth-data {:type :token :token "foobar" :claims {:tid (:id token)}}}
handler (#'app.http.access-token/wrap-authz
identity (assoc th/*system* :app.http.access-token/allow-mcp true))
request {::http/auth-data {:type :token :token (:token token)
:claims (tokens/verify th/*system* {:token (:token token)})}}
response (handler request)]
(t/is (nil? (:app.http.access-token/profile-id
((#'app.http.access-token/wrap-authz identity th/*system*) request)))
"MCP tokens do not authenticate routes that have not opted in")
;; Must set ::actoken/id from claims :tid
(t/is (= (:id token) (:app.http.access-token/id response)))
;; Must set ::actoken/type from database
@ -125,6 +133,30 @@
(t/is (= #{} (:app.http.access-token/perms response)))
(t/is (= (:id profile) (:app.http.access-token/profile-id response)))))
(t/deftest access-token-authz-follows-flags
(let [profile (th/create-profile* 1)
create #(db/tx-run! th/*system* app.rpc.commands.access-token/create-access-token
(:id profile) "test" nil %)
request (fn [{:keys [token]}]
{::http/auth-data {:type :token :token token
:claims (tokens/verify th/*system* {:token token})}})
auth (fn [flags token]
(with-redefs [cf/flags flags]
(let [handler (#'app.http.access-token/wrap-authz
identity (assoc th/*system* :app.http.access-token/allow-mcp true))]
(:app.http.access-token/profile-id (handler (request token))))))
personal (create nil)
mcp (create "mcp")]
(t/testing "only mcp: MCP tokens authenticate, personal tokens do not"
(t/is (= (:id profile) (auth #{:mcp} mcp)))
(t/is (nil? (auth #{:mcp} personal))))
(t/testing "only access-tokens: both authenticate"
(t/is (= (:id profile) (auth #{:access-tokens} mcp)))
(t/is (= (:id profile) (auth #{:access-tokens} personal))))
(t/testing "neither flag: the middleware is not installed"
(with-redefs [cf/flags #{}]
(t/is (nil? ((:compile app.http.access-token/authz))))))))
(defrecord MethodAwareDummyRequest [req-method headers]
yreq/IRequest
(method [_] req-method)

219
backend/test/backend_tests/mcp_oauth_clients_test.clj Normal file
View File

@ -0,0 +1,219 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS SUBSIDIARY SL
(ns backend-tests.mcp-oauth-clients-test
(:require
[app.mcp.oauth-clients :as clients]
[app.mcp.oauth-state :as state]
[app.util.json :as json]
[backend-tests.helpers :as th]
[clojure.string :as str]
[clojure.test :as t]
[mockery.core :refer [with-mocks]]))
(t/use-fixtures :once th/state-init)
(t/deftest registered-clients
(let [registration (clients/register! {}
{:client_name "Example"
:redirect_uris ["https://client.example/callback"]})
client (clients/resolve-client {} (:client_id registration))]
(t/is (string? (:client_secret registration)))
(t/is (nil? (:client_secret client)))
(t/is (state/secret= (:secret-hash client) (state/digest (:client_secret registration))))
(t/is (clients/redirect-matches? client "https://client.example/callback"))
(doseq [redirect ["https://client.example/callback?extra=1"
"https://client.example/callback/../evil"
"https://evil.example/callback"]]
(t/is (not (clients/redirect-matches? client redirect))))))
(t/deftest registrations-are-self-contained-and-distinct
(doseq [method ["none" "client_secret_basic" "client_secret_post"]]
(let [metadata {:client_name "Example α"
:logo_uri "https://client.example/logo.png"
:redirect_uris ["https://client.example/callback?source=mcp&mode=oauth"]
:token_endpoint_auth_method method}
first (clients/register! {} metadata)
second (clients/register! {} metadata)
client (clients/resolve-client {} (:client_id first))]
(t/is (not= (:client_id first) (:client_id second)))
(t/is (<= (count (:client_id first)) 2048))
(t/is (= metadata (select-keys client (keys metadata))))
(t/is (= (:client_id first) (:client_id client)))
(t/is (nil? (:client_secret client)))
(if (= method "none")
(do (t/is (nil? (:client_secret first)))
(t/is (nil? (:secret-hash client))))
(t/is (state/secret= (:secret-hash client)
(state/digest (:client_secret first))))))))
(t/deftest oversized-registration-is-rejected
(let [metadata {:redirect_uris [(str "https://client.example/" (apply str (repeat 1800 "a")))]}]
(t/is (= "invalid_client_metadata"
(try (clients/register! {} metadata)
(catch clojure.lang.ExceptionInfo cause (:oauth-error (ex-data cause))))))))
(t/deftest unusable-client-logos-are-ignored
;; An optional image must not prevent a client from authorizing.
(doseq [logo [nil "" 42 "/logo.png" "http://client.example/logo.png"
"javascript:alert(1)" "data:image/svg+xml,<svg/>"
"https://user:secret@client.example/logo.png"
(str "https://client.example/" (apply str (repeat 2048 "a")))]]
(let [client (clients/validate-metadata
{:redirect_uris ["https://client.example/callback"]
:logo_uri logo}
false)]
(t/is (not (contains? client :logo_uri))))))
(t/deftest client-id-size-boundary
(let [callback "https://client.example/callback/"
metadata {:redirect_uris [callback] :token_endpoint_auth_method "none"}
registration (clients/register! {} metadata)
[_ encoded] (str/split (:client_id registration) #"\." 2)
payload-size (alength (.decode (java.util.Base64/getUrlDecoder) encoded))
;; 1,525 payload bytes encode to 2,034 characters plus the 14-char prefix.
padding (apply str (repeat (- 1525 payload-size) "a"))
metadata (assoc metadata :redirect_uris [(str callback padding)])
largest (clients/register! {} metadata)]
(t/is (= 2048 (count (:client_id largest))))
(t/is (= (:redirect_uris metadata)
(:redirect_uris (clients/resolve-client {} (:client_id largest)))))
(t/is (= "invalid_client_metadata"
(try (clients/register! {} (update-in metadata [:redirect_uris 0] str "a"))
(catch clojure.lang.ExceptionInfo cause (:oauth-error (ex-data cause))))))))
(t/deftest malformed-client-identifiers-are-rejected
(doseq [id ["unknown" "penpot-mcp-v2.e30" "penpot-mcp-v1.e30"
"penpot-mcp-v1.W10" "penpot-mcp-v1.%%" "penpot-mcp-v1.bm90LWpzb24"
(str "penpot-mcp-v1." (apply str (repeat 2048 "a")))]]
(t/is (= "invalid_client"
(try (clients/resolve-client {} id)
(catch clojure.lang.ExceptionInfo cause (:oauth-error (ex-data cause))))))))
(t/deftest client-metadata-validation
(doseq [redirect ["https://client.example/callback#fragment" "javascript:alert(1)"
"http://client.example/callback" "https://user:secret@client.example/cb"]]
(t/is (thrown? clojure.lang.ExceptionInfo
(clients/validate-metadata {:redirect_uris [redirect]} false))))
(t/is (clients/redirect-matches? {:redirect_uris ["http://127.0.0.1:3000/callback"]}
"http://127.0.0.1:12345/callback"))
(t/is (= "none" (:token_endpoint_auth_method
(clients/validate-metadata
{:redirect_uris ["https://chatgpt.com/connector_platform_oauth_redirect"]
:token_endpoint_auth_methods_supported ["none" "private_key_jwt"]}
true))))
(t/is (thrown? clojure.lang.ExceptionInfo
(clients/validate-metadata
{:redirect_uris ["https://example.com/cb"]
:grant_types ["authorization_code" "refresh_token"]} false))))
(t/deftest client-metadata-documents-can-advertise-additional-grants
(let [metadata {:redirect_uris ["https://client.example/callback"]
:grant_types ["authorization_code" "refresh_token"]}]
(t/is (= ["authorization_code"]
(:grant_types (clients/validate-metadata metadata true))))))
(t/deftest client-metadata-documents-require-authorization-code-support
(doseq [grants [[] ["refresh_token"] "authorization_code"
["authorization_code" nil] ["authorization_code" 1]]]
(t/is (thrown? clojure.lang.ExceptionInfo
(clients/validate-metadata
{:redirect_uris ["https://client.example/callback"]
:grant_types grants}
true)))))
(t/deftest localhost-callbacks-allow-only-port-changes
(let [client {:redirect_uris ["http://localhost/callback"]}]
(t/is (clients/redirect-uri? "http://localhost/callback"))
(t/is (clients/redirect-matches? client "http://localhost:52351/callback"))
(doseq [redirect ["http://localhost.evil.example:52351/callback"
"http://127.0.0.1:52351/callback"
"http://localhost:52351/other"
"http://localhost:52351/callback?extra=1"
"http://localhost:52351/callback#fragment"
"http://user@localhost:52351/callback"]]
(t/is (not (clients/redirect-matches? client redirect))))
(doseq [redirect ["http://localhost.evil.example/callback"
"http://user@localhost/callback"]]
(t/is (not (clients/redirect-uri? redirect))))))
(t/deftest codex-published-client-metadata
;; Public metadata from https://chatgpt.com/oauth/codex/client.json.
;; Keep this fixture offline so upstream changes cannot make CI flaky.
(let [client-id "https://chatgpt.com/oauth/codex/client.json"
metadata {:client_id client-id
:client_uri "https://chatgpt.com/codex"
:application_type "native"
:redirect_uris ["http://127.0.0.1/callback" "http://localhost/callback"]
:token_endpoint_auth_method "none"
:token_endpoint_auth_methods_supported ["none"]
:grant_types ["authorization_code" "refresh_token"]
:response_types ["code"]
:client_name "Codex"
:logo_uri "https://persistent.oaistatic.com/sonic/misc/openai-logo.png"}]
(with-mocks [dns {:target 'app.util.ssrf/resolve-host
:return (into-array java.net.InetAddress
[(java.net.InetAddress/getByName "93.184.216.34")])}
sender {:target 'app.http.client/send!
:return (fn [& _]
{:status 200
:headers {"content-type" "application/json" "cache-control" "no-store"}
:body (java.io.ByteArrayInputStream. (json/encode metadata))})}]
(let [client (clients/resolve-client th/*system* client-id)]
(t/is (= client-id (:client_id client)))
(t/is (= (:logo_uri metadata) (:logo_uri client)))
(t/is (= ["authorization_code"] (:grant_types client)))
(t/is (= "none" (:token_endpoint_auth_method client)))
(t/is (clients/redirect-matches? client "http://127.0.0.1:52351/callback"))))))
(t/deftest client-metadata-documents
(let [client-id "https://client.example/client.json"
calls (atom 0)
metadata (atom {:client_id client-id
:client_name "Example"
:redirect_uris ["https://client.example/callback"]
:token_endpoint_auth_methods_supported ["none" "private_key_jwt"]})]
(with-mocks [dns {:target 'app.util.ssrf/resolve-host
:return (into-array java.net.InetAddress
[(java.net.InetAddress/getByName "93.184.216.34")])}
sender {:target 'app.http.client/send!
:return (fn [_ _ _]
(swap! calls inc)
{:status 200
:headers {"content-type" "application/json" "cache-control" "no-store"}
:body (java.io.ByteArrayInputStream.
(json/encode @metadata))})}]
(t/is (= "none" (:token_endpoint_auth_method (clients/resolve-client th/*system* client-id))))
(swap! metadata assoc :redirect_uris ["https://client.example/changed"])
(t/is (not (clients/redirect-matches? (clients/resolve-client th/*system* client-id)
"https://client.example/callback")))
(t/is (= 2 @calls))
(swap! metadata assoc :client_id "https://different.example/client.json")
(t/is (thrown? clojure.lang.ExceptionInfo (clients/resolve-client th/*system* client-id)))
(swap! metadata assoc :client_id client-id :client_name (apply str (repeat 65537 "a")))
(t/is (thrown? clojure.lang.ExceptionInfo (clients/resolve-client th/*system* client-id))))))
(t/deftest client-metadata-rejects-unsafe-fetches
(with-mocks [sender {:target 'app.http.client/send!
:return (fn [& _] (throw (AssertionError. "Unsafe request reached HTTP client")))}]
(doseq [client-id ["https://127.0.0.1/client.json"
"https://169.254.169.254/client.json"
"https://[::1]/client.json"
"https://user:secret@example.com/client.json"
"https://example.com/client.json#fragment"]]
(t/is (thrown? clojure.lang.ExceptionInfo (clients/resolve-client th/*system* client-id))))
(t/is (not (:called? @sender)))))
(t/deftest client-metadata-rejects-redirects
(with-mocks [dns {:target 'app.util.ssrf/resolve-host
:return (into-array java.net.InetAddress
[(java.net.InetAddress/getByName "93.184.216.34")])}
sender {:target 'app.http.client/send!
:return {:status 302
:headers {"location" "https://127.0.0.1/internal"}
:body (java.io.ByteArrayInputStream. (byte-array 0))}}]
(t/is (thrown? clojure.lang.ExceptionInfo
(clients/resolve-client th/*system* "https://redirect.example/client.json")))))

253
backend/test/backend_tests/mcp_oauth_http_test.clj Normal file
View File

@ -0,0 +1,253 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS SUBSIDIARY SL
(ns backend-tests.mcp-oauth-http-test
(:require
[app.common.uri :as uri]
[app.config :as cf]
[app.db :as db]
[app.http :as http]
[app.http.errors :as errors]
[app.http.mcp-oauth :as oauth]
[app.http.session :as session]
[app.mcp.oauth-clients :as clients]
[app.mcp.oauth-state :as state]
[app.rpc.commands.access-token :as access-token]
[app.setup.clock :as clock]
[app.util.json :as json]
[backend-tests.helpers :as th]
[clojure.string :as str]
[clojure.test :as t]
[yetti.response :as yres])
(:import java.net.URLEncoder java.nio.charset.StandardCharsets))
(t/use-fixtures :once th/state-init)
(t/use-fixtures :each th/database-reset
(fn [run]
(binding [cf/config (assoc cf/config :tenant (str (java.util.UUID/randomUUID)))]
(run))))
(defn- form [params]
(str/join "&" (for [[key value] params]
(str (name key) "=" (URLEncoder/encode (str value) StandardCharsets/UTF_8)))))
(defn- request [path & {:as options}]
(let [handler (#'http/router-handler (:app.http/router th/*system*))]
(handler (th/make-dummy-request (assoc options :path path)))))
(defn- body [response] (json/decode (::yres/body response)))
(defn- login-cookie [profile]
(let [session (session/create-session (:app.http.session/manager th/*system*)
{:profile-id (:id profile)})
token (:token (#'session/assign-token th/*system* session))]
{(cf/get :auth-token-cookie-name) token}))
(defn- begin [client]
(let [reply (request "/api/mcp/oauth/authorize"
:query (form {:client_id (:client_id client)
:redirect_uri (first (:redirect_uris client))
:response_type "code" :scope "mcp"
:resource (oauth/resource)
:state "client-state"
:code_challenge (state/digest (apply str (repeat 43 "a")))
:code_challenge_method "S256"}))]
(t/is (= 303 (::yres/status reply)))
(get (uri/query-string->map (.getQuery (java.net.URI. (get-in reply [::yres/headers "location"]))))
:request)))
(t/deftest discovery-and-registration
(let [metadata (body (request "/.well-known/oauth-authorization-server/api/mcp/oauth"))
resource (body (request "/api/mcp/oauth/resource"))
registered (request "/api/mcp/oauth/register" :method :post
:headers {"content-type" "application/json"}
:body-bytes (json/encode-str {:redirect_uris ["https://example.com/callback"]
:token_endpoint_auth_method "none"}))]
(t/is (= (oauth/issuer) (:issuer metadata)))
(t/is (= ["S256"] (:code_challenge_methods_supported metadata)))
(t/is (= (oauth/resource) (:resource resource)))
(t/is (= 201 (::yres/status registered)))
(t/is (= "none" (:token_endpoint_auth_method (body registered))))
(t/is (nil? (:client_secret (body registered))))))
(t/deftest complete-authorization-flow
(let [profile (th/create-profile* 1 {:is-active true})
cookies (login-cookie profile)
client (clients/register! th/*system* {:redirect_uris ["https://example.com/callback"]
:logo_uri "https://example.com/logo.png"
:token_endpoint_auth_method "none"})
handle (begin client)
details (request "/api/mcp/oauth/request" :query (form {:request handle}) :cookies cookies)
origin (str (cf/get-public-uri))
origin (str/replace origin #"/$" "")
decision {:request handle :decision "approve" :csrf (:csrf (body details))}
submit #(request "/api/mcp/oauth/decision" :method :post :cookies cookies
:headers {"content-type" "application/x-www-form-urlencoded" "origin" origin}
:body-bytes (form %))]
(t/is (= 401 (::yres/status (request "/api/mcp/oauth/request" :query (form {:request handle})))))
(t/is (= 200 (::yres/status details)))
(t/is (= "https://example.com/logo.png" (:logo-uri (body details))))
(t/is (= 400 (::yres/status (submit (assoc decision :csrf "wrong")))))
(let [approved (submit decision)
callback (java.net.URI. (:redirect-uri (body approved)))
params (uri/query-string->map (.getQuery callback))
exchange {:grant_type "authorization_code" :code (:code params)
:client_id (:client_id client) :redirect_uri "https://example.com/callback"
:resource (oauth/resource) :code_verifier (apply str (repeat 43 "a"))}
redeem #(request "/api/mcp/oauth/token" :method :post
:headers {"content-type" "application/x-www-form-urlencoded"}
:body-bytes (form %))]
(t/is (= 200 (::yres/status approved)))
(t/is (= "client-state" (:state params)))
(t/is (= (oauth/issuer) (:iss params)))
(t/is (= 400 (::yres/status (submit decision))))
;; Metadata is public and editable, but changing it changes the client ID.
;; Even with the correct verifier, an edited ID cannot use this approval.
(let [[prefix encoded] (str/split (:client_id client) #"\." 2)
payload (json/decode (.decode (java.util.Base64/getUrlDecoder) encoded))]
(doseq [changed [(assoc payload :client_name "Different application")
(assoc payload :redirect_uris ["https://attacker.example/callback"])]]
(let [id (str prefix "." (.encodeToString (.withoutPadding (java.util.Base64/getUrlEncoder))
(json/encode changed)))]
(t/is (string? (:client_id (clients/resolve-client {} id))))
(t/is (= "invalid_grant" (:error (body (redeem (assoc exchange :client_id id)))))))))
(t/is (= 400 (::yres/status (redeem (assoc exchange :code_verifier (apply str (repeat 43 "b")))))))
(let [token-response (redeem exchange)
token (body token-response)
stored (first (db/query th/*pool* :access-token {:profile-id (:id profile) :type "mcp"}))]
(t/is (= 200 (::yres/status token-response)))
(t/is (= "no-store" (get-in token-response [::yres/headers "cache-control"])))
(t/is (= (:token stored) (:access_token token)))
(t/is (= "Bearer" (:token_type token)))
(t/is (nil? (:expires_in token)))
(t/is (nil? (:refresh_token token)))
(t/is (= 400 (::yres/status (redeem exchange))))))))
(t/deftest denial-and-session-binding
(let [profile (th/create-profile* 1 {:is-active true})
other (th/create-profile* 2 {:is-active true})
cookies (login-cookie profile)
client (clients/register! th/*system* {:redirect_uris ["https://example.com/callback"]
:token_endpoint_auth_method "none"})
handle (begin client)
details (body (request "/api/mcp/oauth/request" :query (form {:request handle}) :cookies cookies))
params {:request handle :csrf (:csrf details) :decision "deny"}
submit #(request "/api/mcp/oauth/decision" :method :post :cookies cookies
:headers {"content-type" "application/x-www-form-urlencoded" "origin" %}
:body-bytes (form params))]
(t/is (= 403 (::yres/status
(request "/api/mcp/oauth/request" :query (form {:request handle})
:cookies (login-cookie other)))))
(t/is (= 403 (::yres/status (submit "https://attacker.example"))))
(let [denied (submit (str/replace (str (cf/get-public-uri)) #"/$" ""))
callback (java.net.URI. (:redirect-uri (body denied)))
result (uri/query-string->map (.getQuery callback))]
(t/is (= "access_denied" (:error result)))
(t/is (= "client-state" (:state result)))
(t/is (empty? (db/query th/*pool* :access-token {:profile-id (:id profile)})))
(t/is (not (:mcp-enabled (db/decode-transit-pgobject
(:props (th/db-get :profile {:id (:id profile)})))))))))
(t/deftest oauth-input-and-cors-errors
(doseq [data ["{" "[]" (apply str (repeat 16385 "a"))]]
(let [reply (request "/api/mcp/oauth/register" :method :post
:headers {"content-type" "application/json"}
:body-bytes data)]
(t/is (= 400 (::yres/status reply)))
(t/is (= "*" (get-in reply [::yres/headers "access-control-allow-origin"])))))
(let [reply (request "/api/mcp/oauth/token" :method :post
:headers {"content-type" "application/x-www-form-urlencoded"}
:body-bytes "code=a&code=b")]
(t/is (= 400 (::yres/status reply))))
(t/is (= 204 (::yres/status (request "/api/mcp/oauth/token" :method :options)))))
(t/deftest confidential-client-exchange
(let [profile (th/create-profile* 1 {:is-active true})
stored (db/tx-run! th/*system* access-token/ensure-mcp-access! (:id profile))
verifier (apply str (repeat 43 "a"))]
(doseq [method ["client_secret_basic" "client_secret_post"]]
(let [client (clients/register! th/*system*
{:redirect_uris ["https://example.com/callback"]
:token_endpoint_auth_method method})
code (state/create! th/*system* :code
{:client-id (:client_id client)
:redirect-uri "https://example.com/callback"
:resource (oauth/resource)
:challenge (state/digest verifier)
:profile-id (str (:id profile))
:token-id (str (:id stored))}
120)
params {:grant_type "authorization_code" :client_id (:client_id client)
:code code :code_verifier verifier :redirect_uri "https://example.com/callback"}
redeem (fn [secret]
(request "/api/mcp/oauth/token" :method :post
:headers (cond-> {"content-type" "application/x-www-form-urlencoded"}
(= method "client_secret_basic")
(assoc "authorization"
(str "Basic " (.encodeToString
(java.util.Base64/getEncoder)
(.getBytes (str (:client_id client) ":" secret) "UTF-8")))))
:body-bytes (form (cond-> params
(= method "client_secret_post")
(assoc :client_secret secret)))))]
(t/is (= 401 (::yres/status (redeem "wrong"))))
(t/is (= (:token stored) (:access_token (body (redeem (:client_secret client))))))))))
(t/deftest exchange-rejects-expired-token
(let [profile (th/create-profile* 1 {:is-active true})
stored (db/tx-run! th/*system* access-token/ensure-mcp-access! (:id profile))
verifier (apply str (repeat 43 "a"))
client (clients/register! th/*system* {:redirect_uris ["https://example.com/callback"]
:token_endpoint_auth_method "none"})
code (state/create! th/*system* :code
{:client-id (:client_id client)
:redirect-uri "https://example.com/callback"
:resource (oauth/resource)
:challenge (state/digest verifier)
:profile-id (str (:id profile))
:token-id (str (:id stored))}
120)]
(db/exec! th/*pool* ["UPDATE access_token SET expires_at = now() - interval '1 day' WHERE id = ?"
(:id stored)])
(let [reply (request "/api/mcp/oauth/token" :method :post
:headers {"content-type" "application/x-www-form-urlencoded"}
:body-bytes (form {:grant_type "authorization_code" :code code
:client_id (:client_id client) :code_verifier verifier
:redirect_uri "https://example.com/callback"}))]
(t/is (= 400 (::yres/status reply)))
(t/is (= "invalid_grant" (:error (body reply)))))))
(t/deftest unexpected-errors-are-logged
(let [logged (atom [])
cookies (login-cookie (th/create-profile* 1 {:is-active true}))
fail (fn [& _] (throw (RuntimeException. "unexpected")))]
(with-redefs [errors/handle (fn [cause _] (swap! logged conj (ex-message cause)))
clients/register! fail
clock/get-clock fail]
(t/testing "endpoint failures"
(let [reply (request "/api/mcp/oauth/register" :method :post
:headers {"content-type" "application/json"}
:body-bytes (json/encode-str {:redirect_uris ["https://example.com/callback"]}))]
(t/is (= 503 (::yres/status reply)))
(t/is (= {:error "temporarily_unavailable"} (body reply)))
(t/is (= "*" (get-in reply [::yres/headers "access-control-allow-origin"])))))
(t/testing "session middleware failures"
(let [reply (request "/api/mcp/oauth/request" :query (form {:request "x"}) :cookies cookies)]
(t/is (= 503 (::yres/status reply)))
(t/is (= {:error "temporarily_unavailable"} (body reply)))))
(t/testing "OAuth rejections are not logged"
(t/is (= 400 (::yres/status (request "/api/mcp/oauth/token" :method :post
:headers {"content-type" "application/x-www-form-urlencoded"}
:body-bytes "code=a&code=b"))))))
(t/is (= ["unexpected" "unexpected"] @logged))))
(t/deftest authorization-rejects-unregistered-callback
(let [client (clients/register! th/*system* {:redirect_uris ["https://example.com/callback"]})
reply (request "/api/mcp/oauth/authorize"
:query (form {:client_id (:client_id client)
:redirect_uri "https://attacker.example/callback"}))]
(t/is (= 400 (::yres/status reply)))
(t/is (nil? (get-in reply [::yres/headers "location"])))))

53
backend/test/backend_tests/mcp_oauth_state_test.clj Normal file
View File

@ -0,0 +1,53 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS SUBSIDIARY SL
(ns backend-tests.mcp-oauth-state-test
(:require
[app.config :as cf]
[app.mcp.oauth-state :as state]
[backend-tests.helpers :as th]
[clojure.test :as t]
[mockery.core :refer [with-mocks]]))
(t/use-fixtures :once th/state-init)
(t/deftest authorization-state
(let [cfg th/*system*
handle (state/create! cfg :code {:client-id "test"} 60)
record (state/read! cfg :code handle)]
(t/is (= {:client-id "test"} (:value record)))
(t/is (nil? (state/read! cfg :request handle)))
(t/is (false? (state/consume! cfg :code handle (assoc record :raw "wrong"))))
(t/is (= record (state/read! cfg :code handle)))
(let [results (mapv deref (repeatedly 8 #(future (state/consume! cfg :code handle record))))]
(t/is (= 1 (count (filter true? results)))))
(t/is (nil? (state/read! cfg :code handle)))))
(t/deftest bind-pending-request-once
(let [cfg th/*system*
handle (state/create! cfg :request {:client-id "test"} 60)
record (state/read! cfg :request handle)]
(t/is (true? (state/replace! cfg :request handle record {:session-id "first"})))
(t/is (false? (state/replace! cfg :request handle record {:session-id "second"})))
(t/is (= {:session-id "first"} (:value (state/read! cfg :request handle))))))
(t/deftest pkce-and-secrets
;; RFC 7636 appendix B
(t/is (= "E9Melhoa2OwvFrEMTJguCHaoeK1t8URWbuGJSstw-cM"
(state/digest "dBjftJeZ4CVP-mB92K27uhbUJU1p1r_wW1gFWFOEjXk"))))
(t/deftest expiry-and-tenant-isolation
(let [cfg th/*system*
handle (state/create! cfg :request {:test true} 1)]
(binding [cf/config (assoc cf/config :tenant "another-tenant")]
(t/is (nil? (state/read! cfg :request handle))))
(Thread/sleep 1100)
(t/is (nil? (state/read! cfg :request handle)))))
(t/deftest state-storage-fails-closed
(with-mocks [store {:target 'app.redis/set :return nil}]
(t/is (thrown? clojure.lang.ExceptionInfo
(state/create! th/*system* :request {:test true} 60)))))

6
backend/test/backend_tests/offload_file_data_test.clj
View File

@ -453,9 +453,9 @@
(v3/export-files!
(-> th/*system*
(assoc ::bfc/ids #{(:id file)})
(assoc ::bfc/export-type :detach-libraries))
(io/output-stream output))
(assoc ::bfc/file-ids #{(:id file)})
(assoc ::bfc/export-type :detach-libraries)
(assoc ::bfc/output (io/output-stream output))))
(let [result (-> th/*system*
(assoc ::bfc/project-id (:default-project-id profile))

77
backend/test/backend_tests/rpc_access_tokens_test.clj
View File

@ -6,12 +6,15 @@
(ns backend-tests.rpc-access-tokens-test
(:require
[app.common.time :as ct]
[app.common.uuid :as uuid]
[app.db :as db]
[app.http :as http]
[app.http.access-token :as actoken]
[app.rpc :as-alias rpc]
[app.rpc.commands.access-token :as access-token]
[app.storage :as sto]
[app.tokens :as tokens]
[backend-tests.helpers :as th]
[clojure.test :as t]
[mockery.core :refer [with-mocks]]))
@ -207,7 +210,7 @@
(t/is (not (contains? all-ids (:id second-mcp))))
(t/is (contains? all-ids (:id third-mcp))))))))
(t/deftest mcp-tokens-cannot-be-used-as-access-tokens
(t/deftest access-token-decoder-accepts-mcp-and-personal-issuers
(let [prof (th/create-profile* 1 {:is-active true})
cfg th/*system*]
@ -218,9 +221,9 @@
:name "mcp token"})
mcp-token (:token result)
;; Try to decode as access token (should fail)
decoded (actoken/decode-token cfg mcp-token)]
(t/is (nil? decoded))))
(t/is (= "urn:penpot:mcp-token" (:iss decoded)))
(t/is (= (:id prof) (:uid decoded)))))
(t/testing "Regular access tokens use access-token issuer claim"
(let [{:keys [result]} (th/command! {::th/type :create-access-token
@ -232,3 +235,71 @@
decoded (actoken/decode-token cfg access-token)]
(t/is (some? decoded))
(t/is (= (:id prof) (:uid decoded)))))))
(t/deftest oauth-mcp-token-provisioning
(let [prof (th/create-profile* 1 {:is-active true})
cfg th/*system*
provision #(db/tx-run! cfg access-token/ensure-mcp-access! (:id prof))]
(t/testing "approval enables MCP and creates a fixed token"
(let [token (provision)
props (-> (th/db-get :profile {:id (:id prof)})
:props db/decode-transit-pgobject)]
(t/is (string? (:token token)))
(t/is (nil? (:expires-at token)))
(t/is (true? (:mcp-enabled props)))
(t/is (= token (provision)))))
(t/testing "approval preserves a token generated in settings"
(let [{:keys [result error]}
(th/command! {::th/type :create-access-token
::rpc/profile-id (:id prof)
:type "mcp"
:name "From settings"})]
(t/is (nil? error))
(t/is (= (:token result) (:token (provision))))))
(t/testing "approval replaces an expired token"
(db/exec! th/*pool* [(str "UPDATE access_token SET expires_at = now() - interval '1 day'"
" WHERE profile_id = ?")
(:id prof)])
(let [expired (first (db/query th/*pool* :access-token {:profile-id (:id prof) :type "mcp"}))
token (provision)]
(t/is (not= (:token expired) (:token token)))
(t/is (nil? (:expires-at token)))
(t/is (= [(:id token)]
(map :id (db/query th/*pool* :access-token {:profile-id (:id prof) :type "mcp"}))))))
(t/testing "approval replaces a token issued with the personal-token issuer"
(db/delete! th/*pool* :access-token {:profile-id (:id prof)})
(let [token-id (uuid/next)
now (ct/now)
old (tokens/generate cfg {:iss "access-token" :uid (:id prof)
:iat now :tid token-id})]
(db/tx-run! cfg (fn [{:keys [::db/conn]}]
(db/insert! conn :access-token
{:id token-id :name "MCP" :token old :type "mcp"
:profile-id (:id prof) :created-at now :updated-at now
:perms (db/create-array conn "text" [])})))
(let [token (provision)]
(t/is (not= old (:token token)))
(t/is (= actoken/mcp-token-issuer
(:iss (actoken/decode-token cfg (:token token)))))
(t/is (= [(:id token)]
(map :id (db/query th/*pool* :access-token
{:profile-id (:id prof) :type "mcp"})))))))
(t/testing "approval replaces a token this instance cannot decrypt"
(db/delete! th/*pool* :access-token {:profile-id (:id prof)})
(let [now (ct/now)]
(db/tx-run! cfg (fn [{:keys [::db/conn]}]
(db/insert! conn :access-token
{:id (uuid/next) :name "MCP" :token "not-a-jwe" :type "mcp"
:profile-id (:id prof) :created-at now :updated-at now
:perms (db/create-array conn "text" [])})))
(let [token (provision)]
(t/is (not= "not-a-jwe" (:token token)))
(t/is (= [(:id token)]
(map :id (db/query th/*pool* :access-token
{:profile-id (:id prof) :type "mcp"})))))))
(t/testing "concurrent approvals share one token"
(db/delete! th/*pool* :access-token {:profile-id (:id prof)})
(let [results (mapv deref (repeatedly 4 #(future (provision))))]
(t/is (= 1 (count (set (map :token results)))))
(t/is (= 1 (count (db/query th/*pool* :access-token
{:profile-id (:id prof) :type "mcp"}))))))))

69
backend/test/backend_tests/rpc_binfile_test.clj
View File

@ -6,6 +6,7 @@
(ns backend-tests.rpc-binfile-test
(:require
[app.binfile.common :as bfc]
[app.binfile.v3 :as bf.v3]
[app.common.schema :as sm]
[app.common.uuid :as uuid]
@ -13,9 +14,11 @@
[app.db :as db]
[app.rpc :as-alias rpc]
[app.rpc.commands.binfile :as binfile]
[app.storage.tmp :as tmp]
[backend-tests.helpers :as th]
[clojure.test :as t]
[datoteka.fs :as fs]
[datoteka.io :as io]
[mockery.core :refer [with-mocks]]))
(t/use-fixtures :once th/state-init)
@ -155,3 +158,69 @@
(t/is (= file-id (get-in (first events) [:props :id])))
(t/is (= (:id project) (get-in (first events) [:props :project-id])))
(t/is (= (:id team) (get-in (first events) [:props :team-id]))))))))
(defn- export-file
[profile]
(let [file (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared false})
output (tmp/tempfile :suffix ".zip")]
(bf.v3/export-files!
(-> th/*system*
(assoc ::bfc/file-ids #{(:id file)})
(assoc ::bfc/embed-assets false)
(assoc ::bfc/include-libraries false)
(assoc ::bfc/output (io/output-stream output))))
output))
(defn- import-file
[profile path]
(let [out (th/multipart-command! {::th/type :import-binfile
::rpc/profile-id (:id profile)
:project-id (:default-project-id profile)
:name "imported"
:file {:filename "imported.penpot"
:size (fs/size path)
:path path
:mtype "application/zip"}})]
(t/is (nil? (:error out)))
(th/consume-sse (:result out))))
(defn- import-events
[mock]
(->> (:call-args-list @mock)
(map second)
(filter #(= "import-binfile" (:name %)))))
(t/deftest import-binfile-audit-event-records-file-ids
(with-mocks [mock {:target 'app.loggers.audit/submit :return nil}]
(let [profile (th/create-profile* 1 {:is-active true})
events (import-file profile (export-file profile))
file-ids (-> events last second :file-ids)
[event :as audit-events] (import-events mock)]
(t/is (= :end (-> events last first)))
(t/is (= 1 (count audit-events)))
(t/is (= 1 (count file-ids)))
(t/is (= (vec file-ids) (-> event :props :file-ids)))
(t/is (= 1 (-> event :props :file-count)))
(t/is (= "completed" (-> event :props :status)))
(t/is (= (:default-project-id profile) (-> event :props :project-id)))
(t/is (= "penpot" (-> event :props :referer)))
(t/is (= (:id profile) (:profile-id event)))
(t/is (= "command" (:type event)))
(t/is (not (contains? (:props event) :file))))))
(t/deftest import-binfile-audit-event-records-failure
(with-mocks [mock {:target 'app.loggers.audit/submit :return nil}]
(let [profile (th/create-profile* 1 {:is-active true})
path (export-file profile)
events (with-redefs [bf.v3/import-files!
(fn [_] (throw (ex-info "boom" {:type :internal})))]
(import-file profile path))
[event :as audit-events] (import-events mock)]
(t/is (= :error (-> events last first)))
(t/is (= 1 (count audit-events)))
(t/is (= "failed" (-> event :props :status)))
(t/is (not (contains? (:props event) :file-ids))))))

134
backend/test/backend_tests/rpc_climit_test.clj
View File

@ -6,13 +6,22 @@
(ns backend-tests.rpc-climit-test
(:require
[app.rpc :as-alias rpc]
[app.rpc.climit :as-alias 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]))
(t/use-fixtures :once th/state-init)
(defn- command-limits
"The `::climit/id` declaration of the RPC command named `name`."
[name]
(let [[mdata _] (get (:app.rpc/methods th/*system*) (keyword name))]
(::climit/id mdata)))
(defn- method-limit-declarations
"The `::climit/id` declarations of every RPC command, as the running system
wraps them."
@ -24,11 +33,87 @@
(when-let [limits (::climit/id mdata)]
[mdata limits])))))
(defn- declared-ids
"The limit ids a command declares, in the order it declares them."
[limits]
(cond
(keyword? limits)
[limits]
(vector? (first limits))
(mapv first limits)
:else
[(first limits)]))
(defn- limit-order-edges
"The pairs of limit ids the commands declare, as edges: the first one of the
pair is taken before the second one."
[declarations]
(reduce (fn [edges [mdata limits]]
(let [ids (declared-ids limits)
size (count ids)]
(into edges
(for [i (range size)
j (range (inc i) size)]
[(nth ids i) (nth ids j)]))))
#{}
declarations))
(defn- limit-order-cycle
"The limit ids whose relative order the commands disagree about: the ones
left when the relation cannot be sorted.
Two commands that take the same limiters in opposite order leave two paths
of one profile holding them in opposite order, and the threads park for
good. A ring of three does the same, so the relation is checked as a whole
and not pair by pair."
[edges]
(let [nodes (into #{} (mapcat identity) edges)
outgoing (reduce (fn [acc [a b]] (update acc a (fnil conj #{}) b)) {} edges)
indegree (reduce (fn [acc [_ b]] (update acc b (fnil inc 0))) {} edges)]
(loop [pending nodes
degrees indegree]
(let [ready (filterv #(zero? (get degrees % 0)) pending)]
(if (empty? ready)
(seq pending)
(recur (apply disj pending ready)
(reduce (fn [degrees node]
(reduce (fn [degrees next]
(update degrees next (fnil dec 0)))
degrees
(get outgoing node)))
degrees
ready)))))))
(t/deftest the-media-object-from-url-command-declares-its-own-limits
;; The command used to enter climit from inside its handler, which forced
;; every path to take the root limiters before the command ones. It declares
;; its limits now, so there is a single place where they are read.
(t/is (= [[:process-image/by-profile ::rpc/profile-id]
[:process-image/global]]
(command-limits "create-file-media-object-from-url"))))
(t/deftest the-update-profile-photo-command-declares-its-own-limits
;; The command used to enter climit from inside its handler, which forced
;; every path to take the root limiters before the command ones. It declares
;; its limits now, so there is a single place where they are read.
(t/is (= [[:process-image/by-profile ::rpc/profile-id]
[:process-image/global]]
(command-limits "update-profile-photo"))))
(t/deftest the-update-team-photo-command-declares-its-own-limits
;; The command generates the thumbnail of a team through `upload-photo`,
;; which used to enter climit on its own. It declares the limits now, so the
;; image processing of a team is bounded like the one of a profile.
(t/is (= [[:process-image/by-profile ::rpc/profile-id]
[:process-image/global]]
(command-limits "update-team-photo"))))
(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.
;; declared is acquired first. 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
@ -49,3 +134,46 @@
(t/is (< idx gidx)
(str where " must declare " id " before "
(keyword (namespace id) "global")))))))))
(t/deftest every-command-takes-the-shared-limits-in-the-same-order
;; Two commands that share a limit and take it in opposite order can hold
;; the same limiters in opposite order and park for good. The order is free
;; now that no command enters climit from inside its handler, so this test
;; is what keeps the commands consistent with each other.
(let [declarations (method-limit-declarations)
edges (limit-order-edges declarations)
cycle (limit-order-cycle edges)]
;; the system wraps every command, so a short list means the scan went stale
(t/is (<= 10 (count declarations)))
(t/is (seq edges))
(t/is (nil? cycle)
(str "the commands take these limits in different orders: "
(pr-str cycle)))))
(t/deftest a-ring-of-three-limits-is-a-cycle
;; A ring of three limits does the same as a pair in opposite order: three
;; paths hold the three limiters and wait for each other. The relation is
;; checked as a whole for that reason, and not pair by pair.
(t/is (= #{:a :b :c}
(set (limit-order-cycle #{[:a :b] [:b :c] [:c :a]}))))
(t/is (nil? (limit-order-cycle #{[:a :b] [:b :c]}))))
(t/deftest every-declared-limit-has-an-entry-in-the-shipped-config
;; `climit/wrap` logs a warning and runs the handler with no limiter at all
;; when the config has no entry for a declared id, so the command runs on
;; every thread that asks for it. The production file is maintained by hand
;; outside the repository and mirrors this one, so a command declaring a limit
;; the file does not list is the shape of an unbounded command in production.
(let [path (io/resource "climit.edn")
config (edn/read-string (slurp path))
declared (into #{}
(mapcat (fn [[_ limits]] (declared-ids limits)))
(method-limit-declarations))]
;; the system wraps every command, so an empty set means the scan went stale
(t/is (seq declared))
(doseq [id declared]
(t/is (some? (get config id))
(str id " is declared by a command but has no entry in climit.edn")))))

179
backend/test/backend_tests/rpc_commands_mcp_feedback_test.clj Normal file
View File

@ -0,0 +1,179 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS SUBSIDIARY SL
(ns backend-tests.rpc-commands-mcp-feedback-test
(:require
[app.common.json :as json]
[app.common.time :as ct]
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
[app.email :as email]
[app.http :as http]
[app.jobs :as jobs]
[app.rpc :as-alias rpc]
[app.rpc.commands.access-token :as access-token]
[app.tokens :as tokens]
[backend-tests.helpers :as th]
[clojure.test :as t]
[yetti.response :as-alias yres]))
(t/use-fixtures :once (t/compose-fixtures
(partial th/init-config [:enable-access-tokens
:enable-client-header-check-middleware])
th/init-system))
(t/use-fixtures :each th/database-reset)
(def ^:private feedback
{:subject "Export fails"
:feedback "Exporting a valid shape repeatedly fails. Expected a PNG."})
(defn- create-identity
[]
(let [profile (th/create-profile* (uuid/next) {:is-active true})
token (db/tx-run! th/*system* access-token/create-access-token
(:id profile) "MCP" nil "mcp")]
{:profile profile :token token}))
(defn- request
([token] (request token feedback))
([token params] (request token params {}))
([token params options]
(with-redefs [cf/config (assoc cf/config :mcp-feedback-email "mcp@example.com")]
((#'http/router-handler (::http/router th/*system*))
(th/make-dummy-request
(merge {:path "/api/main/methods/send-mcp-feedback"
:method :post
:headers (cond-> {"content-type" "application/json"
"accept" "application/json"
"x-client" "penpot-mcp"}
token (assoc "authorization" (str "Token " token)))
:body-bytes (json/encode params)}
options))))))
(defn- emails
[]
(map #(jobs/decode-params (jobs/get-job-def (::jobs/defs th/*system*) :sendmail) (:params %))
(db/query th/*system* :job {:name "sendmail"})))
(t/deftest queues-plain-text-feedback
(let [{:keys [token profile]} (create-identity)
response (request (:token token))
email (first (emails))]
(t/is (= 200 (::yres/status response)))
(t/is (= 1 (count (emails))))
(t/is (= "mcp@example.com" (:to email)))
(t/is (= (:email profile) (:reply-to email)))
(t/is (= "[MCP feedback] Export fails" (:subject email)))
(t/is (= {"text/plain" (str "Submitted by: " (:fullname profile)
" <" (:email profile) ">\n"
"Profile ID: " (:id profile) "\n\n"
"Feedback:\n\n" (:feedback feedback))}
(:body email)))
(t/is (nil? (:attachments email)))))
(t/deftest rejects-invalid-credentials
(let [{:keys [profile token]} (create-identity)]
(doseq [credential [nil "" "invalid"
(tokens/generate th/*system* {:iss "other"
:uid (:id profile) :tid (:id token)})
(tokens/generate th/*system* {:iss "access-token"
:uid (:id profile) :tid (:id token)})
(tokens/generate th/*system* {:iss "urn:penpot:mcp-token"
:uid (uuid/next) :tid (:id token)})
(tokens/generate th/*system* {:iss "urn:penpot:mcp-token"
:uid (:id profile) :tid (uuid/next)})
(tokens/generate th/*system* {:iss "urn:penpot:mcp-token"
:uid (:id profile) :tid (:id token)
:exp (ct/minus (ct/now) (ct/duration "1h"))})]]
(t/is (= 401 (::yres/status (request credential)))))
(t/is (empty? (emails)))))
(t/deftest rejects-expired-revoked-and-wrong-type-tokens
(let [{:keys [token profile]} (create-identity)]
(db/update! th/*system* :access-token
{:expires-at (ct/minus (ct/now) (ct/duration "1h"))} {:id (:id token)})
(t/is (= 401 (::yres/status (request (:token token)))))
(db/update! th/*system* :access-token {:expires-at nil :type "personal"} {:id (:id token)})
(t/is (= 401 (::yres/status (request (:token token)))))
(db/update! th/*system* :access-token {:type "mcp"} {:id (:id token)})
(db/tx-run! th/*system* access-token/create-access-token (:id profile) "Replacement" nil "mcp")
(t/is (= 401 (::yres/status (request (:token token)))))
(t/is (empty? (emails)))))
(t/deftest rejects-unavailable-profiles
(doseq [changes [{:is-active false}
{:is-blocked true}
{:deleted-at (ct/minus (ct/now) (ct/duration "1h"))}]]
(let [{:keys [token profile]} (create-identity)]
(db/update! th/*system* :profile changes {:id (:id profile)})
(t/is (= (if (:deleted-at changes) 404 403)
(::yres/status (request (:token token)))))))
(t/is (empty? (emails))))
(t/deftest validates-feedback-before-queueing
(let [{:keys [token]} (create-identity)]
(doseq [params [{}
(assoc feedback :subject "")
(assoc feedback :subject " ")
(assoc feedback :subject "a\r\nBcc: victim@example.com")
(assoc feedback :subject "a\tb")
(assoc feedback :subject "a\u0085b")
(assoc feedback :subject "a\u0000b")
(assoc feedback :feedback "a\u0000b")
(assoc feedback :feedback "a\u001bb")
(assoc feedback :subject (apply str (repeat 121 "x")))
(assoc feedback :feedback " \n")
(assoc feedback :feedback (apply str (repeat 5001 "x")))
(assoc feedback :to "victim@example.com")
(assoc feedback :attachments {})
(assoc feedback :feedback 42)]]
(t/is (= 400 (::yres/status (request (:token token) params)))))
(t/is (empty? (emails)))
(t/is (= 200 (::yres/status
(request (:token token) {:subject (apply str (repeat 120 "x"))
:feedback (apply str (repeat 5000 "x"))}))))
(t/is (= 200 (::yres/status
(request (:token token) {:subject "Tabs and breaks"
:feedback "line one\r\n\tline two\n"}))))))
(t/deftest audit-event-omits-feedback-text
(let [{:keys [profile]} (create-identity)]
(with-redefs [cf/config (assoc cf/config :mcp-feedback-email "mcp@example.com")]
(let [result (th/command-raw! (merge feedback {::th/type :send-mcp-feedback
::rpc/profile-id (:id profile)
::rpc/auth-type :token
::rpc/token-type "mcp"}))]
(t/is (= {} (:app.loggers.audit/replace-props (meta result))))))))
(t/deftest disabled-without-feedback-email
(let [{:keys [token]} (create-identity)]
(with-redefs [cf/config (dissoc cf/config :mcp-feedback-email)]
(let [response ((#'http/router-handler (::http/router th/*system*))
(th/make-dummy-request
{:path "/api/main/methods/send-mcp-feedback" :method :post
:headers {"authorization" (str "Token " (:token token))
"content-type" "application/json"
"x-client" "penpot-mcp"}
:body-bytes (json/encode feedback)}))]
(t/is (= 400 (::yres/status response)))))
(t/is (empty? (emails)))))
(t/deftest feedback-is-post-only
(let [{:keys [token]} (create-identity)]
(t/is (= 405 (::yres/status (request (:token token) feedback {:method :get})))))
(t/is (empty? (emails))))
(t/deftest mcp-token-does-not-authorize-ordinary-rpc
(let [{:keys [token]} (create-identity)]
(t/is (= 403 (::yres/status
(request (:token token) {} {:path "/api/rpc/command/get-teams"}))))))
(t/deftest does-not-acknowledge-a-failed-queue-submission
(let [{:keys [token]} (create-identity)]
(with-redefs [email/send (fn [& _] (throw (ex-info "Queue unavailable" {})))]
(t/is (= 500 (::yres/status (request (:token token)))))))
(t/is (empty? (emails))))

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

@ -6,19 +6,27 @@
(ns backend-tests.rpc-file-snapshot-test
(:require
[app.binfile.common :as bfc]
[app.common.data :as d]
[app.common.features :as cfeat]
[app.common.files.defaults :as cfd]
[app.common.files.migrations :as fmg]
[app.common.pprint :as pp]
[app.common.thumbnails :as thc]
[app.common.time :as ct]
[app.common.types.objects-map :as omap]
[app.common.types.shape :as cts]
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
[app.db.sql :as sql]
[app.features.fdata :as fdata]
[app.features.file-snapshots :as fsnap]
[app.http :as http]
[app.rpc :as-alias rpc]
[app.storage :as sto]
[backend-tests.helpers :as th]
[clojure.set :as set]
[clojure.test :as t]
[cuerdas.core :as str]))
@ -138,6 +146,156 @@
;; delete 2 snapshots and 2 file data entries
(t/is (= 4 (:processed res)))))))))
(t/deftest snapshot-preview-resolves-fragments
;; Regression test (R1): previewing an automatic snapshot of a
;; pointer-mapped file must return plain data, not pointer
;; placeholders the preview UI cannot render.
(let [profile (th/create-profile* 1)
file (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared false})
file-id (:id file)
page-id (first (get-in file [:data :pages]))
shape-id (uuid/random)]
;; An update at revn 0 takes an automatic (system) snapshot of the
;; pre-change state; with pointer-map that snapshot shares fragments
;; with the live file.
(update-file! :profile-id (:id profile)
:file-id file-id
:revn 0
:changes [{:type :add-obj
:page-id page-id
:id shape-id
:parent-id uuid/zero
:frame-id uuid/zero
:components-v2 true
:obj (cts/setup-shape
{:id shape-id
:name "rect"
:frame-id uuid/zero
:parent-id uuid/zero
:type :rect})}])
;; Single labeled snapshot here, but order explicitly so a
;; future edit adding more snapshots cannot pick the wrong one.
(let [snap-id (->> (th/db-query :file-change {:file-id file-id} {:order-by [:created-at]})
(filter #(some? (:label %)))
(first)
(:id))
_ (t/is (uuid? snap-id))
out (th/command! {::th/type :get-file-snapshot
::rpc/profile-id (:id profile)
:file-id file-id
:id snap-id
:features cfeat/supported-features})]
(t/is (nil? (:error out)))
(let [data (get-in (:result out) [:data])]
(t/is (map? data))
(t/is (empty? (fdata/get-used-pointer-ids data)))))))
(defn- live-fragment-ids
[file-id]
(into #{}
(comp (filter #(nil? (:deleted-at %)))
(map :id))
(th/db-query :file-data {:file-id file-id :type "fragment"})))
(t/deftest user-snapshot-shares-fragments
;; User-pinned versions share fragment rows like automatic snapshots
;; instead of storing a materialized copy.
(let [profile (th/create-profile* 1)
file (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared false})
file-id (:id file)
page-id (first (get-in file [:data :pages]))
before (live-fragment-ids file-id)
out (th/command! {::th/type :create-file-snapshot
::rpc/profile-id (:id profile)
:file-id file-id
:label "v1"})
_ (t/is (nil? (:error out)))
snap-id (:id (:result out))]
;; No new fragment rows: the version reuses the live ones.
(t/is (uuid? snap-id))
(t/is (= before (live-fragment-ids file-id)))
;; The version pointers are a subset of the live pointers.
(let [live (fdata/get-used-pointer-ids
(:data (bfc/get-file th/*system* file-id)))
snap (fdata/get-used-pointer-ids
(:data (fsnap/get-snapshot th/*system* file-id snap-id)))]
(t/is (pos? (count snap)))
(t/is (every? #(contains? live %) snap)))
(let [shape-id (uuid/random)]
;; Modify the file, then restore the version and compare resolved
;; content with the version preview (both materialized).
(update-file! :profile-id (:id profile)
:file-id file-id
:revn 0
:changes [{:type :add-obj
:page-id page-id
:id shape-id
:parent-id uuid/zero
:frame-id uuid/zero
:components-v2 true
:obj (cts/setup-shape
{:id shape-id
:name "rect"
:frame-id uuid/zero
:parent-id uuid/zero
:type :rect})}]))
(let [preview-out (th/command! {::th/type :get-file-snapshot
::rpc/profile-id (:id profile)
:file-id file-id
:id snap-id
:features cfeat/supported-features})
_ (t/is (nil? (:error preview-out)))
preview (:result preview-out)
restore-out (th/command! {::th/type :restore-file-snapshot
::rpc/profile-id (:id profile)
:file-id file-id
:id snap-id})
_ (t/is (nil? (:error restore-out)))
live (:data (bfc/get-file th/*system* file-id :realize? true))
;; The preview resolves pointers but keeps objects-maps
;; encoded; realize them too so both sides are plain data.
preview-data (:data (fdata/realize-objects
nil {:data (:data preview)}))]
(t/is (= preview-data live)))))
(t/deftest user-snapshot-of-file-needing-migration-is-materialized
;; A file with pending migrations cannot share fragments: the
;; migration path realizes the data, so the stored snapshot holds
;; plain maps. This pins the shape so it cannot drift silently.
(let [profile (th/create-profile* 1)
file (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared false})
file-id (:id file)]
(th/db-update! :file {:version (dec (:version file))} {:id file-id})
(let [out (th/command! {::th/type :create-file-snapshot
::rpc/profile-id (:id profile)
:file-id file-id
:label "v1"})
_ (t/is (nil? (:error out)))
snap-id (:id (:result out))
snap (fsnap/get-snapshot th/*system* file-id snap-id)]
(t/is (uuid? snap-id))
(t/is (empty? (fdata/get-used-pointer-ids (:data snap))))
;; ...while preview keeps working on the migrated content.
(let [preview (th/command! {::th/type :get-file-snapshot
::rpc/profile-id (:id profile)
:file-id file-id
:id snap-id
:features cfeat/supported-features})]
(t/is (nil? (:error preview)))
(t/is (map? (get-in preview [:result :data])))))))
(t/deftest snapshots-locking
(let [profile-1 (th/create-profile* 1 {:is-active true})
profile-2 (th/create-profile* 2 {:is-active true})
@ -220,3 +378,364 @@
;; (th/print-result! out)
(t/is (nil? (:error out)))
(t/is (true? (:result out)))))))
(t/deftest snapshot-creation-serializes-with-file-gc
;; A user snapshot shares fragment rows with the live file, so its
;; creation must serialize with a concurrent :file-gc pass (which
;; takes FOR UPDATE + SKIP LOCKED on the file row): creation holds
;; FOR SHARE, the GC skips locked files instead of racing it.
(let [profile (th/create-profile* 1)
file (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared false})
file-id (:id file)]
(t/testing "gc skips a file locked for share"
(db/tx-run! th/*system*
(fn [cfg]
;; Hold FOR SHARE to commit, like create-file-snapshot does.
(bfc/get-file cfg file-id :lock-for-share? true)
;; The GC uses SKIP LOCKED on a different connection, so it
;; must skip instead of blocking or marking.
(t/is (not (th/run-task! :file-gc {:file-id file-id}))))))
(t/testing "creation cannot slip between gc scan and mark"
;; Deterministic interleaving: pause the GC right after its
;; snapshot scan, then create a snapshot. With the FOR SHARE lock
;; the creation waits at the read and sees post-GC fragment ids;
;; without it, it reads pre-GC ids and pins a fragment the pass
;; is about to mark.
(let [orig-reduce @#'fsnap/reduce-snapshots
orig-create @#'fsnap/create!
scan-started (promise)
release-scan (promise)
reached-insert (promise)
do-create (fn []
(th/command! {::th/type :create-file-snapshot
::rpc/profile-id (:id profile)
:file-id file-id
:label "pinned"}))]
(with-redefs [fsnap/reduce-snapshots
(fn [cfg file-id xform f init]
(deliver scan-started true)
@release-scan
(orig-reduce cfg file-id xform f init))
fsnap/create!
(fn [& args]
(deliver reached-insert true)
(apply orig-create args))]
(let [gc-done (future (th/run-task! :file-gc {:file-id file-id}))]
(t/is (= true (deref scan-started 10000 ::timeout)))
(let [created (future (do-create))]
;; The creation must not reach the insert while the GC
;; pass holds the file row: with FOR SHARE it waits at the
;; read instead of snapshotting pre-GC fragment ids.
(t/is (= ::timeout (deref reached-insert 10000 ::timeout)))
(deliver release-scan true)
(t/is (some? (deref gc-done 30000 ::timeout)))
(let [out (deref created 30000 ::timeout)]
(t/is (not= ::timeout out))
(t/is (nil? (:error out)))
(t/is (uuid? (get-in out [:result :id])))))))))
(t/testing "snapshot taken around gc still resolves"
;; The racing pass marks nothing (the file is unchanged, so
;; reattach keeps every id), therefore there is nothing to purge;
;; the snapshot keeps resolving afterwards.
(t/is (zero? (:processed (th/run-task! :objects-gc {}))))
(t/is (true? (th/run-task! :file-gc {:file-id file-id})))
;; The pinned snapshot (not an arbitrary autosnapshot: those may
;; reference fragments an earlier pass already marked) must keep
;; resolving after another GC cycle.
(let [snap-id (->> (th/db-query :file-change {:file-id file-id} {:order-by [:created-at]})
(filter #(= "pinned" (:label %)))
(first)
(:id))
out (th/command! {::th/type :get-file-snapshot
::rpc/profile-id (:id profile)
:file-id file-id
:id snap-id
:features cfeat/supported-features})]
(t/is (uuid? snap-id))
(t/is (nil? (:error out)))
(t/is (empty? (fdata/get-used-pointer-ids
(get-in out [:result :data]))))))))
(t/deftest restore-backup-serializes-with-file-gc
;; The backup snapshot taken by restore shares fragment rows with
;; the live file, so its creation must serialize with a concurrent
;; :file-gc pass, like ::create-file-snapshot does: with FOR SHARE
;; held by the GC pass, the restore waits at the locked read instead
;; of snapshotting pre-GC fragment ids that the pass is about to
;; mark as deleted.
(let [profile (th/create-profile* 1)
file (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared false})
file-id (:id file)
page-id (first (get-in file [:data :pages]))
shape-id (uuid/random)
snap-id (:id (:result (th/command! {::th/type :create-file-snapshot
::rpc/profile-id (:id profile)
:file-id file-id
:label "v1"})))]
(t/is (uuid? snap-id))
(update-file! :profile-id (:id profile)
:file-id file-id
:revn 0
:changes [{:type :add-obj
:page-id page-id
:id shape-id
:parent-id uuid/zero
:frame-id uuid/zero
:components-v2 true
:obj (cts/setup-shape
{:id shape-id
:name "rect"
:frame-id uuid/zero
:parent-id uuid/zero
:type :rect})}])
(let [orig-reduce @#'fsnap/reduce-snapshots
orig-create @#'fsnap/create!
scan-started (promise)
release-scan (promise)
reached-insert (promise)
do-restore (fn []
(th/command! {::th/type :restore-file-snapshot
::rpc/profile-id (:id profile)
:file-id file-id
:id snap-id}))]
(with-redefs [fsnap/reduce-snapshots
(fn [cfg file-id xform f init]
(deliver scan-started true)
@release-scan
(orig-reduce cfg file-id xform f init))
fsnap/create!
(fn [& args]
(deliver reached-insert true)
(apply orig-create args))]
(let [gc-done (future (th/run-task! :file-gc {:file-id file-id}))]
(t/is (= true (deref scan-started 10000 ::timeout)))
(let [restored (future (do-restore))]
(t/is (= ::timeout (deref reached-insert 10000 ::timeout)))
(deliver release-scan true)
(t/is (some? (deref gc-done 30000 ::timeout)))
(let [out (deref restored 30000 ::timeout)]
(t/is (not= ::timeout out))
(t/is (nil? (:error out))))))))
(let [backup-ids (->> (th/db-query :file-change {:file-id file-id})
(map (juxt :id :label))
(filter (fn [[_ label]]
(and (string? label)
(str/starts-with? label "snapshot-"))))
(map first)
(set))
backup-ids (set/intersection
backup-ids
(into #{}
(map :id)
(th/db-query :file-data {:file-id file-id
:type "snapshot"})))
live (into #{}
(map :id)
(filter #(nil? (:deleted-at %))
(th/db-query :file-data {:file-id file-id
:type "fragment"})))]
(t/is (= 1 (count backup-ids)))
(doseq [backup-id backup-ids
:let [snap (fsnap/get-snapshot th/*system* file-id backup-id)]]
(t/is (every? live (fdata/get-used-pointer-ids (:data snap))))
(let [out (th/command! {::th/type :get-file-snapshot
::rpc/profile-id (:id profile)
:file-id file-id
:id backup-id
:features cfeat/supported-features})]
(t/is (nil? (:error out)))
(t/is (empty? (fdata/get-used-pointer-ids
(get-in out [:result :data])))))))))
(t/deftest snapshot-preview-applies-pending-migrations
;; A snapshot taken while a migration was pending stores the old
;; format. The preview must apply the pending migration in memory
;; (the same pure step a normal read runs) instead of handing the old
;; format to the UI, and must not persist anything: the stored
;; version keeps its data so restoring it re-migrates on next read.
(let [profile (th/create-profile* 1)
file (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared false})
file-id (:id file)
page-id (first (get-in file [:data :pages]))
shape-id (uuid/random)]
(update-file! :profile-id (:id profile)
:file-id file-id
:revn 0
:changes [{:type :add-obj
:page-id page-id
:id shape-id
:parent-id uuid/zero
:frame-id uuid/zero
:components-v2 true
:obj (-> (cts/setup-shape {:id shape-id
:name "rect"
:frame-id uuid/zero
:parent-id uuid/zero
:type :rect})
(assoc :applied-tokens {:stroke-width "token"}))}])
;; Force the 0031 migration on the next save.
(th/db-delete! :file-migration {:file-id file-id
:name "0031-migrate-stroke-width-token-attr"})
(update-file! :profile-id (:id profile)
:file-id file-id
:revn 1
:changes [{:type :add-page :name "b" :id (uuid/random)}])
(let [snapshot (->> (th/db-query :file-change {:file-id file-id})
(filter #(and (some? (:label %))
(= 1 (:revn %))))
(first))
snapshot-id (:id snapshot)
stored (fdata/realize th/*system*
(assoc (fsnap/get-snapshot th/*system* file-id snapshot-id)
:id file-id))
out (th/command! {::th/type :get-file-snapshot
::rpc/profile-id (:id profile)
:file-id file-id
:id snapshot-id
:features cfeat/supported-features})]
(t/is (uuid? snapshot-id))
;; The stored version keeps the old format and the pending
;; migration: the preview must not touch the stored row.
(t/is (not (contains? (set (:migrations stored))
"0031-migrate-stroke-width-token-attr")))
(t/is (= {:stroke-width "token"}
(get-in stored [:data :pages-index page-id
:objects shape-id :applied-tokens])))
;; The preview migrates it in memory.
(t/is (nil? (:error out)))
(t/is (= file-id (get-in out [:result :data :id])))
(let [tokens (get-in out [:result :data :pages-index page-id
:objects shape-id :applied-tokens])]
(t/is (not (contains? tokens :stroke-width)))
(t/is (contains? tokens :stroke-width-top))
(t/is (contains? tokens :stroke-width-bottom)))
;; The preview declared the migrated set in the payload.
(t/is (contains? (set (get-in out [:result :migrations]))
"0031-migrate-stroke-width-token-attr")))
;; Nothing was persisted by the preview.
(let [snapshot-id (:id (->> (th/db-query :file-change {:file-id file-id})
(filter #(and (some? (:label %))
(= 1 (:revn %))))
(first)))
stored (fdata/realize th/*system*
(assoc (fsnap/get-snapshot th/*system* file-id snapshot-id)
:id file-id))]
(t/is (= {:stroke-width "token"}
(get-in stored [:data :pages-index page-id
:objects shape-id :applied-tokens]))))))
(t/deftest snapshot-preview-realizes-objects-for-clients-without-the-feature
;; `:features` works like in `get-file`: a client that does not
;; declare `fdata/objects-map` receives plain objects instead of the
;; storage structure of the fragment.
(let [profile (th/create-profile* 1)
file (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared false})
file-id (:id file)
page-id (first (get-in file [:data :pages]))
shape-id (uuid/random)
_ (update-file! :profile-id (:id profile)
:file-id file-id
:revn 0
:changes [{:type :add-obj
:page-id page-id
:id shape-id
:parent-id uuid/zero
:frame-id uuid/zero
:components-v2 true
:obj (cts/setup-shape
{:id shape-id
:name "rect"
:frame-id uuid/zero
:parent-id uuid/zero
:type :rect})}])
snapshot-id (:id (:result (th/command! {::th/type :create-file-snapshot
::rpc/profile-id (:id profile)
:file-id file-id
:label "v1"})))
preview (fn [features]
(th/command! {::th/type :get-file-snapshot
::rpc/profile-id (:id profile)
:file-id file-id
:id snapshot-id
:features features}))
with-feature (preview cfeat/supported-features)
without-feature (preview (disj cfeat/supported-features
"fdata/objects-map"))]
(t/is (nil? (:error with-feature)))
(t/is (nil? (:error without-feature)))
(t/is (omap/objects-map?
(get-in with-feature [:result :data :pages-index page-id :objects])))
(t/is (not (omap/objects-map?
(get-in without-feature [:result :data :pages-index page-id :objects]))))))
(t/deftest snapshot-preview-migrates-legacy-snapshots-without-migrations
;; Snapshots written before the `migrations` column existed (SQL
;; migration 0140) store NULL and the format version of their time.
;; The decoder must hand an ordered set (a vector would make
;; `need-migration?` compare indexes), and the preview must
;; regenerate the applied set from the stored version, migrate the
;; data in memory and leave the row untouched.
(let [profile (th/create-profile* 1)
file (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared false})
file-id (:id file)
snap-id (:id (:result (th/command! {::th/type :create-file-snapshot
::rpc/profile-id (:id profile)
:file-id file-id
:label "legacy"})))]
(t/is (d/ordered-set? (:migrations (fsnap/get-snapshot th/*system* file-id snap-id))))
;; Turn the version into a pre-0140 snapshot: no applied set and an
;; old format version.
(th/db-exec! ["UPDATE file_change SET migrations = NULL, version = 60 WHERE id = ?"
snap-id])
(let [stored (fsnap/get-snapshot th/*system* file-id snap-id)
out (th/command! {::th/type :get-file-snapshot
::rpc/profile-id (:id profile)
:file-id file-id
:id snap-id
:features cfeat/supported-features})
result (:result out)]
(t/is (nil? (:migrations stored)))
(t/is (= 60 (:version stored)))
(t/is (nil? (:error out)))
(t/is (d/ordered-set? (:migrations result)))
;; The preview regenerates everything the stored version lacks
;; instead of trusting the absent applied set.
(t/is (= cfd/version (:version result)))
(t/is (= (into #{} fmg/available-migrations)
(set (:migrations result))))
(t/is (set/subset? (into #{} (fmg/generate-migrations-from-version cfd/version))
(set (:migrations result))))
;; Nothing is persisted.
(let [stored (fsnap/get-snapshot th/*system* file-id snap-id)]
(t/is (nil? (:migrations stored)))
(t/is (= 60 (:version stored)))))))

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

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

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

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

433
backend/test/backend_tests/rpc_file_update_repair_test.clj Normal file
View File

@ -0,0 +1,433 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS SUBSIDIARY SL
(ns backend-tests.rpc-file-update-repair-test
(:require
[app.binfile.common :as bfc]
[app.common.features :as cfeat]
[app.common.files.repair :as cfr]
[app.common.files.validate :as cfv]
[app.common.test-helpers.compositions :as tho]
[app.common.test-helpers.files :as thf]
[app.common.test-helpers.ids-map :as thi]
[app.common.test-helpers.shapes :as ths]
[app.common.types.shape :as cts]
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
[app.features.file-snapshots :as fsnap]
[app.metrics :as mtx]
[app.msgbus :as mbus]
[app.rpc :as-alias rpc]
[app.rpc.commands.files-update :as files-update]
[app.srepl.procs.file-repair :as file-repair]
[app.util.pointer-map :as pmap]
[backend-tests.helpers :as th]
[clojure.test :as t])
(:import
io.prometheus.client.CollectorRegistry))
(t/use-fixtures :once th/state-init)
(t/use-fixtures :each th/database-reset)
(defn- with-repair-flags
[f]
(with-redefs [cf/flags (conj cf/flags :file-validation)]
(f)))
(defn- with-full-repair-flags
[f]
(with-redefs [cf/flags (conj cf/flags :file-validation :file-schema-validation)]
(f)))
(defn- repair-count
[outcome]
(or (.getSampleValue ^CollectorRegistry
(mtx/get-registry (::mtx/metrics th/*system*))
"penpot_rpc_update_file_repair_total"
(into-array String ["outcome"])
(into-array String [(name outcome)]))
0.0))
(defn- add-rect
[page-id shape-id]
{:type :add-obj
:page-id page-id
:id shape-id
:parent-id uuid/zero
:frame-id uuid/zero
:components-v2 true
:obj (cts/setup-shape
{:id shape-id
:name "rect"
:frame-id uuid/zero
:parent-id uuid/zero
:type :rect})})
(defn- set-attr
[page-id shape-id attr val]
{:type :mod-obj
:id shape-id
:page-id page-id
:operations [{:type :set :attr attr :val val}]})
(defn- update-file
[profile-id file-id revn changes & {:keys [skip-validate session-id]
:or {session-id (uuid/random)}}]
(th/command! (cond-> {::th/type :update-file
::rpc/profile-id profile-id
:id file-id
:session-id session-id
:revn revn
:vern 0
:features cfeat/supported-features
:changes changes}
skip-validate (assoc :skip-validate true))))
(defn- stored-file
[file-id]
(bfc/get-file th/*system* file-id :realize? true))
(defn- change-rows
[file-id]
(->> (th/db-query :file-change {:file-id file-id} {::db/remove-deleted false})
(filter (fn [row]
(and (some? (:changes row))
(nil? (:label row)))))
(sort-by :created-at)
(vec)))
(defn- label-rows
[file-id]
(->> (th/db-query :file-change {:file-id file-id} {::db/remove-deleted false})
(filter :label)
(vec)))
(defn- pointer-map-in?
[x]
(cond
(pmap/pointer-map? x) true
(map? x) (boolean (some pointer-map-in? (vals x)))
(sequential? x) (boolean (some pointer-map-in? x))
:else false))
(defn- setup-file
[& {:keys [is-shared] :or {is-shared false}}]
(let [profile (th/create-profile* 1 {:is-active true})
file (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared is-shared})
page-id (first (get-in file [:data :pages]))
shape-a (uuid/next)
shape-b (uuid/next)
out (update-file (:id profile) (:id file) 0
[(add-rect page-id shape-a)
(add-rect page-id shape-b)])]
(t/is (th/success? out))
{:profile profile
:file-id (:id file)
:page-id page-id
:shape-a shape-a
:shape-b shape-b
:revn (:revn (stored-file (:id file)))}))
(defn- break-frame
[{:keys [profile file-id page-id shape-a revn]}]
(let [out (update-file (:id profile) file-id revn
[(set-attr page-id shape-a :frame-id (uuid/next))]
:skip-validate true)]
(t/is (th/success? out))
(stored-file file-id)))
(t/deftest repairs-preexisting-frame-not-found
(with-repair-flags
(fn []
(let [{:keys [profile file-id page-id shape-a shape-b] :as ctx} (setup-file)
broken (break-frame ctx)
before (repair-count :repaired)
out (update-file (:id profile) file-id (:revn broken)
[(set-attr page-id shape-b :name "renamed")])
stored (stored-file file-id)
shape (get-in stored [:data :pages-index page-id :objects shape-a])
frame (get-in stored [:data :pages-index page-id :objects (:frame-id shape)])]
(t/is (th/success? out))
(t/is (nil? (cfv/validate-file stored {})))
(t/is (some? frame))
(t/is (= "renamed"
(get-in stored [:data :pages-index page-id :objects shape-b :name])))
(t/is (= 1.0 (- (repair-count :repaired) before)))))))
(t/deftest repairs-preexisting-frame-not-found-with-schema-validation
(with-full-repair-flags
(fn []
(let [{:keys [profile file-id page-id shape-a shape-b] :as ctx} (setup-file)
broken (break-frame ctx)
n (:revn broken)
before-repaired (repair-count :repaired)
before-unrepaired (repair-count :unrepaired)
out (update-file (:id profile) file-id n
[(set-attr page-id shape-b :name "renamed")])
stored (stored-file file-id)
shape (get-in stored [:data :pages-index page-id :objects shape-a])
frame (get-in stored [:data :pages-index page-id :objects (:frame-id shape)])
labels (label-rows file-id)
repair (filter #(= (str "internal/repair/" n) (:label %)) labels)
snap (filter #(= (str "internal/snapshot/" n) (:label %)) labels)]
(t/is (th/success? out))
(t/is (nil? (cfv/validate-file stored {})))
(t/is (some? frame))
(t/is (= "renamed"
(get-in stored [:data :pages-index page-id :objects shape-b :name])))
(t/is (= (+ n 2) (:revn stored)))
(t/is (= 1 (count repair)))
(t/is (zero? (count snap)))
(t/is (= 1.0 (- (repair-count :repaired) before-repaired)))
(t/is (= 0.0 (- (repair-count :unrepaired) before-unrepaired)))))))
(t/deftest rejects-client-caused-break
(with-repair-flags
(fn []
(let [{:keys [profile file-id page-id shape-a revn]} (setup-file)
before (stored-file file-id)
out (update-file (:id profile) file-id revn
[(set-attr page-id shape-a :frame-id (uuid/next))])
after (stored-file file-id)]
(t/is (not (th/success? out)))
(t/is (= :referential-integrity (:code (ex-data (:error out)))))
(t/is (= (:revn before) (:revn after)))))))
(t/deftest skip-validate-does-not-repair
(with-repair-flags
(fn []
(let [{:keys [profile file-id page-id shape-a shape-b] :as ctx} (setup-file)
broken (break-frame ctx)
out (update-file (:id profile) file-id (:revn broken)
[(set-attr page-id shape-b :name "renamed")]
:skip-validate true)
stored (stored-file file-id)
shape (get-in stored [:data :pages-index page-id :objects shape-a])]
(t/is (th/success? out))
(t/is (nil? (get-in stored [:data :pages-index page-id :objects (:frame-id shape)])))))))
(t/deftest damage-on-untouched-page-is-left
(with-repair-flags
(fn []
(let [{:keys [profile file-id page-id shape-a revn]} (setup-file)
page-2 (uuid/next)
shape-c (uuid/next)
_ (t/is (th/success?
(update-file (:id profile) file-id revn
[{:type :add-page :id page-2 :name "page-2"}
(add-rect page-2 shape-c)])))
file (stored-file file-id)
_ (t/is (th/success?
(update-file (:id profile) file-id (:revn file)
[(set-attr page-2 shape-c :frame-id (uuid/next))]
:skip-validate true)))
file (stored-file file-id)
out (update-file (:id profile) file-id (:revn file)
[(set-attr page-id shape-a :name "on-page-1")])
stored (stored-file file-id)
shape (get-in stored [:data :pages-index page-2 :objects shape-c])]
(t/is (th/success? out))
(t/is (nil? (get-in stored [:data :pages-index page-2 :objects (:frame-id shape)])))))))
(t/deftest growing-scope-repairs-component-touched-by-repair
(thi/reset-idmap!)
(with-repair-flags
(fn []
(let [file (-> (thf/sample-file :file1 :page-label :page1)
(assoc :revn 0)
(tho/add-simple-component :component1 :root1 :child1)
(ths/add-sample-shape :other)
(update-in [:data :components (thi/id :component1)]
assoc :main-instance-id (uuid/next)
:objects {(uuid/next) {:id (uuid/next)}}))
page-id (thi/id :page1)
changes [(set-attr page-id (thi/id :other) :name "renamed")]
cfg {::files-update/validation-timings (atom {})}
result (with-redefs [bfc/get-resolved-file-libraries (fn [_ _] {})]
(@#'files-update/process-changes-and-validate cfg file changes nil))
stored result]
(t/is (some? (::files-update/repair stored)))
(t/is (nil? (cfv/validate-file stored {})))
(t/is (nil? (get-in stored [:data :components (thi/id :component1) :objects])))))))
(t/deftest repair-records-timings-with-schema-validation
(thi/reset-idmap!)
(with-full-repair-flags
(fn []
(let [file (-> (thf/sample-file :file1 :page-label :page1)
(assoc :revn 0)
(ths/add-sample-shape :shape1)
(ths/update-shape :shape1 :frame-id (uuid/next)))
changes [(set-attr (thi/id :page1) (thi/id :shape1) :name "renamed")]
timings (atom {})
cfg {::files-update/validation-timings timings}
result (with-redefs [bfc/get-resolved-file-libraries (fn [_ _] {})]
(@#'files-update/process-changes-and-validate cfg file changes nil))]
(t/is (some? (::files-update/repair result)))
(t/is (number? (:repair-ms @timings)))
(t/is (number? (:reprocess-changes-ms @timings)))
(t/is (number? (:validate-schema-ms @timings)))))))
(t/deftest unrepairable-rejects-and-calls-repair-once
(with-repair-flags
(fn []
(let [{:keys [profile file-id page-id shape-b] :as ctx} (setup-file)
broken (break-frame ctx)
calls (atom 0)
before (repair-count :unrepaired)
out (with-redefs [cfr/repair-file (fn [_ _ _]
(swap! calls inc)
[])]
(update-file (:id profile) file-id (:revn broken)
[(set-attr page-id shape-b :name "renamed")]))]
(t/is (not (th/success? out)))
(t/is (= :referential-integrity (:code (ex-data (:error out)))))
(t/is (= 1 @calls))
(t/is (= 1.0 (- (repair-count :unrepaired) before)))))))
(t/deftest repair-writes-change-rows-and-reuses-snapshot
(with-repair-flags
(fn []
(let [{:keys [profile file-id page-id shape-b] :as ctx} (setup-file)
broken (break-frame ctx)
before (count (change-rows file-id))
session (uuid/next)
calls (atom [])
n (:revn broken)
out (with-redefs [mbus/pub! (fn [_cfg & {:keys [topic message]}]
(swap! calls conj {:topic topic :message message}))]
(update-file (:id profile) file-id n
[(set-attr page-id shape-b :name "renamed")]
:session-id session))
rows (change-rows file-id)
new (subvec rows before)
labels (label-rows file-id)
repair (filter #(= (str "internal/repair/" n) (:label %)) labels)
snap (filter #(= (str "internal/snapshot/" n) (:label %)) labels)
msgs (filter #(= :file-change (:type (:message %))) @calls)
stored (stored-file file-id)]
(t/is (th/success? out))
(t/is (= "renamed"
(get-in stored [:data :pages-index page-id :objects shape-b :name])))
(t/is (= 2 (count new)))
(t/is (= (inc n) (:revn (first new))))
(t/is (= files-update/repair-session-id (:session-id (first new))))
(t/is (some? (:deleted-at (first new))))
(t/is (= (:created-at (first new)) (:updated-at (first new))))
(t/is (= (+ n 2) (:revn (second new))))
(t/is (= session (:session-id (second new))))
(t/is (some? (:deleted-at (second new))))
(t/is (= (:created-at (second new)) (:updated-at (second new))))
(t/is (not (pos? (compare (:created-at (first new))
(:created-at (second new))))))
(t/is (= 1 (count repair)))
(t/is (zero? (count snap)))
(t/is (>= (count msgs) 2))
(t/is (true? (get-in (first msgs) [:message :repaired])))
(t/is (= files-update/repair-session-id
(get-in (first msgs) [:message :session-id])))
(t/is (= session (get-in (second msgs) [:message :session-id])))
(t/is (not (true? (get-in (second msgs) [:message :repaired]))))
(t/is (= (+ n 2) (get-in (second msgs) [:message :revn])))))))
(t/deftest repair-library-change-keeps-saver-session
(with-repair-flags
(fn []
(let [{:keys [profile file-id page-id shape-b] :as ctx} (setup-file :is-shared true)
broken (break-frame ctx)
session (uuid/next)
calls (atom [])
out (with-redefs [mbus/pub! (fn [_cfg & {:keys [topic message]}]
(swap! calls conj {:topic topic :message message}))]
(update-file (:id profile) file-id (:revn broken)
[(set-attr page-id shape-b :name "renamed")]
:session-id session))
lib-msgs (filter #(= :library-change (:type (:message %))) @calls)]
(t/is (th/success? out))
(t/is (seq lib-msgs))
(doseq [msg lib-msgs]
(t/is (= session (get-in msg [:message :session-id])))
(t/is (not= files-update/repair-session-id
(get-in msg [:message :session-id]))))))))
(t/deftest repair-snapshot-without-auto-snapshot
(with-redefs [cf/flags (-> cf/flags
(conj :file-validation)
(disj :auto-file-snapshot))]
(let [{:keys [profile file-id page-id shape-b] :as ctx} (setup-file)
broken (break-frame ctx)
n (:revn broken)
out (update-file (:id profile) file-id n
[(set-attr page-id shape-b :name "renamed")])
labels (label-rows file-id)
repair (filter #(= (str "internal/repair/" n) (:label %)) labels)
snaps (filter #(re-find #"^internal/snapshot/" (str (:label %))) labels)
row (first repair)
snap (fsnap/get-snapshot th/*system* file-id (:id row))
sfile {:id file-id
:features (:features (stored-file file-id))
:data (:data snap)}]
(t/is (th/success? out))
(t/is (= 1 (count repair)))
(t/is (zero? (count snaps)))
(t/is (false? (pointer-map-in? (:data snap))))
(t/is (some? (cfv/validate-file sfile {}))))))
(t/deftest srepl-repair-grows-revn-by-iterations
(thi/reset-idmap!)
(let [file (-> (thf/sample-file :file1 :page-label :page1)
(assoc :revn 3)
(ths/add-sample-shape :shape1)
(ths/update-shape :shape1 :frame-id (uuid/next)))
loop (cfr/repair-file-until-valid
file {}
(fn [file _] (cfv/validate-file file {})))
wrapped (file-repair/repair-file file {})]
(t/is (pos? (:iterations loop)))
(t/is (= (+ (:revn file) (:iterations loop)) (:revn wrapped)))
(t/is (nil? (cfv/validate-file wrapped {})))))
(t/deftest healthy-save-writes-one-change-row
(with-repair-flags
(fn []
(let [{:keys [profile file-id page-id shape-b revn]} (setup-file)
before (count (change-rows file-id))
out (update-file (:id profile) file-id revn
[(set-attr page-id shape-b :name "ok")])
labels (label-rows file-id)]
(t/is (th/success? out))
(t/is (= 1 (- (count (change-rows file-id)) before)))
(t/is (empty? (filter #(re-find #"^internal/repair/" (str (:label %))) labels)))))))
(t/deftest repairs-several-missing-children-on-root
(with-full-repair-flags
(fn []
(let [{:keys [profile file-id page-id shape-a shape-b revn]} (setup-file)
r1 (uuid/next)
r2 (uuid/next)
r3 (uuid/next)
_ (t/is (th/success?
(update-file (:id profile) file-id revn
[(set-attr page-id uuid/zero :shapes
[shape-a shape-b r1 r2 r3])]
:skip-validate true)))
broken (stored-file file-id)
errors (cfv/validate-file broken {})
out (update-file (:id profile) file-id (:revn broken)
[(set-attr page-id shape-b :name "renamed")])
stored (stored-file file-id)
root (get-in stored [:data :pages-index page-id :objects uuid/zero])]
(t/is (= [:child-not-found :child-not-found :child-not-found]
(mapv :code errors)))
(t/is (= #{uuid/zero} (into #{} (map :shape-id) errors)))
(t/is (th/success? out))
(t/is (= [shape-a shape-b] (:shapes root)))
(t/is (nil? (cfv/validate-file stored {})))
(t/is (= "renamed"
(get-in stored [:data :pages-index page-id :objects shape-b :name])))))))

47
backend/test/backend_tests/rpc_management_nitrate_test.clj
View File

@ -251,6 +251,53 @@
(t/is (false? (get-in teams-by-id [(:id owned-team) :is-default])))
(t/is (false? (get-in teams-by-id [(:id member-team) :is-default])))))))
(t/deftest get-organization-member-teams-returns-roles-within-given-teams
(with-mocks [nitrate-mock {:target 'app.nitrate/call :return nil}]
(let [profile (th/create-profile* 1 {:is-active true})
other (th/create-profile* 2 {:is-active true})
owned-team (th/create-team* 1 {:profile-id (:id profile)})
admin-team (th/create-team* 2 {:profile-id (:id other)})
editor-team (th/create-team* 3 {:profile-id (:id other)})
viewer-team (th/create-team* 4 {:profile-id (:id other)})
foreign-team (th/create-team* 5 {:profile-id (:id other)})
not-member (th/create-team* 6 {:profile-id (:id other)})
deleted-team (th/create-team* 7 {:profile-id (:id profile)})
_ (th/db-update! :team
{:deleted-at (ct/now)}
{:id (:id deleted-team)})
_ (doseq [[team role] [[admin-team :admin]
[editor-team :editor]
[viewer-team :viewer]
[foreign-team :editor]]]
(th/create-team-role* {:team-id (:id team)
:profile-id (:id profile)
:role role}))
team-ids (mapv :id [owned-team admin-team editor-team viewer-team
not-member deleted-team
{:id (:default-team-id profile)}])
out (th/management-command! {::th/type :get-organization-member-teams
::rpc/profile-id (:id other)
:profile-id (:id profile)
:team-ids team-ids})]
(t/is (th/success? out))
(t/is (= {(:id owned-team) :owner
(:id admin-team) :admin
(:id editor-team) :editor
(:id viewer-team) :viewer}
(->> out :result (map (juxt :id :role)) (into {}))))
(t/is (= (:name owned-team)
(->> out :result (d/seek #(= (:id owned-team) (:id %))) :name))))))
(t/deftest get-organization-member-teams-empty-team-ids
(with-mocks [nitrate-mock {:target 'app.nitrate/call :return nil}]
(let [profile (th/create-profile* 1 {:is-active true})
out (th/management-command! {::th/type :get-organization-member-teams
::rpc/profile-id (:id profile)
:profile-id (:id profile)
:team-ids []})]
(t/is (th/success? out))
(t/is (= [] (:result out))))))
(t/deftest update-profile-theme-updates-only-theme
(with-mocks [nitrate-mock {:target 'app.nitrate/call :return nil}]
(let [profile (th/create-profile* 1 {:is-active true

25
backend/test/backend_tests/rpc_test.clj
View File

@ -902,6 +902,27 @@
(t/is (some? ex))
(t/is (th/ex-of-type? ex :not-found))))
;; --- TOKEN TYPE RESTRICTIONS
(t/deftest mcp-token-authentication
(let [pid (uuid/custom 1 1)
method (fn [mdata]
(rpc/make-rpc-handler
{:test-method [mdata (partial (#'rpc/wrap-authentication
nil (fn [_ params] params) mdata)
nil)]}))
handler (method {::rpc/auth-type :token ::rpc/token-type "mcp"})]
(doseq [extras [{::session/profile-id pid}
{::actoken/profile-id pid}
{::actoken/profile-id pid ::actoken/type "personal"}]]
(t/is (th/ex-of-code? (call-ex handler {:extras extras}) :token-auth-required)))
(let [extras {::actoken/profile-id pid ::actoken/type "mcp"}]
(t/is (= "mcp" (::rpc/token-type (call-body handler {:extras extras}))))
(t/is (th/ex-of-code? (call-ex (method {}) {:extras extras}) :token-auth-required)))
(t/is (= pid (::rpc/profile-id
(call-body (method {}) {:extras {::actoken/profile-id pid
::actoken/type "personal"}}))))))
;; --- PARAMS VALIDATION: SERVER AUTH CONTEXT VS CLIENT PARAMS
(t/deftest client-qualified-keys-do-not-override-server-auth-context
@ -915,7 +936,8 @@
request {:params {:name "valid"
:app.rpc/profile-id attacker-pid
:app.rpc/auth-type :token
:app.rpc/token-perms #{"admin"}}}
:app.rpc/token-perms #{"admin"}
:app.rpc/token-type "mcp"}}
params (with-meta {::rpc/profile-id server-pid
::rpc/auth-type :session}
{::http/request request})]
@ -923,6 +945,7 @@
(t/is (= server-pid (::rpc/profile-id @captured)))
(t/is (= :session (::rpc/auth-type @captured)))
(t/is (not (contains? @captured ::rpc/token-perms)))
(t/is (not (contains? @captured ::rpc/token-type)))
(t/is (= "valid" (:name @captured)))))
;; --- RESPONSE: NIL BODY WITH CUSTOM HEADERS

101
backend/test/backend_tests/srepl_main_test.clj
View File

@ -205,3 +205,104 @@
;; to the zero one.
(t/is (nil? (:profile-id event)))
(t/is (= (:id profile) (get-in event [:props :id])))))))))
(t/deftest update-profile-email-changes-email
(with-mocks [audit-mock {:target 'app.loggers.audit/insert :return nil}]
(with-redefs [sys/system th/*system*]
(let [profile (th/create-profile* 1 {:is-active true})
result (srepl/update-profile-email!
:email (:email profile)
:new-email "corrected@example.com")]
(t/is (= :updated result))
(t/is (= "corrected@example.com"
(:email (th/db-get :profile {:id (:id profile)}))))
(let [event (->> (:call-args-list @audit-mock)
(map second)
first)]
(t/is (= "update-profile-email" (:name event)))
(t/is (= "action" (:type event)))
(t/is (= (:id profile) (get-in event [:props :id])))
(t/is (= (:email profile) (get-in event [:props :email])))
(t/is (= "corrected@example.com"
(get-in event [:props :new-email]))))))))
(t/deftest update-profile-email-rejects-collision
(with-redefs [sys/system th/*system*]
(let [profile1 (th/create-profile* 1 {:is-active true})
profile2 (th/create-profile* 2 {:is-active true})
error (try
(srepl/update-profile-email!
:email (:email profile1)
:new-email (:email profile2))
(catch Throwable e e))]
(t/is (th/ex-of-code? error :email-already-exists))
(t/is (= (:email profile1)
(:email (th/db-get :profile {:id (:id profile1)})))))))
(t/deftest update-profile-email-unchanged-when-same
(with-mocks [audit-mock {:target 'app.loggers.audit/insert :return nil}]
(with-redefs [sys/system th/*system*]
(let [profile (th/create-profile* 1 {:is-active true})
result (srepl/update-profile-email!
:email (:email profile)
:new-email (:email profile))]
(t/is (= :unchanged result))
(t/is (empty? (:call-args-list @audit-mock)))))))
(t/deftest update-profile-email-not-found
(with-mocks [audit-mock {:target 'app.loggers.audit/insert :return nil}]
(with-redefs [sys/system th/*system*]
(let [error (try
(srepl/update-profile-email!
:email "missing@example.com"
:new-email "corrected@example.com")
(catch Throwable e e))]
(t/is (th/ex-of-code? error :profile-not-found))
(t/is (= :not-found (:type (ex-data error))))
(t/is (empty? (:call-args-list @audit-mock)))))))
(t/deftest clear-email-complaint-reports-deletes-and-unmutes
(with-mocks [audit-mock {:target 'app.loggers.audit/insert :return nil}]
(with-redefs [sys/system th/*system*]
(let [profile (th/create-profile* 1 {:is-active true :is-muted true
:email "bounced@example.com"})
_ (th/create-complaint-for th/*system*
{:id (:id profile) :type :bounce})
_ (th/create-complaint-for th/*system*
{:id (:id profile) :type :complaint})
_ (th/create-global-complaint-for th/*system*
{:email (:email profile)
:type :bounce})
_ (th/create-global-complaint-for th/*system*
{:email (:email profile)
:type :complaint})
result (srepl/clear-email-complaint-reports! (:email profile))]
(t/is (= :cleared result))
(t/is (empty? (th/db-query :global-complaint-report
{:email (:email profile)})))
(t/is (empty? (th/db-query :profile-complaint-report
{:profile-id (:id profile)})))
(t/is (false? (:is-muted (th/db-get :profile {:id (:id profile)}))))
(let [event (->> (:call-args-list @audit-mock)
(map second)
first)]
(t/is (= "clear-email-complaint-reports" (:name event)))
(t/is (= "action" (:type event)))
(t/is (= (:id profile) (get-in event [:props :id])))
(t/is (= (:email profile) (get-in event [:props :email]))))))))
(t/deftest clear-email-complaint-reports-without-profile
(with-mocks [audit-mock {:target 'app.loggers.audit/insert :return nil}]
(with-redefs [sys/system th/*system*]
(let [email "orphan-bounce@example.com"
_ (th/create-global-complaint-for th/*system*
{:email email :type :bounce})
result (srepl/clear-email-complaint-reports! email)]
(t/is (= :cleared result))
(t/is (empty? (th/db-query :global-complaint-report {:email email})))
(let [event (->> (:call-args-list @audit-mock)
(map second)
first)]
(t/is (= "clear-email-complaint-reports" (:name event)))
(t/is (= email (get-in event [:props :email])))
(t/is (nil? (get-in event [:props :id]))))))))

12
backend/test/backend_tests/tasks/binfile_jobs_integration_test.clj
View File

@ -249,11 +249,13 @@
(with-redefs [jobs/heartbeat (fn [_cfg & {:as options}]
(swap! calls conj options)
1)]
(bfj/export-files th/*system*
(jobs/make-context (jobs/get-job th/*system* job-id))
{:ids #{file-id}
:export-type :detach-libraries
:output (tmp/tempfile* :suffix ".penpot")}))
(let [cfg (bfc/export-cfg th/*system*
{:file-ids #{file-id}
:export-type :detach-libraries
:output (tmp/tempfile* :suffix ".penpot")})
context (jobs/make-context (jobs/get-job th/*system* job-id))]
(bfj/check-active cfg context)
(bfj/run cfg context v3/export-files!)))
(let [reports (map :progress @calls)]

15
backend/test/backend_tests/tasks/import_binfile_test.clj
View File

@ -9,7 +9,6 @@
it leaves behind when it fails."
(:require
[app.binfile.common :as bfc]
[app.binfile.jobs :as bfj]
[app.binfile.v1 :as v1]
[app.binfile.v3 :as v3]
[app.common.uuid :as uuid]
@ -50,7 +49,7 @@
[file-id]
(let [output (tmp/tempfile* :suffix ".penpot")]
(v1/export-files! (-> th/*system*
(assoc ::bfc/ids #{file-id})
(assoc ::bfc/file-ids #{file-id})
(assoc ::bfc/include-libraries false)
(assoc ::bfc/embed-assets false))
output)
@ -249,12 +248,12 @@
;; the core does its work inside the transaction and answers with a result
;; the schema of the task does not accept: the check runs before the
;; transaction commits, so the work is rolled back with it
(with-redefs [bfj/import-files
(fn [tx-cfg _context _params]
(th/create-file* tx-cfg 7 {:profile-id (:id profile)
:project-id project-id
:is-shared false
:name "half imported"})
(with-redefs [v3/import-files!
(fn [cfg]
(th/create-file* cfg 7 {:profile-id (:id profile)
:project-id project-id
:is-shared false
:name "half imported"})
{:file-ids [(uuid/next)]
:resolution "not-a-map"})]

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

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

2
common/package.json
View File

@ -4,7 +4,7 @@
"license": "MPL-2.0",
"author": "Kaleidos INC Sucursal en España SL",
"private": true,
"packageManager": "pnpm@12.15.0+sha512.b3951d6d6ff4a9f13dc7cf56cd28d2b8eb37dbcc9c68e52e1e1191873ea9f82a017287ab50baadc5ccc494f036c67c0e47eb13608c2fa36f47711b61ea128e61",
"packageManager": "pnpm@12.16.1+sha512.091d1dee7927575661b25dab3c2ae31cafc1c54d6b71ed6a6600cf0c1cb10434a447eae14015f1b23e2e6bedeed79df94a932e2164d2832280dce3fb32f656d1",
"type": "module",
"repository": {
"type": "git",

122
common/pnpm-lock.yaml generated
View File

@ -7,153 +7,153 @@ importers:
configDependencies: {}
packageManagerDependencies:
pnpm:
specifier: 12.15.0
version: 12.15.0
specifier: 12.16.1
version: 12.16.1
packages:
'@pnpm/exe.android-arm64@12.15.0':
resolution: {integrity: sha512-eVCqmscY70LGvgRzu3mi8IBWBFGix+a6mNZoWmXxESsBdeiKEF9xQSuaeel10yn+zI7TXy2jlI63vFLzETk+aQ==}
'@pnpm/exe.android-arm64@12.16.1':
resolution: {integrity: sha512-PKf78Ew+i0CBYf0Xc+eMcqQiqyBT+u8XCVg1F5roc98/6wWfdYlWhrUMmEBiKWaJ3JqHxrtt8l1NwZ7qfJt2/Q==}
cpu: [arm64]
os: [android]
'@pnpm/exe.android-x64@12.15.0':
resolution: {integrity: sha512-Gx/WbkFcdUFUg8g8AShezcS9EiQxfYvdAm2hfKLO8sfJmJvKOCt5fzlgHWDzmGhoclibgW+tUGZ/KF4F4wOTCA==}
'@pnpm/exe.android-x64@12.16.1':
resolution: {integrity: sha512-xdu7gMbB98pdvhwMeA6612Of515FDlRUtfA/1f7nWPZfPLnEdSRBO2u+1N0XBtQ/ennhPH/lrxB1gC6gnR/cdg==}
cpu: [x64]
os: [android]
'@pnpm/exe.darwin-arm64@12.15.0':
resolution: {integrity: sha512-N0ZykiDWCvqSBJvt71j7cSoBR993FqvYZFtmpCtqvW3pguiI+NAgraLPA5OTwu5mV+/d8hYpVcPktJA3xFDLtA==}
'@pnpm/exe.darwin-arm64@12.16.1':
resolution: {integrity: sha512-pVbmIIbhixiLvADLu1WA3TaW8FZy/D72R1De27WbbFx8/2mxvnsTyFVm4fO9kjpjMY7RzJd48CiQ96p8fO3ebQ==}
cpu: [arm64]
os: [darwin]
'@pnpm/exe.darwin-x64@12.15.0':
resolution: {integrity: sha512-7Ntr2HlBUxzwWOg7NwDxCbRW/3vXuqKO+hcXm+w3SBi9rrHY53li1wLqWVT7Gjxd+lVEHM1QJZo6WJEGFU8C6A==}
'@pnpm/exe.darwin-x64@12.16.1':
resolution: {integrity: sha512-xZvQBFqcZjO7vFKTK3XsJpqY6lnBL9EWSLCzVUPq3kZ94+D96gwJCa76xxGNK8Cj32f4eeM91Qg+yNRR4sRpDw==}
cpu: [x64]
os: [darwin]
'@pnpm/exe.freebsd-x64@12.15.0':
resolution: {integrity: sha512-btOiyL7fL7W4uQGH0aqFai2TNC3IoKcZ7gNHBVbEFZt2dWrnrD0SufL3iGs3fLlmb4OtuU35uf4Zpr9V9Jh9mA==}
'@pnpm/exe.freebsd-x64@12.16.1':
resolution: {integrity: sha512-zTtunfi9mBhRXiXEJYfwiJj0tk7MgTSfqDSRh+Az9FZ9THazVIiQiVNS8jpcsftDOqu7LKNffQdjmgwHDThfUg==}
cpu: [x64]
os: [freebsd]
'@pnpm/exe.linux-arm64-musl@12.15.0':
resolution: {integrity: sha512-pNC38k+O+90FOjbPNSnw0E7apq1PKTmz3fFe1amn+lys/U5kL++uzir8bRiho8ONcyA3d9EU7wdqcY0DKkj+JA==}
'@pnpm/exe.linux-arm64-musl@12.16.1':
resolution: {integrity: sha512-BJ3mOmcmQgcUo92Ee/WfEOt1pRiv3y2MMAkhEiYHd85UiPpHTfFhv+SpCbALmfExzXk3UlaRtMYwHlkQymc4VA==}
cpu: [arm64]
os: [linux]
libc: [musl]
'@pnpm/exe.linux-arm64@12.15.0':
resolution: {integrity: sha512-qML/8aCXslh8td/w4U+HJNqUcZ2+m6EfTbWScIzZRmyPsRFN+xB4LP1U/hymxc1iSJiKtG56HJx2fvUErWFIGw==}
'@pnpm/exe.linux-arm64@12.16.1':
resolution: {integrity: sha512-JaRd5gNxwdNGBBkrZFt8bknrK4YmHVJBW0JMhUQ0fJ0dEYp6C2GT9ExaCqOO8EwYEyqM+jpKgJIK+8WFaJy3ew==}
cpu: [arm64]
os: [linux]
libc: [glibc]
'@pnpm/exe.linux-ppc64@12.15.0':
resolution: {integrity: sha512-tjRDUUl7RCJ6T/6eoNPxOqkwU4Mzi5RtTXmSAxujyz37OTwwsMU7Ps087Zk4gHcUvRSeyF40ZFsew3vtE+nmUA==}
'@pnpm/exe.linux-ppc64@12.16.1':
resolution: {integrity: sha512-FnSV0Jv40S1cMv7vFNWwvu0X567Lec4L4HCRead3CFcD6zQDNbGw81s8N5bcKPahtPD9ApVuhsbmFCx4rw6RMw==}
cpu: [ppc64]
os: [linux]
libc: [glibc]
'@pnpm/exe.linux-riscv64@12.15.0':
resolution: {integrity: sha512-bF1uBWEfbwaeryz6lIiaJ8AWD082otZfvzGX5l+6LZRpRwUEpJHUsJrORaYP5/cNMv5ZR2p6TvvcJcQzwtDzmw==}
'@pnpm/exe.linux-riscv64@12.16.1':
resolution: {integrity: sha512-C1Sww4FN5IttD4atRRhAKmQtSGWVp04ZAKNxO8pfu2bkRPwOW+7v+2DH1Xs1W+kZYYpO86BYDvUcadefF+AgaQ==}
cpu: [riscv64]
os: [linux]
libc: [glibc]
'@pnpm/exe.linux-s390x@12.15.0':
resolution: {integrity: sha512-zKMhIzsexYMToeLmqV5jPsvV/f9vwsJb2kUH2NFYzalbxImeBrlA4kL7GwF8gD4pagV6jYYcJb8RjbZIdjHptg==}
'@pnpm/exe.linux-s390x@12.16.1':
resolution: {integrity: sha512-kn2fautsTcxIMODoovQVqZyfpDRdNgGkoeVqNdrKqbeBBvrEl+fXLkmZiq5xDht1LMr4sYiCNcsMfNMT6JPFmg==}
cpu: [s390x]
os: [linux]
libc: [glibc]
'@pnpm/exe.linux-x64-musl@12.15.0':
resolution: {integrity: sha512-A9J0Jg0Rdx+qQU4qXtwyST5tto9IOu1zi4fDk35nbc6DWahggbcKtFvZPKFwL2qgUXGXOX//hXv6z/sp6emO8A==}
'@pnpm/exe.linux-x64-musl@12.16.1':
resolution: {integrity: sha512-PM6ccHCOe/O9SsTflTJTYWfwogJZa6EmUvpnwZgiPguJBddh20wDQKgxUPXf48rDsPm9vMsIij0uHswwwbXL8g==}
cpu: [x64]
os: [linux]
libc: [musl]
'@pnpm/exe.linux-x64@12.15.0':
resolution: {integrity: sha512-yc+QlZR+9+nr29J4fRzhMoapgxTBDndq/+peyoq1XUufnQFnfbXUMFudDIKzHi545linGqmOmXfn0NoufNgcOg==}
'@pnpm/exe.linux-x64@12.16.1':
resolution: {integrity: sha512-RK//8ZLcXGW8A2k8bQOXZDBN1Qu92zN4dYnG1bzj1zoQ1fkZ6jNzZ1AvXtsfGVma795CJtvoaF5bLXf4l/FIUw==}
cpu: [x64]
os: [linux]
libc: [glibc]
'@pnpm/exe.win32-arm64@12.15.0':
resolution: {integrity: sha512-fPXZxuY1VclkOga9bc53qNCXcegfeoBR8+Ue+AospDwKzuGGSHll0oDxkLfkmpjyRqpe7bH5DyQPYp/xSMaIVA==}
'@pnpm/exe.win32-arm64@12.16.1':
resolution: {integrity: sha512-Ox3kNNVxtGw6pK7SVejmeOUgHhUTZgAM7NQQ6cU7frPw3ix9+j7d2MGbRg3fyEFAaKWq8ZAZLTQGcDyLnAu+qA==}
cpu: [arm64]
os: [win32]
'@pnpm/exe.win32-x64@12.15.0':
resolution: {integrity: sha512-nrd+Tp1We1DGj4DGG5Bea9lZNh9y1PjlLBdEwdInS4D0h0UIDtM7JaGGGDJhNzIwcHASyihWI7HLV+dtG+fhYg==}
'@pnpm/exe.win32-x64@12.16.1':
resolution: {integrity: sha512-k+FhRJ0ttphFoFIVB1Sk4v76YJAulafmA/Ly57cysesUhhIzVlApeOShUz0jXubKx317TThlEfpQrukldnqORA==}
cpu: [x64]
os: [win32]
pnpm@12.15.0:
resolution: {integrity: sha512-s5UdbW/0qfE9x89WzSjSuOs328ycaOUuHhGRhz6p+CoBcoerULqtxczElPA2xnwOR+sTYIwvo29HcRth6hKOYQ==}
pnpm@12.16.1:
resolution: {integrity: sha512-CR0d7nknV1Zhsl2rPCrjHK/BxU1rce1qZgDPDByxBDSkR+rhQBXxsj4ua+3u1535SpMuIWTSgyKA3OP7MvZW0Q==}
engines: {node: '>=18'}
hasBin: true
snapshots:
'@pnpm/exe.android-arm64@12.15.0':
'@pnpm/exe.android-arm64@12.16.1':
optional: true
'@pnpm/exe.android-x64@12.15.0':
'@pnpm/exe.android-x64@12.16.1':
optional: true
'@pnpm/exe.darwin-arm64@12.15.0':
'@pnpm/exe.darwin-arm64@12.16.1':
optional: true
'@pnpm/exe.darwin-x64@12.15.0':
'@pnpm/exe.darwin-x64@12.16.1':
optional: true
'@pnpm/exe.freebsd-x64@12.15.0':
'@pnpm/exe.freebsd-x64@12.16.1':
optional: true
'@pnpm/exe.linux-arm64-musl@12.15.0':
'@pnpm/exe.linux-arm64-musl@12.16.1':
optional: true
'@pnpm/exe.linux-arm64@12.15.0':
'@pnpm/exe.linux-arm64@12.16.1':
optional: true
'@pnpm/exe.linux-ppc64@12.15.0':
'@pnpm/exe.linux-ppc64@12.16.1':
optional: true
'@pnpm/exe.linux-riscv64@12.15.0':
'@pnpm/exe.linux-riscv64@12.16.1':
optional: true
'@pnpm/exe.linux-s390x@12.15.0':
'@pnpm/exe.linux-s390x@12.16.1':
optional: true
'@pnpm/exe.linux-x64-musl@12.15.0':
'@pnpm/exe.linux-x64-musl@12.16.1':
optional: true
'@pnpm/exe.linux-x64@12.15.0':
'@pnpm/exe.linux-x64@12.16.1':
optional: true
'@pnpm/exe.win32-arm64@12.15.0':
'@pnpm/exe.win32-arm64@12.16.1':
optional: true
'@pnpm/exe.win32-x64@12.15.0':
'@pnpm/exe.win32-x64@12.16.1':
optional: true
pnpm@12.15.0:
pnpm@12.16.1:
optionalDependencies:
'@pnpm/exe.android-arm64': 12.15.0
'@pnpm/exe.android-x64': 12.15.0
'@pnpm/exe.darwin-arm64': 12.15.0
'@pnpm/exe.darwin-x64': 12.15.0
'@pnpm/exe.freebsd-x64': 12.15.0
'@pnpm/exe.linux-arm64': 12.15.0
'@pnpm/exe.linux-arm64-musl': 12.15.0
'@pnpm/exe.linux-ppc64': 12.15.0
'@pnpm/exe.linux-riscv64': 12.15.0
'@pnpm/exe.linux-s390x': 12.15.0
'@pnpm/exe.linux-x64': 12.15.0
'@pnpm/exe.linux-x64-musl': 12.15.0
'@pnpm/exe.win32-arm64': 12.15.0
'@pnpm/exe.win32-x64': 12.15.0
'@pnpm/exe.android-arm64': 12.16.1
'@pnpm/exe.android-x64': 12.16.1
'@pnpm/exe.darwin-arm64': 12.16.1
'@pnpm/exe.darwin-x64': 12.16.1
'@pnpm/exe.freebsd-x64': 12.16.1
'@pnpm/exe.linux-arm64': 12.16.1
'@pnpm/exe.linux-arm64-musl': 12.16.1
'@pnpm/exe.linux-ppc64': 12.16.1
'@pnpm/exe.linux-riscv64': 12.16.1
'@pnpm/exe.linux-s390x': 12.16.1
'@pnpm/exe.linux-x64': 12.16.1
'@pnpm/exe.linux-x64-musl': 12.16.1
'@pnpm/exe.win32-arm64': 12.16.1
'@pnpm/exe.win32-x64': 12.16.1
---
lockfileVersion: '9.0'

Some files were not shown because too many files have changed in this diff Show More