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

✨ Add unified jobs substrate replacing legacy one-shot task system (#11542)

Browse Source 
* 🎉 Move backend jobs to the unified job table substrate

Replace the generic 'task' table with a unified 'job' table as the
durable substrate for all backend jobs, and migrate every producer
and consumer to it. The legacy 'task' table stops receiving writes
but stays dormant (still cleaned by tasks-gc); upload-session
chunking and the other post-branch upstream changes are preserved.

New 0154 migration creates the 'job' table: dispatch and lifecycle
columns (name, queue, priority, scheduled_at, retries, status,
timestamps, props) plus optional user-facing ledger columns
(profile_id, target, progress, error, result, resource_id,
expires_at). No modified_at trigger: the application updates it on
every write for lease and orphan detection. Partial indexes cover
the dispatcher claim query, orphan scanning, and per-profile
listing.

New app.jobs public API: submit!/invoke!, heartbeats and progress
reporting, a precompiled job-def registry (name, schema, handler,
decoder, validator), an ephemeral request/response mode, and a
management API for external workers. The dispatcher claims
new/retry rows (FOR UPDATE SKIP LOCKED) with a plain JSON redis
payload and marks lease-expired running rows as orphaned; the
runner executes per-queue with the same retry conventions.

New jobs GC (daily): deletes expired rows and retains internal
terminal rows per :jobs-retention, touching referenced storage
objects so storage-gc-touched reclaims them. Job resources live in
a dedicated job-resource bucket with a reclaim branch in
storage-gc-touched.

All production call-sites (sendmail, delete-object, demo-purge,
file-gc, offload, webhooks, quotes, nitrate bulk delete,
snapshots, telemetry) and the ten cron tasks now submit through
app.jobs; cron is a pure scheduler and the legacy worker registry,
task-table inserts, and per-namespace handlers are removed.

Includes migrations, dispatcher, runner, jobs, request/response,
jobs GC, management API, and cron test suites.

AI-assisted-by: glm-5.3-flash
AI-assisted-by: muse-spark-1.3-contributor
AI-assisted-by: kimi-k3
AI-assisted-by: mimo-v2.5

* ✨ Address review comments on jobs substrate

Resolves the four open review threads on the jobs PR. Orphaned jobs
are now marked aborted, a system-side terminal state with no retry:
the dispatcher sweep stores the end event with outcome aborted in a
single bulk insert in the same transaction, records the terminal
outcome next to the orphaned counter, and reports an error log;
orphans keep alerting through the log and the counter, with no
user notification.

The aborted state is terminal everywhere: the status CHECK, the
sweep, the lifecycle writers, the jobs GC retention, the backlog
gauges and the user status mapping, with tests covering each
transition. The claim comment, the 2.20 doc version and the legacy
task table notes are corrected, and objects-gc heartbeats per chunk.

AI-assisted-by: muse-spark-1.3-contributor
This commit is contained in:
Andrey Antukh 2026-10-06 07:33:12 +02:00 committed by GitHub
parent 0eb1e8ba95
commit d3ca9a0b83
No known key found for this signature in database
GPG Key ID: B5690EEEBB952194
97 changed files with 8796 additions and 1533 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
.agents/skills/review-plan/SKILL.md
View File

@ -6,64 +6,40 @@ slash: true
# Review Plan
Act as a senior software engineer and perform a thorough review of an
implementation plan.
Act as a senior software engineer and perform a thorough review of an implementation plan.
## When to use
- The user asks to review a plan, in any phrasing: "review this plan",
"does this plan look right?", "second opinion on the plan" — or runs
`/review-plan`.
- A plan was just produced (typically by `/make-a-plan`) and the user
wants it evaluated before executing it.
- The user asks to review a plan, in any phrasing: "review this plan", "does this plan look right?", "second opinion on the plan" — or runs `/review-plan`.
- A plan was just produced (typically by `/make-a-plan`) and the user wants it evaluated before executing it.
## Instructions
1. **Determine the plan under review** from the session context (for example, a
plan just produced by `/make-a-plan`) or from a plan file path given by the
user (typically under `.agents/plans/`). If a file path is given, read the
file first so the complete plan is in context.
2. Delegate the review to the `general` subagent (via the task tool), unless the
user specifies another agent. Include in the prompt the
**`plan-review-criteria`** skill name and all user context.
3. When the subagent returns, output the review to the user verbatim. Do not
summarize it and do not act on its findings.
4. Right after the review, suggest the next step based on the verdict. These
are suggestions — the user decides, and any instruction overrides them:
1. **Determine the plan under review** from the session context (for example, a plan just produced by `/make-a-plan`) or from a plan file path given by the user (typically under `.agents/plans/`). If a file path is given, read the file first so the complete plan is in context.
2. Delegate the review to the `general` subagent (via the task tool), unless the user specifies another agent. Include in the prompt the **`plan-review-criteria`** skill name and all user context.
3. When the subagent returns, output the review to the user verbatim. Do not summarize it and do not act on its findings.
4. Right after the review, suggest the next step based on the verdict. These are suggestions — the user decides, and any instruction overrides them:
- **Approve** → suggest `/implement-plan` to execute it.
- **Request changes** → suggest `/make-a-plan` to make a plan to address the
findings.
- **Request changes** → suggest `/make-a-plan` to make a plan to address the findings.
### Hard rule — read-only while reviewing
This flow is read-only **for the duration of the review**: from the moment it
starts until the user considers the review finished (including any feedback,
questions, or clarifications about it). During that period, never fix,
implement, edit files or create commits — not even "obvious" fixes derived from
the findings. Once the user explicitly states the review is done (or moves on to
a different task), this rule no longer applies and you act as a normal build
agent again.
This flow is read-only **for the duration of the review**: from the moment it starts until the user considers the review finished (including any feedback, questions, or clarifications about it). During that period, never fix, implement, edit files or create commits — not even "obvious" fixes derived from the findings. Once the user explicitly states the review is done (or moves on to a different task), this rule no longer applies and you act as a normal build agent again.
## Instructions for the subagent
1. Load the **`plan-review-criteria`** skill and follow its process and output
format.
2. Read `AGENTS.md` (if present) and follow its instructions for finding and
reading all related documentation and testing memories before reviewing.
3. Return in your final message the COMPLETE review, verbatim, exactly as the
skill instructs it to be produced. Do not summarize it — include the full
structured review.
1. Load the **`plan-review-criteria`** skill and follow its process and output format.
2. Read `AGENTS.md` (if present) and follow its instructions for finding and reading all related documentation and testing memories before reviewing.
3. Cada hallazgo debe tener un identificador único y estable, con el formato `F1`, `F2`, etc. El identificador debe aparecer en el título del hallazgo y no debe reutilizarse dentro de la misma revisión. Esto permite que el usuario pueda responder sobre un hallazgo concreto.
4. Return in your final message the COMPLETE review, verbatim, exactly as the skill instructs it to be produced. Do not summarize it — include the full structured review.
### Strong rules for the subagent
1. Do not invent problems. Every finding must be real and actionable.
2. Read-only: do not modify any file and do not create a commit — reviewing
never writes.
3. Be specific and constructive. "This could be better" is not helpful — explain
why and how.
2. Read-only: do not modify any file and do not create a commit — reviewing never writes.
3. Be specific and constructive. "This could be better" is not helpful — explain why and how.
4. Prioritize by impact. One structural issue outweighs ten nits.
5. Judge the plan as the implementer would: every task executable without
guessing, ordering follows the dependency graph, risks named.
5. Judge the plan as the implementer would: every task executable without guessing, ordering follows the dependency graph, risks named.
## User input, overrides and additional context

4
.github/workflows/tests-backend.yml vendored
View File

@ -80,6 +80,10 @@ jobs:
- name: Tests
working-directory: ./backend
env:
# `clojure.core/assert` is elided at compile time, so without this
# flag the precondition asserts do not exist in the compiled code
# and the suite silently stops checking them.
PENPOT_FLAGS: "enable-backend-asserts"
PENPOT_TEST_DATABASE_URI: "postgresql://postgres/penpot_test"
PENPOT_TEST_DATABASE_USERNAME: penpot_test
PENPOT_TEST_DATABASE_PASSWORD: penpot_test

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

@ -37,21 +37,46 @@ Backend RPC command areas without focused memories include access tokens, binfil
`app.db` helpers accept cfg, pool, or conn in most places and convert kebab-case to snake_case:
- `db/get`, `db/get*`, `db/query`, `db/insert!`, `db/update!`, `db/delete!`.
- `db/get*`/`db/query` signature is `(ds table where-params & {:as opts})`: trailing keywords become an opts MAP (ignored by the select builder — use `{::db/remove-deleted false}` map as the single vararg to also see rows with `deleted_at` set), while a trailing ODD number of keywords crashes with "Don't know how to create ISeq from: Keyword". Extra keywords are NOT a column filter: rows always come back with all columns.
- Next.js/JDBC caveat: where-maps don't support value vectors (no `IN`); use `status = ANY(?)` with `db/create-array` inside `db/tx-run!`.
- Use `db/run!` for multiple operations on one connection.
- Use `db/tx-run!` for transactions.
- `job`-substrate specifics (unified jobs): the only writers of a job status are `claim`, `retry-job`, `complete`, `fail` and `cancel` in `app.jobs`; each one is a conditional update plus its `job_event` row in the same transaction, so history can never contradict the row. A writer that affects no row writes no event and no metric. They never join the caller's transaction, because a lifecycle write reports on work that already happened: a rolled back caller cannot undo a transition, and an independent connection cannot see the caller's uncommitted job row, so a job must be committed before it can be claimed. GC deletes return resource ids via `RETURNING` inside one transaction.
- Every public function of `app.jobs` takes a cfg map. A bare pool or connection is a caller bug and is not coerced: the substrate has no conversion of its own, and the ones in `app.db` are the db layer's business.
- Every new foreign key of the substrate is `DEFERRABLE`, `job_event.job_id` included.
- Some tables carry a SQL deletion guard (`raise_deletion_protection` + a `deletion_protection__tgr` statement trigger): `profile`, `team`, `team_font_variant`, `file_media_object`, `file_thumbnail`, `file_tagged_object_thumbnail` and `job`. A `DELETE` raises unless the transaction runs `SET LOCAL rules.deletion_protection TO off` (the guard is on when the GUC is unset, empty or `on`); see `app.tasks.objects-gc`, `app.jobs.gc` and `th/db-force-delete`.
Database migrations live in `backend/src/app/migrations/`; pure SQL migrations are under `backend/src/app/migrations/sql/`. SQL filenames conventionally start with a sequence and verb/table description, e.g. `0026-mod-profile-table-add-is-active-field`. Applied migrations are tracked in the `migrations` table.
For interactive PostgreSQL access with correct dev defaults, use `scripts/psql`; to dump
the current DDL schema, use `scripts/db-schema` (see `mem:scripts/psql`).
For interactive PostgreSQL access with correct dev defaults, use `scripts/psql`; to dump the current DDL schema, use `scripts/db-schema` (see `mem:scripts/psql`).
For deeper details on transaction semantics, advisory locks, Transit vs JSON helpers, and dev/test DB URLs: `mem:backend/subtleties`.
## Background tasks
## Background tasks (unified jobs)
A task handler is an Integrant component with `ig/assert-key`, `ig/expand-key`, and `ig/init-key`, returning the function run by the worker. New tasks also need wiring in `app.main`: handler config, worker registry entry, and cron entry if scheduled.
Every background job is a job-def: a plain `(defn execute-X [cfg params] ...)` in its namespace + a malli params schema + an `ig/init-key` that returns the job-def map `{::jobs/name, ::jobs/schema, ::jobs/handler, ::jobs/decoder, ::jobs/validator}` (decoder/validator precompiled at init). The registry is the `::jobs/defs` wiring in `app.main`, which also populates a module-level registry used by `jobs/submit` as fallback — job-def components cannot ig/ref `::jobs/defs` (wiring cycle). Submit from RPC code passes its RPC cfg (it carries `::jobs/defs` via ig/ref).
- `::jobs/handler` is `(fn [context params] ...)`. It is NOT given the runner cfg: a job-def closes over its own dependencies, and handing it the runner cfg would let a handler reach the pool or any other component. A wrapper passes the context to its implementation only when the implementation takes it; most do not, and their implementation stays `[cfg params]`.
- The context is built by `jobs/make-context` and has exactly four keys: `id`, `name`, `label`, `resource-id`, behind a closed schema. `queue` is absent on purpose (a routing detail of the dispatcher, not a property of the job) and so are `retry-num`/`max-retries`/`attempt` (retry policy belongs to the runner, and an attempt number cannot be durable because the `noop` strategy re-runs without incrementing the counter).
- `jobs/invoke` is the in-process escape hatch: it delivers a nil context without a row, validates and delivers `::jobs/context` when given, and keeps `::jobs/job-id` independent. `::jobs/context` and `::jobs/job-id` are cfg options, not params.
- Business params live in the `params` column (plain JSON, decoded with the job-def decoder). `submit` takes an optional `::jobs/profile-id` and `::jobs/resource-id`, both validated as UUIDs and stored as columns; nothing is inferred from `params`. No caller passes a profile-id yet.
- `heartbeat` uses named options `[cfg & {:keys [job-id progress] :as options}]` and returns the number of durable writes. The job id falls back to `::jobs/job-id` on the cfg and then to the runner-bound `*job-id*`. A progress report needs `current`, allows optional `total` and `stage` (max 250 chars) and takes no other key.
- `job.error` conforms to `app.jobs/schema:job-error` (`type` and `code` keywords, `hint` text, extra details allowed). Read it back with `jobs/decode-job-error`; a plain `db/decode-json-pgobject` leaves the keywords as strings. `complete` takes named options and an optional `resource-id`, which is only ever set, never replaced: it reads the row locked inside its own transaction and applies the rules in a fixed order, skipping a job that is no longer completable before refusing one for its resource, so the answer is a function of the row and not of the order two callers arrive in.
For worker dispatch, cron, retry semantics (`ex/raise :type ::wrk/retry` with `:delay`/`:strategy`), deduplication, job events, and queue internals: `mem:backend/subtleties`.
## Jobs metrics
- `app.jobs.metrics` owns the jobs metric names, bounded labels and the periodic backlog sampler.
- Metrics use only `name`, `queue`, `outcome`, `reason`, `stage` and `kind` labels. Job IDs, profile IDs, params, reply bodies and exception text must never be labels. Every label goes as-is (lowercased where case varies): values come from fixed call sites, so a new value in Prometheus means new code, not noise. Only a missing value falls back (`other`, or `failed` for outcomes).
- The canonical job name is a keyword (`app.jobs/schema:job-name`): `submit` and `invoke` reject strings. The row stores text, so `jobs/get-job-def` still coerces (it is the runner's boundary), cron entries carry the job under `:job` with `d/name` only at the SQL/log boundary, and test helpers keyword-ize row names before invoking.
- The durable lifecycle metrics are submitted, dispatched, completed, retries, orphaned and rescheduled counters; queue-wait, execution and total-time histograms; dispatcher and backlog state; GC, cron and ephemeral request metrics.
- `app.metrics/run!` is safe for recording failures, but metrics components still require a valid metrics instance. Durable submit call sites carry `::mtx/metrics` through RPC or job-def configuration. The jobs substrate takes the **cfg**, not the instance, and resolves it with `app.metrics/instance`, which raises `:missing-metrics` when absent: `app.jobs`, `app.jobs.metrics`, the runner, the dispatcher, cron and the jobs GC all follow that. `app.http`, `app.rpc.climit` and `app.storage.s3.metrics` still take the instance and were left out of scope on purpose, so do not read the codebase as uniform. The six job writers resolve at the top of their body, before writing, because their metric lands in a `db/after-commit` callback that swallows exceptions. The GC, the dispatcher and cron resolve inside that callback instead, so their guarantee rests on the component schema instead. A job that calls `heartbeat` from a component cfg must carry `::mtx/metrics` on it, and the event helper records the counter from the cfg the transaction hands it.
- SQL-backed job metrics are registered with `app.db/after-commit` from INSIDE the transaction that changed the row, so a rollback cannot inflate submitted, terminal, retry, event or dispatcher counters. Every lifecycle writer owns that transaction (`app.jobs/own-transaction` drops `::db/conn`), and `db/transact!` gives a transaction that joins no other its own callback context, so the write and its metric commit or vanish together. `submit` is the exception and joins the caller on purpose: creating a job is part of the caller's business work.
- `penpot_jobs_events_total` counts stored job events with no labels: the interesting split is `kind`, and grouping a growing append-only table to build a metric is not worth the query on the write path.
- The backlog sampler is `::jobs-metrics/sampler`; it runs every 30 seconds on worker-enabled, writable systems, groups by status and publishes the oldest pending age, and does not start on a read-only database.
- `penpot_tasks_timing` remains exported for compatibility while the jobs-specific histograms are adopted.
For worker dispatch, cron, retry semantics, deduplication, and queue internals: `mem:backend/subtleties`.
## REPL
@ -98,9 +123,7 @@ IMPORTANT: all CLI commands must be executed from the `backend/` subdirectory.
* **Linting:** `pnpm run lint:clj`.
* **Formatting:** `pnpm run check-fmt:clj` to check, `pnpm run fmt:clj` to fix. After running `fmt:clj`, `check-fmt:clj` is redundant. Avoid unrelated whitespace diffs.
**Before linting:** if delimiter errors are suspected (after LLM edits), run
`scripts/paren-repair` on the affected files first. Delimiter errors produce
misleading linter/compiler output. See `mem:scripts/paren-repair`.
**Before linting:** if delimiter errors are suspected (after LLM edits), run `scripts/paren-repair` on the affected files first. Delimiter errors produce misleading linter/compiler output. See `mem:scripts/paren-repair`.
## Testing

12
.serena/memories/backend/storage.md
View File

@ -30,6 +30,13 @@
- `objects-gc` removes deleted domain rows and touches their storage object IDs.
- Use `::db/reuse-conn true` with `sto/resolve` inside a database transaction.
## GC Cost Model
- `sto/touch-object!` is one `UPDATE storage_object SET touched_at`: DB-only, never touches S3/FS backend content.
- Physical FK cascades are avoided by convention; domain deletion is logical (`deleted_at`) everywhere. GC removes small objects first, then parents, then grandparents (see `deletion-proc-vars` order in `app.tasks.objects-gc`). Per-row delete cost is small and bounded.
- `objects-gc` sweeps in chunks of 100 (`::chunk-size`, overridable per job params); `storage-gc-deleted` in chunks of 25. Each chunk is one transaction: cursor fetch + single-row deletes/updates + commit.
- Consequence: per-chunk cost is DB-only and bounded, so these sweeps cannot outrun the 30-minute jobs lease in practice (would need millions of pending rows in one proc). Per-chunk `heartbeat` where present is belt-and-braces, not load-bearing.
## Connection Reuse Details
### `app.storage/resolve` patterns:
@ -87,12 +94,13 @@ Since `put-object!` uses backend-specific operations (`impl/resolve-backend` + `
| `file-data` | Encoded file data when `file-data-backend` is `storage`. Reference metadata has `storage-ref-id`, `file-id`, and the `file_data` row ID. | Yes | Authentication required | Reference scan. |
| `file-data-fragment` | Compatibility value for file-data fragments. The current backend has no dedicated producer for this bucket. | No current write semantics | Public | No touched-object collector case. |
| `file-change` | Compatibility value for file changes. Current snapshots store data in `file_data`, not this bucket. | No current write semantics | Authentication required | No touched-object collector case. |
| `job-resource` | Storage objects owned by job rows (`job.resource_id`). | Yes | Authentication required | jobs-GC touch → reference scan. |
- The valid bucket set lives in `app.storage/valid-buckets`.
- The valid bucket set is `app.storage.schema/metadata-buckets` (derived from `bucket-requirements`, where a new bucket and its required metadata keys are one entry); `app.storage/valid-buckets` aliases it.
- `file-media-object` is the default bucket for old rows without bucket metadata.
- Do not assign a new bucket without adding its access and cleanup behavior.
- The touched-object collector raises an internal error for an unknown bucket.
- It supports `file-media-object`, `team-font-variant`, `file-object-thumbnail`, `file-thumbnail`, `profile`, `file-data`, `tempfile`, `upload-session`, and `organization`.
- It supports `file-media-object`, `team-font-variant`, `file-object-thumbnail`, `file-thumbnail`, `profile`, `file-data`, `tempfile`, `upload-session`, `job-resource`, and `organization`.
- It does not support `file-data-fragment` or `file-change`.
## Access Rules

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

@ -14,17 +14,24 @@
- Most `app.db` helpers accept a pool, connection, or map containing `::db/pool` / `::db/conn`; preserve that convention in shared code.
- `db/tx-run!` uses `next.jdbc.transaction/*nested-tx* :ignore`: nested transaction calls reuse the outer transaction, not a savepoint. Use explicit savepoints when nested rollback semantics matter.
- Whether a call is nested is decided by the CONNECTION, not by an ambient flag: `db/transact!` binds `*after-commit-conn*` around the body, and a transactable that is not identical to that connection is an independent unit of work that owns its own after-commit context. A `tx-run!` that passes a pool while a transaction is open therefore commits on its own and drains its own callbacks, instead of leaving them in a context that may roll back.
- `after-commit` callbacks run on commit only. A transaction marked `::db/rollback` (used by `srepl` and `app.tasks/offload-file-data`) commits nothing, so it runs none of them.
- `db/run!` opens/reuses one connection but does not create a transaction.
- `db/tjson` is Transit JSON for jsonb storage; `db/json` is plain JSON. Worker task props use Transit and are decoded with `decode-transit-pgobject`.
- `db/tjson` is Transit JSON for jsonb storage; `db/json` is plain JSON. Job params (`job.params`) are plain JSON, decoded with the job-def decoder (`app.jobs/decode-params`); only the legacy `task` props were Transit (`decode-transit-pgobject`).
- Advisory transaction locks accept UUIDs or ints. UUID locks are hashed using a zero-UUID seeded siphash.
## Workers and cron
- Task queues are tenant-prefixed. Submit dedupe only removes not-yet-due `new` tasks with the same name/queue/label; it does not dedupe due, scheduled, retry, running, or completed work.
- The dispatcher selects `new`/`retry` tasks with `FOR UPDATE SKIP LOCKED`, marks them `scheduled`, and publishes Redis payload `[id scheduled-at]`. The runner skips Redis messages whose scheduled timestamp no longer matches DB state.
- Lost `scheduled` tasks are rescheduled after about 5 minutes; `running` tasks older than about 24 hours are marked failed as orphans.
- A task handler that is missing or returns an invalid result currently defaults to completed after warning. Throwing with `ex-data :type ::retry` controls retry behavior; `:strategy ::noop` retries without incrementing retry count.
- Cron jobs lock their `scheduled_task` row with `FOR UPDATE SKIP LOCKED`, disable statement/idle-in-transaction timeouts locally, and reschedule themselves in `finally` unless interrupted. Worker, dispatcher, and cron components do not start when the DB pool is read-only.
- `job` carries `tenant` (the instance the job belongs to) and a bare `queue`. Several instances share one database and the tenant is what keeps an instance from claiming another environment's jobs, so every query that acts on one instance's work filters on `tenant`: dispatch claim, orphan sweep, lost-job reschedule, cron no-overlap count, submit dedupe. The `job__dispatcher__idx` leads with `tenant` (equality) then `(priority DESC, scheduled_at)`; `queue` does not lead because the dispatcher claims every queue of its tenant. The `<tenant>:<queue>` prefix survives only in the Redis key, composed once by `app.worker/queue-key`.
- Submit dedupe only removes not-yet-due `new` jobs of the same tenant with the same name/queue/label; it does not dedupe due, scheduled, retry, running, or completed work.
- The dispatcher selects `new`/`retry` jobs with `FOR UPDATE SKIP LOCKED`, marks them `scheduled`, and publishes the JSON payload `[id scheduled-at]` to the `penpot.worker.queue:<tenant>:<queue>` Redis list. The runner skips Redis messages whose scheduled timestamp no longer matches DB state.
- Lost `scheduled` jobs are rescheduled after 5 minutes; `running` jobs untouched longer than `:jobs-lease` (default 30 min) are marked `aborted` with `app.jobs/orphan-error` (`type :internal`, `code :orphan`). `aborted` is a system-side terminal state like `cancelled` (never retried, swept by retention like other terminals, reported with an error log); long jobs must `heartbeat` per chunk so a healthy backlog is never mistaken for a dead process. The `:progress` report is optional and only feeds the durable log.
- An orphan gets its `end` event (`outcome "aborted"`) from the sweep itself: one bulk `INSERT ... SELECT` in the same transaction as the bulk `UPDATE`, never one insert per orphan. No msgbus notification goes out for it; orphans alert through the error log and the orphaned counter.
- `job_event` is append-only and deleted by cascade with the job. `progress` is a row there, not a column: no Redis and no mutable column to keep in sync.
- `job` is deletion-protected at the SQL level (`deletion_protection__tgr`): a stray `DELETE FROM job` raises instead of dropping the row and its `job_event` cascade without touching the referenced `storage_object`. The only intended deleters, the jobs GC and the submit dedupe, disable the guard with `SET LOCAL rules.deletion_protection TO off` inside their transaction; tests use `th/db-force-delete`.
- A missing job-def raises (`:no-job-definition`) instead of completing. Throwing with `ex-data :type ::retry` still controls retry behavior; `:strategy ::noop` retries without incrementing retry count.
- Cron entries claim their `scheduled_task` row with `FOR UPDATE SKIP LOCKED`, disable statement/idle-in-transaction timeouts locally, submit one `job` row per entry when no active instance exists (no-overlap), and reschedule themselves in `finally` unless interrupted. Worker, dispatcher, and cron components do not start when the DB pool is read-only.
- Integrant params schemas name injected components as bare `::ns/key` entries (pool, metrics, msgbus, job defs), and a bare entry is a malli registry lookup, not `any?`: the owning namespace must `sm/register!` it at load, or the backend crashes at boot with `:malli.core/invalid-schema` instead of asserting. Unit tests never build those keys, so `backend-tests.worker-test` compiles the three worker schemas to catch it.
## Config and HTTP/session middleware
@ -47,7 +54,9 @@
## Metrics recording
- `app.metrics/run!` is safe by default: a recording failure never throws (a metrics bug must not change the behavior of the measured operation). The first failure per metric id logs at `warn`, later ones at `debug`. The `instance` precondition is a plain assert (the backend enables `:backend-asserts`), and the collector lookup sits outside the recording guard, so a missing instance fails hard even when asserts are disabled. `::mtx/metrics` is required by the storage, s3-backend, and db-pool schemas; `app.db` wires the prometheus `MetricsTrackerFactory` unconditionally. Storage-specific metric contracts: `mem:backend/storage`.
- `app.metrics/run!` is safe by default: a recording failure never throws (a metrics bug must not change the behavior of the measured operation). The first failure per metric id logs at `warn`, later ones at `debug`. The `instance` precondition is a plain assert (the backend enables `:backend-asserts`), and the collector lookup sits outside the recording guard, so a missing instance fails hard even when asserts are disabled. `::mtx/metrics` is required by the storage, s3-backend, db-pool and jobs APIs; jobs helpers never silently skip a missing metrics instance. The resolver is `app.metrics/instance` and it raises, unlike `run!`.
- `app.msgbus` (`pub!`, `sub!`, `purge!`) keeps taking the **instance** on purpose: msgbus is what produces it, and `app.rpc.notifications` already shows the caller passing a cfg. `app.jobs` resolves `::mbus/msgbus` from the cfg internally, and `insert-event` keeps its explicit pre-insert check so a profile job never loses its notification.
- `app.db/after-commit` is the boundary for SQL-backed metrics: callbacks are drained by the commit of the transaction that owns the connection they were registered on, and discarded when it rolls back. Because nesting follows the connection, that transaction is the outermost one only for a real nested call.
## Storage and media

3
.serena/memories/backend/testing.md
View File

@ -5,8 +5,11 @@ JVM `clojure.test` (kaocha runner) under `backend/test/backend_tests/`.
- READ `mem:testing` FIRST — it defines the execution discipline (no piping, tee to file, preferred commands) that applies to all JVM test runs.
- All CLI commands must be executed from the `backend/` subdirectory.
- Tests are invoked directly via `clojure -M:dev:test` (kaocha) — there is no pnpm wrapper. Kaocha auto-discovers test namespaces, so no runner registration is needed.
- **Preferred way to run them: `scripts/ci <module> --test`**, which runs lint, tests and format per module and writes a log per task under `.ci-logs/`. It exports `PENPOT_FLAGS` with `enable-backend-asserts` appended, so use it rather than calling `clojure -M:dev:test` by hand.
- **Why the flag matters:** `clojure.core/assert` is elided at compile time when `*assert*` is false, and `app.config` only sets that var from the flags when it loads. The test fixture redefines the flags after that, so they never reach it: without the flag the suite runs with every assertion compiled out, and a test that depends on an assert only means something with it set. GitHub Actions sets it too. When running the suite directly, the command is `PENPOT_FLAGS="enable-backend-asserts" clojure -M:dev:test`.
- Coverage: if code is added or modified in `src/`, corresponding tests in `test/backend_tests/` must be added or updated.
- Isolated run: `clojure -M:dev:test --focus backend-tests.my-ns-test` for a specific test namespace, or `clojure -M:dev:test --focus backend-tests.my-ns-test/my-test-var` for a specific test var.
- Multiple focus symbols are supported by REPEATING the flag (kaocha accumulates them, last-wins does not apply): `clojure -M:dev:test --focus backend-tests.ns-one --focus backend-tests.ns-two` — preferred over a shell loop of isolated runs.
- Regression run: `clojure -M:dev:test` to ensure no regressions in related functional areas.
- If you need to filter output, tee to a temp file first: `clojure -M:dev:test 2>&1 | tee /tmp/penpot-test-output.txt`.
- RPC test helpers `command!`/`management-command!` split the data map: qualified keys become server params, unqualified keys become request body params. To inject request-level context (headers, `:app.http/auth-key-id`, ip), pass a map under `:app.http/request` metadata; non-map `IRequest` stubs fall back to a dummy request.

1
.serena/memories/clojure/idioms.md
View File

@ -9,3 +9,4 @@ Behaviors confirmed against the language/stdlib — do not re-derive from assump
- Valid: `(defn ^:async f)`, `(defn- ^:async f)`, `(^:async fn [] …)` (the latter is what stock `t/async` generates itself).
- `^:async` fns never throw synchronously (rejected promises instead); `try/catch/finally` supported; continuations are microtasks, timers and RxJS schedulers are macrotasks (FIFO).
- `!` suffix allowed cases (only exceptions to the no-new-`!` rule in `mem:clojure/design-rules`): mutating public `app.db` API (`insert!`, `update!`, `delete!`, `run!`, `tx-run!`, `exec!`, ...) and fns whose contract is to work over transients (stdlib `conj!`, `assoc!`, `dissoc!`, `disj!`, `persistent!` and custom helpers over them); any further case must be registered here with justification before use.
- Penpot extends `clojure.core/Inst` in `app.common.time` ( JVM-only section), so `inst-ms` also accepts `Duration` (returns `.toMillis`, NOT epoch millis), `FileTime` and `OffsetDateTime`. It only works where that namespace is loaded; on a bare `Duration`, prefer explicit `.toMillis`, which reads as what it is (an amount, not an instant).

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

@ -57,7 +57,7 @@ The memory is structured in a way that you can get the critical information abou
- `scripts/gh.py` — GitHub operations helper: list milestone issues, fetch PR details, compare against CHANGES.md. Requires `gh` CLI. See `mem:scripts/gh`.
- `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/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. See `mem:scripts/ci`.
- `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`.
# Dependency graph

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

@ -27,7 +27,7 @@ Compose-based dev environment under `docker/devenv/`, driven by `manage.sh`. Par
## Worker policy
Backend workers run only on ws0. `_env` gates `enable-backend-worker` on `PENPOT_BACKEND_WORKER`; ws1+ inject it as false. Workers are pure fire-and-forget: `wrk/submit!` inserts a row into the shared Postgres `task` table and returns; RPC handlers never wait on completion and workers never publish to msgbus. The reason for "ws0 only" is avoiding multi-instance worker races (cron dedup is best-effort across instances, `wrk/submit!` `dedupe` is racy across submitters); details in `mem:prod-infra/core`.
Backend workers run only on ws0. `_env` gates `enable-backend-worker` on `PENPOT_BACKEND_WORKER`; ws1+ inject it as false. Workers are pure fire-and-forget: `jobs/submit` inserts a row into the shared Postgres `job` table and returns (the legacy `task` table stays dormant); RPC handlers never wait on completion and workers never publish to msgbus. The reason for "ws0 only" is avoiding multi-instance worker races (cron dedup is best-effort across instances, `jobs/submit` `dedupe` is racy across submitters); details in `mem:prod-infra/core`.
Each workspace is independent and can be started/stopped in any order. Shared infra (Postgres, RustFS, etc.) is shut down only when no instances remain running.

18
.serena/memories/prod-infra/core.md
View File

@ -4,29 +4,33 @@ Backend (`app.config`, `PENPOT_*` env vars) is parameterized; deployments choose
## Services
- **PostgreSQL**: durable store. Profiles, teams, files, sessions, audit, `storage_object` metadata, the `task` queue, `scheduled_task` cron registry, migrations. File-data also lives here when the file-data backend is `legacy-db`/`db`. One shared DB across all backends.
- **PostgreSQL**: durable store. Profiles, teams, files, sessions, audit, `storage_object` metadata, the `job` work queue (plus the dormant legacy `task` table), `scheduled_task` cron registry, migrations. File-data also lives here when the file-data backend is `legacy-db`/`db`. One shared DB across all backends.
- **Redis (Valkey-compatible)**: per-backend message bus and cache. Concrete uses: msgbus Pub/Sub for collaborative-editing broadcasts and team/profile-org notifications fired by RPC handlers (`app.rpc.notifications`, `files_update`, `teams`, `websocket`); file-summary cache gated by `enable-redis-cache`; rate-limit counters; and the dispatcher→runner work hand-off list `penpot.worker.queue:<tenant>:<queue>`. `PENPOT_REDIS_URI`.
- **Object storage**: backends `:s3` and `:fs`. S3 in prod; devenv uses RustFS. Holds uploaded media, file-data when the file-data backend is `storage`, exports. Backend-side details (resolve, dedup, bucket set, object lifecycle, and file-data backends): `mem:backend/storage`.
- **SMTP mailer**: invitations, password resets, email verification (sent via the `:sendmail` worker task).
- **SMTP mailer**: invitations, password resets, email verification (sent via the `:sendmail` worker job).
- **LDAP** (optional auth provider): helpers in `app.auth.*`, gated by `enable-login-with-ldap`.
## Task queue and worker model
Async tasks are enqueued via `wrk/submit!` (`app.worker`), which inserts a row into the shared Postgres `task` table tagged with `queue = "<tenant>:<queue-name>"`. Submission is **fire-and-forget** — RPC handlers never poll, never wait, and workers never publish to msgbus. The only completion signal is the `task` row's `status` / `completed_at` columns, which nothing in `rpc/` reads. Soft-delete RPCs return immediately after marking the top-level row, leaving the cascade and reaping to workers.
Async jobs are enqueued via `jobs/submit` (`app.jobs`), which inserts a row into the shared Postgres `job` table tagged with `queue = "<tenant>:<queue-name>"`. Submission is **fire-and-forget** — RPC handlers never poll and never wait. The completion signal is the `job` row's `status` / `completed_at` columns, which nothing in `rpc/` reads today. A job submitted with `::jobs/profile-id` also publishes a `:job-event` message on that profile's msgbus topic after each transaction commits, but no caller passes a profile-id yet, so nothing reaches msgbus in production. Soft-delete RPCs return immediately after marking the top-level row, leaving the cascade and reaping to workers.
Workers run on backends with `enable-backend-worker` in `PENPOT_FLAGS`. Each worker-enabled backend has a `dispatcher` (polls `task` with `FOR UPDATE SKIP LOCKED`, marks status='scheduled', RPUSHes claimed task IDs into **its own** Redis list) and one or more `runner`s per queue (BLPOP from that same local list, execute, update the Postgres row). The Redis hand-off list is purely intra-backend — cross-backend coordination happens at the Postgres row level.
Workers run on backends with `enable-backend-worker` in `PENPOT_FLAGS`. Each worker-enabled backend has a `dispatcher` (polls `job` with `FOR UPDATE SKIP LOCKED`, marks status='scheduled', RPUSHes the JSON `[id scheduled-at]` payloads into **its own** Redis list) and one or more `runner`s per queue (BLPOP from that same local list, execute, update the Postgres row). The Redis hand-off list is purely intra-backend — cross-backend coordination happens at the Postgres row level.
## Cross-backend safety
Postgres row locking is the only correctness primitive: `task` claims via `FOR UPDATE SKIP LOCKED`, cron firing via `FOR UPDATE SKIP LOCKED` on the `scheduled_task` row, plus task-handler-internal locks (e.g. `file_gc_scheduler` locks candidate file rows). This makes the work-claim path safe across any number of worker-enabled backends.
Postgres row locking is the only correctness primitive: `job` claims via `FOR UPDATE SKIP LOCKED`, cron firing via `FOR UPDATE SKIP LOCKED` on the `scheduled_task` row, plus job-handler-internal locks (e.g. `file_gc_scheduler` locks candidate file rows). This makes the work-claim path safe across any number of worker-enabled backends.
Two known race patterns survive multi-backend operation:
- **Cron dedup is best-effort.** The lock on `scheduled_task` is released when the task body finishes. If two backends' cron timers fire for the same scheduled instant with a gap larger than the task body's runtime, both execute it. Penpot's cron entries are idempotent (`session-gc`, `objects-gc`, `storage-gc-*`, `tasks-gc`, `upload-session-gc`, `file-gc-scheduler`); the exceptions are `:telemetry` (would double-report) and `:audit-log-archive` (depends on archive target idempotency).
- **`wrk/submit! ::dedupe true`** does a non-atomic `DELETE` then `INSERT`. Concurrent cross-backend submits can both bypass the `DELETE` (each sees the other's uncommitted insert as absent) and end up with duplicate `'new'` rows. Each row claims and runs once independently, so the underlying work is fine; the "at most one pending" guarantee weakens.
- **Cron dedup is best-effort.** The lock on `scheduled_task` is released when the task body finishes. If two backends' cron timers fire for the same scheduled instant with a gap larger than the task body's runtime, both execute it. Penpot's cron entries are idempotent (`session-gc`, `objects-gc`, `storage-gc-*`, `storage-pending-gc`, `jobs-gc`, `file-gc-scheduler`); the exceptions are `:telemetry` (would double-report) and `:audit-log-archive` (depends on archive target idempotency).
- **`jobs/submit ::dedupe true`** does a non-atomic `DELETE` then `INSERT`. Concurrent cross-backend submits can both bypass the `DELETE` (each sees the other's uncommitted insert as absent) and end up with duplicate `'new'` rows. Each row claims and runs once independently, so the underlying work is fine; the "at most one pending" guarantee weakens.
Penpot in production lives with both: horizontal-scale deployments accept "exactly-once" as "essentially-once for idempotent operations." Devenv parallel instances handle it by running workers only on ws0 (see `mem:devenv/core`).
## Jobs observability
Worker-enabled, writable backends publish unified jobs metrics through the normal Prometheus registry. Counters describe submit, dispatch, terminal outcomes, retries, orphan recovery, rescheduling and total stored job events (unlabelled); histograms separate queue wait, handler execution and total job age. SQL-backed events are recorded after the outer PostgreSQL transaction commits. The `::jobs-metrics/sampler` component publishes backlog by status and the oldest pending-job age every 30 seconds. All labels are bounded operational values; job IDs, profile IDs, params and error text are excluded. Read-only backends do not start the sampler or the workers.
## See also
- Devenv composition and the ws0-only worker placement: `mem:devenv/core`.

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

@ -4,6 +4,12 @@
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`
into the compiled test code. Prefer it over calling `clojure -M:dev:test` by
hand for that reason alone: without the flag the suite passes while every
assertion is compiled out. GitHub Actions sets the same flag.
## When to use
- After implementing or fixing code in a module: run its checks before

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

@ -77,6 +77,10 @@
:telemetry-uri "https://telemetry.penpot.app/"
:jobs-lease (ct/duration {:minutes 30})
:jobs-retention (ct/duration {:days 7})
:jobs-request-timeout (ct/duration {:minutes 2})
:media-max-file-size (* 1024 1024 30) ; 30MiB
:font-max-file-size (* 1024 1024 30) ; 30MiB
@ -103,6 +107,23 @@
:ssrf-allowed-hosts #{}
:ssrf-extra-blocked-cidrs #{}})
(def schema:tenant
"Tenant identifier: hostname-label-style (letters, digits and
hyphens). It is interpolated into Redis keys separated by dots (msgbus
topics, rate-limit buckets, exporter job keys, which are also matched
with a glob pattern), so `.` and whitespace are rejected at startup
because one tenant would then be able to read or overwrite another's
keys.
`%`, `_` and `:` are rejected too, and the reason they were added is
gone: the job queue used to be filtered with a LIKE over a
`<tenant>:<queue>` prefix and now has a `tenant` column. They are kept
because narrowing the rule is a startup contract change with no real
tenant asking for it, and a tenant that has one would have to be
renamed. Tenants using those characters must be renamed before
upgrading."
[:re #"^[A-Za-z0-9-]+$"])
(def schema:config
(do #_sm/optional-keys
[:map {:title "config"}
@ -110,7 +131,7 @@
[:admins {:optional true} [::sm/set ::sm/email]]
[:secret-key {:optional true} :string]
[:tenant {:optional false} :string]
[:tenant {:optional false} schema:tenant]
[:is-saas ::sm/boolean]
[:public-uri {:optional false} ::sm/uri]
[:host {:optional false} :string]
@ -173,6 +194,9 @@
[:deletion-delay {:optional true} ::ct/duration]
[:file-clean-delay {:optional true} ::ct/duration]
[:jobs-lease {:optional true} ::ct/duration]
[:jobs-retention {:optional true} ::ct/duration]
[:jobs-request-timeout {:optional true} ::ct/duration]
[:telemetry-enabled {:optional true} ::sm/boolean]
[:default-blob-version {:optional true} ::sm/int]
[:allow-demo-users {:optional true} ::sm/boolean]
@ -190,6 +214,7 @@
[:scheduled-executor-parallelism {:optional true} ::sm/int] ;; REVIEW
[:worker-default-parallelism {:optional true} ::sm/int]
[:worker-webhook-parallelism {:optional true} ::sm/int]
[:worker-cron-parallelism {:optional true} ::sm/int]
[:database-password {:optional true} [:maybe :string]]
[:database-uri {:optional true} ::sm/uri]
@ -423,6 +448,32 @@
[& segments]
(apply join-uri (c/get config :public-uri) segments))
(defn get-jobs-lease
"Max time a job can run without touching modified_at (heartbeat or
progress) before the dispatcher marks it as `aborted` (system-side
terminal, never retried, reported with an error log)."
[]
(or (c/get config :jobs-lease)
(ct/duration {:minutes 30})))
(defn get-jobs-request-timeout
"Default timeout for the ephemeral request! calls (waiting for the
reply-key blpop); can be overridden per call. Any override is applied
by raising the pooled connection command timeout for the duration of
the call, which the pool restores on return."
[]
(or (c/get config :jobs-request-timeout)
(ct/duration {:minutes 2})))
(defn get-jobs-retention
"How long terminal (completed/failed/cancelled/aborted) internal job rows are
kept before the jobs GC deletes them. The legacy `task` table is not
touched by the jobs GC: while both versions run in parallel it is
cleaned by the legacy `tasks-gc` of that version."
[]
(or (c/get config :jobs-retention)
(ct/duration {:days 7})))
(defn get
"A configuration getter. Helps code be more testable."
([key]

62
backend/src/app/db.clj
View File

@ -583,12 +583,70 @@
(l/trc :hint "explicit rollback requested (savepoint)")
(.rollback conn sp))))
(def ^:dynamic *after-commit-context* nil)
;; the connection the ambient transaction owns, bound by `transact!` for
;; the extent of its body. It is what tells a nested call (same
;; connection) from an independent one (any other).
(def ^:dynamic *after-commit-conn* nil)
(defn- run-after-commit-callbacks
[callbacks]
(doseq [callback callbacks]
(try
(callback)
(catch Throwable cause
(l/wrn :hint "after-commit callback failed" :cause cause)))))
(defn after-commit
"Run a callback after the current transaction commits.
The callback runs immediately when called outside a transaction.
Nesting follows the connection, not an ambient flag. A transaction
opened on the connection the surrounding one owns is part of it and
shares its context, so callbacks are never drained before the
transaction that owns the connection commits. A transaction opened on
any other connection is an independent unit of work: it owns its
context, drains its callbacks at its own commit and drops them if it
rolls back."
[f]
(if *after-commit-context*
(swap! *after-commit-context* conj f)
(f)))
(defn- joins-transaction?
"True when `transactable` is the very connection the ambient
transaction owns, which is what makes this call part of it."
[transactable]
(boolean
(and *after-commit-conn*
(identical? transactable *after-commit-conn*))))
(defn transact!
"A lower-level function for executing function in a transaction"
([transactable f] (transact! transactable f {}))
([transactable f opts]
(binding [next.jdbc.transaction/*nested-tx* :ignore]
(jdbc/transact transactable f opts))))
(if (joins-transaction? transactable)
(binding [next.jdbc.transaction/*nested-tx* :ignore]
(jdbc/transact transactable f opts))
(let [context (atom [])]
(try
(let [result (binding [*after-commit-context* context]
(binding [next.jdbc.transaction/*nested-tx* :ignore]
(jdbc/transact
transactable
(fn [conn]
(binding [*after-commit-conn* conn]
(f conn)))
opts)))]
;; a rollback-only transaction commits nothing, so its
;; callbacks have nothing to follow
(when-not (:rollback-only opts)
(run-after-commit-callbacks @context))
result)
(finally
(reset! context [])))))))
(defn tx-run!
"Run a function in a transaction."

103
backend/src/app/email.clj
View File

@ -6,6 +6,7 @@
(ns app.email
"Main api for send emails."
(:refer-clojure :exclude [send])
(:require
[app.common.data :as d]
[app.common.data.macros :as dm]
@ -16,8 +17,8 @@
[app.config :as cf]
[app.db :as db]
[app.db.sql :as sql]
[app.jobs :as jobs]
[app.util.template :as tmpl]
[app.worker :as wrk]
[clojure.java.io :as io]
[cuerdas.core :as str]
[integrant.core :as ig])
@ -296,23 +297,32 @@
[email-factory params]
(email-factory params))
(defn send!
"Schedule an already defined email to be sent using asynchronously
using worker task."
[{:keys [::conn ::factory] :as params}]
(assert (db/connectable? conn) "expected a valid database connection or pool")
(defn send
"Schedule an already defined email to be sent asynchronously
using the unified jobs machinery. The first `cfg` parameter is the
connectable context that provides the `::jobs/defs` registry (an RPC
method cfg or the system) and can provide a default connection; the
second `params` provides the email data and optionally `::factory`
and `::reuse-conn`. When `::reuse-conn` is true the submission
reuses the caller's existing `::db/conn` (from cfg) instead of
acquiring a fresh one from the pool."
[cfg {:keys [::reuse-conn ::factory] :as params}]
(when (and reuse-conn (nil? (::db/conn cfg)))
(ex/raise :type :validation
:code :missing-connection
:hint "reuse-conn requires the caller cfg to carry ::db/conn (call inside a transaction)"))
(let [email (if factory
(factory params)
(-> params
(dissoc params)
(dissoc ::reuse-conn ::factory)
(check-params)))]
(wrk/submit! {::wrk/task :sendmail
::wrk/delay 0
::wrk/max-retries 4
::wrk/priority 200
::db/conn conn
::wrk/params email})))
(jobs/submit (cond-> (dissoc cfg ::db/conn)
reuse-conn (assoc ::db/conn (::db/conn cfg)))
{::jobs/name :sendmail
::jobs/delay 0
::jobs/max-retries 4
::jobs/priority 200
::jobs/params email})))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SENDMAIL FN / TASK HANDLER
@ -320,39 +330,44 @@
(declare send-to-logger!)
(defn- sendmail-impl
[cfg params]
(when (contains? cf/flags :smtp)
(let [session (create-smtp-session cfg)]
(with-open [transport (.getTransport session (if (::ssl cfg) "smtps" "smtp"))]
(.connect ^Transport transport
^String (::host cfg)
^String (::port cfg)
^String (::username cfg)
^String (::password cfg))
(let [^MimeMessage message (create-smtp-message cfg session params)]
(l/dbg :hint "sendmail"
:id (:id params)
:to (:to params)
:subject (str/trim (:subject params)))
(.sendMessage ^Transport transport
^MimeMessage message
(.getAllRecipients message))))))
(when (contains? cf/flags :log-emails)
(send-to-logger! cfg params)))
(defmethod ig/init-key ::sendmail
[_ cfg]
(fn [params]
(when (contains? cf/flags :smtp)
(let [session (create-smtp-session cfg)]
(with-open [transport (.getTransport session (if (::ssl cfg) "smtps" "smtp"))]
(.connect ^Transport transport
^String (::host cfg)
^String (::port cfg)
^String (::username cfg)
^String (::password cfg))
;; the job handler: [context params]. The smtp deps are closed over
;; here, and this job has no use for the context.
(fn [_context params]
(sendmail-impl cfg params)))
(let [^MimeMessage message (create-smtp-message cfg session params)]
(l/dbg :hint "sendmail"
:id (:id params)
:to (:to params)
:subject (str/trim (:subject params)))
(.sendMessage ^Transport transport
^MimeMessage message
(.getAllRecipients message))))))
(when (contains? cf/flags :log-emails)
(send-to-logger! cfg params))))
(defmethod ig/assert-key ::handler
[_ params]
(assert (fn? (::sendmail params)) "expected valid sendmail handler"))
(defmethod ig/init-key ::handler
[_ {:keys [::sendmail]}]
(fn [{:keys [props] :as task}]
(sendmail props)))
(defmethod ig/init-key ::job-def
[_ {sendmail ::sendmail}]
{::jobs/name :sendmail
::jobs/schema schema:params
::jobs/handler sendmail
::jobs/decoder (sm/decoder schema:params sm/json-transformer)
::jobs/validator (sm/validator schema:params)})
(defn- send-to-logger!
[_ email]

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

@ -19,9 +19,9 @@
[app.db :as db]
[app.db.sql :as-alias sql]
[app.features.fdata :as fdata]
[app.jobs :as jobs]
[app.storage :as sto]
[app.util.blob :as blob]
[app.worker :as wrk]
[cuerdas.core :as str]))
(def sql:snapshots
@ -406,12 +406,12 @@
(assert (uuid? file-id) "missing file-id")
(assert (ct/inst? deleted-at) "missing deleted-at")
(wrk/submit! {::db/conn (db/get-connection cfg)
::wrk/task :delete-object
::wrk/params {:object :snapshot
:deleted-at deleted-at
:file-id file-id
:id id}})
(jobs/submit cfg
{::jobs/name :delete-object
::jobs/params {:object :snapshot
:deleted-at deleted-at
:file-id file-id
:id id}})
(db/update! cfg :file-change
{:deleted-at deleted-at}
{:id id :file-id file-id}

34
backend/src/app/http/session.clj
View File

@ -18,6 +18,7 @@
[app.http :as-alias http]
[app.http.auth :as-alias http.auth]
[app.http.session.tasks :as-alias tasks]
[app.jobs :as jobs]
[app.main :as-alias main]
[app.setup :as-alias setup]
[app.setup.clock :as clock]
@ -329,7 +330,7 @@
;; TASK: SESSION GC
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod ig/assert-key ::tasks/gc
(defmethod ig/assert-key ::job-def
[_ params]
(assert (db/pool? (::db/pool params)) "expected valid database pool")
(assert (ct/duration? (::tasks/max-age params)))
@ -341,7 +342,7 @@
(throw (IllegalArgumentException.
"absolute session max-age must be greater than or equal to idle max-age"))))
(defmethod ig/expand-key ::tasks/gc
(defmethod ig/expand-key ::job-def
[k v]
(let [max-age (cf/get :auth-token-cookie-max-age default-cookie-max-age)
max-age-absolute (cf/get :auth-token-cookie-max-age-absolute
@ -368,10 +369,25 @@
:deleted result)
result))
(defmethod ig/init-key ::tasks/gc
[_ {:keys [::tasks/max-age ::tasks/max-age-absolute] :as cfg}]
(l/dbg :hint "initializing session gc task"
:max-age max-age
:max-age-absolute max-age-absolute)
(fn [_]
(db/tx-run! cfg collect-expired-tasks)))
(declare execute-session-gc)
(def schema:session-gc-params
"Params map (no params needed; config-derived only)."
[:map {:closed true}])
(defmethod ig/init-key ::job-def
[_ cfg]
{::jobs/name :session-gc
::jobs/schema schema:session-gc-params
::jobs/handler
(fn [_context params]
(execute-session-gc cfg params))
::jobs/decoder (sm/decoder schema:session-gc-params sm/json-transformer)
::jobs/validator (sm/validator schema:session-gc-params)})
(defn execute-session-gc
"Plain job handler: delete expired http sessions."
([cfg] (execute-session-gc cfg nil))
([cfg _params]
(jobs/heartbeat cfg)
(db/tx-run! cfg collect-expired-tasks)))

1187
backend/src/app/jobs.clj Normal file
View File

File diff suppressed because it is too large Load Diff

164
backend/src/app/jobs/gc.clj Normal file
View File

@ -0,0 +1,164 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS INC
(ns app.jobs.gc
"A maintenance cron task for the unified `job` table:
- expiration: deletes rows with `expires_at` in the past (any status,
user or internal). Expiration is the mechanism for user-facing jobs
and for jobs carrying volatile resources.
- retention: deletes internal terminal rows (no profile, status in
completed/failed/cancelled/aborted) older than the `:jobs-retention` delay.
The dormant legacy `task` table is cleaned by the parallel legacy
version until the next release, which is what allows PRE and HOURLY to
run side by side on the same database and the deploy to roll back.
User-facing terminal rows (profile_id NOT NULL) are
NOT swept by retention: they are governed by `expires_at` (or stay
as ledger history).
Rows carrying a `resource_id` touch their storage object (touched_at
set in the same transaction, mirroring `sto/touch-object!`) so
`storage-gc-touched` reclaims it: deleting the job row does not touch
the `storage_object` (ON DELETE SET NULL only fires when the object
row is deleted, not the job row), and gc-touched only analyzes objects
already marked with `touched_at` — without the explicit touch the
object would be orphaned.
Each batch deletes and touches in its own transaction: a crash
leaves the remaining batches for the next tick, and an object can
never lose its referencing row without being marked for reclaim.
`job` carries a deletion-protection trigger, so each batch disables
it first (`SET LOCAL rules.deletion_protection TO off`): the GC is
the intended deleter, and the guard only exists so a stray
`DELETE FROM job` cannot drop a row without touching its object."
(:require
[app.common.logging :as l]
[app.common.schema :as sm]
[app.common.time :as ct]
[app.config :as cf]
[app.db :as db]
[app.jobs :as jobs]
[app.jobs.metrics :as metrics]
[integrant.core :as ig]))
(def ^:private sql:touch-objects
"UPDATE storage_object
SET touched_at = ?
WHERE id = ANY(?::uuid[])")
(def ^:private gc-batch-size 1000)
(def ^:private sql:delete-expired-jobs
"DELETE FROM job
WHERE id IN (SELECT id
FROM job
WHERE expires_at < now()
AND status NOT IN ('running', 'retry')
LIMIT ?)
RETURNING resource_id")
(def ^:private sql:delete-retained-jobs
"DELETE FROM job
WHERE id IN (SELECT id
FROM job
WHERE status IN ('completed', 'failed', 'cancelled', 'aborted')
AND profile_id IS NULL
AND modified_at < now() - ?::interval
LIMIT ?)
RETURNING resource_id")
(defn- touch-resources
[conn resource-ids]
(if (seq resource-ids)
(-> (db/exec-one! conn [sql:touch-objects (ct/now)
(db/create-array conn "uuid" resource-ids)])
(db/get-update-count))
0))
(defn- delete-jobs
[cfg kind sql & params]
(loop [deleted 0
touched 0]
(let [[rows touched-now]
(db/tx-run! cfg
(fn [{:keys [::db/conn]}]
(db/exec-one! conn ["SET LOCAL rules.deletion_protection TO off"])
(let [rows (db/exec! conn (conj (into [sql] params)
gc-batch-size))
resource-ids (into [] (keep :resource-id) rows)
touched (touch-resources conn resource-ids)]
(db/after-commit
#(do
(metrics/record-gc-rows
cfg kind :deleted (count rows))
(metrics/record-gc-rows
cfg kind :touched touched)))
[rows touched])))
deleted' (+ deleted (count rows))
touched' (+ touched touched-now)]
(if (< (count rows) gc-batch-size)
[deleted' touched']
(do (jobs/heartbeat cfg)
(recur deleted' touched'))))))
(declare execute-jobs-gc)
(def schema:jobs-gc-params
"min-age: duration object, integer millis or duration string
in-process; integer millis or duration string over the job pipeline
(a duration object does not survive JSON encoding). The handler
always normalizes with ct/duration."
[:map
[:min-age {:optional true} [:or :int :string ::ct/duration]]])
(defmethod ig/init-key ::job-def
[_ cfg]
{::jobs/name :jobs-gc
::jobs/schema schema:jobs-gc-params
::jobs/handler (fn [_context params]
(execute-jobs-gc cfg params))
::jobs/decoder (sm/decoder schema:jobs-gc-params sm/json-transformer)
::jobs/validator (sm/validator schema:jobs-gc-params)})
(defn execute-jobs-gc
"Plain job handler: delete expired rows (expires_at) and retained
internal terminal rows, marking the storage resources of the deleted
rows as touched.
Deletes run in bounded batches of 1000 rows, each batch in its own
transaction, with a heartbeat between batches so long sweeps neither
spike the WAL nor outrun the job lease."
[cfg params]
(let [min-age
(ct/duration (or (:min-age params)
(cf/get-jobs-retention)))
expired-tpoint
(ct/tpoint)
[deleted-expired touched-expired]
(delete-jobs cfg :expired sql:delete-expired-jobs)
retained-tpoint
(ct/tpoint)
[deleted-retained touched-retained]
(delete-jobs cfg :retained sql:delete-retained-jobs
(db/interval min-age))]
(metrics/record-gc-duration cfg :expired (inst-ms (expired-tpoint)))
(metrics/record-gc-duration cfg :retained (inst-ms (retained-tpoint)))
(l/dbg :hint "finished"
:deleted-expired deleted-expired
:touched-expired touched-expired
:deleted-retained deleted-retained
:touched-retained touched-retained)
{:deleted-expired deleted-expired
:touched-expired touched-expired
:deleted-retained deleted-retained
:touched-retained touched-retained}))

248
backend/src/app/jobs/metrics.clj Normal file
View File

@ -0,0 +1,248 @@
;; 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.jobs.metrics
"Metric names, labels and the jobs backlog sampler.
Labels are bounded by construction, not by allowlist: every value
recorded here comes from a fixed call site (a job name from the
registry, a queue from submit, an outcome from the lifecycle
writers), never from params, IDs or exception text. A new value
showing up in Prometheus means new code, which is exactly what you
want to see: folding it into some other bucket would only hide it.
This namespace is intentionally free of job handlers. Callers pass only
values already known at their boundary; IDs, props and exception text never
become metric labels."
(:require
[app.common.data :as d]
[app.common.logging :as l]
[app.common.schema :as sm]
[app.db :as db]
[app.metrics :as mtx]
[cuerdas.core :as str]
[integrant.core :as ig]
[promesa.exec :as px]))
(set! *warn-on-reflection* true)
(defn queue-label
"Coerce a queue to its label: lowercase, with \"other\" only when there
is no queue at all. A new queue shows up as-is: that means new code."
[queue]
(str/lower (mtx/label queue "other")))
;; Job names go to the metric as-is: the registry is fixed (one job-def
;; per name, wired in `app.main`), so cardinality is bounded by it.
;; Anything without a name (nil) still falls back to "other".
(defn- name-label [name]
(mtx/label name "other"))
(defn- gc-kind-label [kind]
(str/lower (or (some-> kind d/name) "other")))
(defn- outcome-label [outcome]
(str/lower (or (some-> outcome d/name) "failed")))
(defn- retry-reason-label [reason]
(str/lower (or (some-> reason d/name) "backoff")))
(defn- stage-label [stage]
(str/lower (or (some-> stage d/name) "execution")))
(defn- record-value [metrics id labels value]
(mtx/run! metrics :id id :labels labels :val value))
(defn- record-count [metrics id labels amount]
(mtx/run! metrics :id id :labels labels :inc amount))
(defn record-submitted
[cfg name queue]
(record-count (mtx/instance cfg) :jobs-submitted
[(name-label name) (queue-label queue)]
1))
(defn record-dispatched
[cfg name queue amount]
(record-count (mtx/instance cfg) :jobs-dispatched
[(name-label name) (queue-label queue)]
amount))
(defn record-outcome
[cfg name queue outcome]
(record-count (mtx/instance cfg) :jobs-completed
[(name-label name) (queue-label queue)
(outcome-label outcome)]
1))
(defn record-retry
[cfg name queue reason]
(record-count (mtx/instance cfg) :jobs-retries
[(name-label name) (queue-label queue)
(retry-reason-label reason)]
1))
(defn record-event
"Total number of job events stored. No labels: the interesting split is
`kind`, and grouping a growing append-only table to build a metric is not
worth the query on the write path."
[cfg]
(record-count (mtx/instance cfg) :jobs-events-total [] 1))
(defn record-orphan
[cfg queue]
(record-count (mtx/instance cfg) :jobs-orphaned
[(queue-label queue)]
1))
(defn record-rescheduled
[cfg queue]
(record-count (mtx/instance cfg) :jobs-rescheduled
[(queue-label queue)]
1))
(defn record-queue-wait
[cfg name queue millis]
(record-value (mtx/instance cfg) :jobs-queue-wait-timing
[(name-label name) (queue-label queue)]
(max 0 (long millis))))
(defn record-execution
[cfg name queue millis]
(record-value (mtx/instance cfg) :jobs-execution-timing
[(name-label name) (queue-label queue)]
(max 0 (long millis))))
(defn record-legacy-execution
"Histogram `penpot_tasks_timing`, from the pre-jobs `task` queue.
It only carries the job name label, with no queue to tell jobs of the
same name apart. Use `record-execution`, which adds the queue label,
for anything new. Kept exported only so the dashboards and the alerts
that already read it keep working: like every other jobs metric,
the label is the raw job name."
[cfg name millis]
(record-value (mtx/instance cfg) :tasks-timing
[(mtx/label name "other")]
(max 0 (long millis))))
(defn record-total
[cfg name queue outcome millis]
(record-value (mtx/instance cfg) :jobs-total-timing
[(name-label name) (queue-label queue)
(outcome-label outcome)]
(max 0 (long millis))))
(defn record-dispatcher-batch
[cfg stage outcome millis]
(record-value (mtx/instance cfg) :jobs-dispatcher-timing
[(stage-label stage) (outcome-label outcome)]
(max 0 (long millis))))
(defn record-dispatcher-size
[cfg queue size]
(record-value (mtx/instance cfg) :jobs-dispatcher-batch-size
[(queue-label queue)]
size))
(defn record-gc-rows
[cfg kind action amount]
(record-count (mtx/instance cfg) :jobs-gc-rows
[(gc-kind-label kind)
(str/lower (or (some-> action d/name) "deleted"))]
amount))
(defn record-gc-duration
[cfg kind millis]
(record-value (mtx/instance cfg) :jobs-gc-timing
[(gc-kind-label kind)]
(max 0 (long millis))))
(defn record-cron
[cfg outcome reason]
(record-count (mtx/instance cfg) :jobs-cron-total
[(str/lower (or (some-> outcome d/name) "error"))
(str/lower (or (some-> reason d/name) "none"))]
1))
(defn record-request
[cfg outcome millis]
(let [outcome (str/lower (or (some-> outcome d/name) "error"))
metrics (mtx/instance cfg)]
(record-count metrics :jobs-requests-total [outcome] 1)
(record-value metrics :jobs-request-timing [outcome]
(max 0 (long millis)))))
(def ^:private backlog-statuses
["new" "scheduled" "running" "retry" "completed" "failed" "cancelled" "aborted"])
(def ^:private sql:backlog
"SELECT status, count(*) AS n
FROM job
GROUP BY status")
(def ^:private sql:oldest-pending
"SELECT coalesce(extract(epoch FROM (now() - min(created_at))), 0) AS age
FROM job
WHERE status IN ('new', 'scheduled', 'retry')")
(defn sample-backlog
"Update the current job backlog gauges. The query is intentionally small
and runs periodically rather than from the worker hot path."
[{:keys [::db/pool] :as cfg}]
(let [rows (db/exec! pool [sql:backlog])
by-id (into {} (map (juxt :status #(or (:n %) 0))) rows)
age (-> (db/exec-one! pool [sql:oldest-pending])
:age
(max 0)
(double))
metrics (mtx/instance cfg)]
(doseq [status backlog-statuses]
(record-value metrics :jobs-backlog [status] (get by-id status 0)))
(record-value metrics :jobs-oldest-pending-age [] age)
age))
(defn- sample-jobs-metrics [cfg]
(try
(sample-backlog cfg)
(catch Throwable cause
(l/warn :hint "unable to sample jobs metrics" :cause cause))))
(def ^:private sample-interval-ms 30000)
(defn create-sampler
"Create the daemon scheduler used by the jobs metrics component."
[cfg]
(let [scheduler (px/scheduled-executor
:parallelism 1
:factory (px/thread-factory :prefix "penpot/jobs-metrics/"
:daemon true))
sample (fn sample []
(try
(sample-jobs-metrics cfg)
(finally
(px/schedule scheduler sample-interval-ms sample))))]
(px/schedule scheduler 0 sample)
scheduler))
(def ^:private schema:sampler
[:map
::db/pool
::mtx/metrics])
(defmethod ig/assert-key ::sampler
[_ cfg]
(assert (sm/check schema:sampler cfg)))
(defmethod ig/init-key ::sampler
[_ {:keys [::db/pool] :as cfg}]
(if (db/read-only? pool)
(l/warn :hint "not started (db is read-only)")
(create-sampler cfg)))
(defmethod ig/halt-key! ::sampler
[_ sampler]
(some-> sampler px/shutdown-now))

34
backend/src/app/loggers/audit.clj
View File

@ -13,19 +13,20 @@
[app.common.logging :as l]
[app.common.schema :as sm]
[app.common.time :as ct]
[app.common.transit :as t]
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
[app.email :as email]
[app.http :as-alias http]
[app.http.access-token :as-alias actoken]
[app.jobs :as jobs]
[app.loggers.audit.tasks :as-alias tasks]
[app.loggers.webhooks :as-alias webhooks]
[app.rpc :as-alias rpc]
[app.setup :as-alias setup]
[app.util.inet :as inet]
[app.util.services :as-alias sv]
[app.worker :as wrk]
[cuerdas.core :as str]
[yetti.request :as yreq]))
@ -295,19 +296,24 @@
:else label)
dedupe? (boolean (and batch-key batch-timeout))]
(wrk/submit! (-> cfg
(assoc ::wrk/task :process-webhook-event)
(assoc ::wrk/queue :webhooks)
(assoc ::wrk/max-retries 0)
(assoc ::wrk/delay (or batch-timeout 0))
(assoc ::wrk/dedupe dedupe?)
(assoc ::wrk/label label)
(assoc ::wrk/params (-> event
(d/without-qualified)
(dissoc :source)
(dissoc :context)
(dissoc :ip-addr)
(dissoc :type)))))))
(jobs/submit cfg
{::jobs/name :process-webhook-event
::jobs/queue :webhooks
::jobs/max-retries 0
::jobs/delay (or batch-timeout 0)
::jobs/dedupe dedupe?
::jobs/label label
;; The event travels as an opaque transit blob:
;; transit preserves the instant/UUID/set types
;; that plain JSON props cannot carry.
::jobs/params {:event-blob
(t/encode-str
(-> event
(d/without-qualified)
(dissoc :source)
(dissoc :context)
(dissoc :ip-addr)
(dissoc :type)))}})))
event)
(defn submit*

84
backend/src/app/loggers/audit/archive_task.clj
View File

@ -10,9 +10,11 @@
[app.common.logging :as l]
[app.common.schema :as sm]
[app.common.transit :as t]
[app.common.uri :as u]
[app.config :as cf]
[app.db :as db]
[app.http.client :as http]
[app.jobs :as jobs]
[app.nitrate :as nitrate]
[app.setup :as-alias setup]
[integrant.core :as ig]
@ -161,46 +163,56 @@
(mark-archived! cfg rows)
(count events))))))))
(def ^:private schema:handler-params
(declare execute-audit-log-archive)
(def schema:audit-log-archive-params
"Optional overrides for the repl invocation defaults."
[:map
::db/pool
::setup/shared-keys
::http/client
[:app.nitrate/client {:optional true} [:maybe :map]]])
[:app.nitrate/client {:optional true} [:maybe :map]]
[:enabled {:optional true} :boolean]
[:uri {:optional true} ::sm/uri]])
(defmethod ig/assert-key ::handler
[_ params]
(assert (sm/valid? schema:handler-params params) "valid params expected for handler"))
(defmethod ig/init-key ::handler
(defmethod ig/init-key ::job-def
[_ cfg]
(fn [{:keys [props] :as params}]
;; NOTE: this let allows overwrite default configured values from
;; the repl, when manually invoking the task. Prefer setting a send
;; flag (:admin-console and/or :nexus); :enabled alone
;; marks chunks without shipping. `invoke!` passes params under
;; `:props`; direct REPL calls may pass a flat map.
(let [props (or props params)
enabled (or (contains? cf/flags :nexus)
(contains? cf/flags :admin-console)
(:enabled props false))
{::jobs/name :audit-log-archive
::jobs/schema schema:audit-log-archive-params
::jobs/handler
(fn [_context params]
(execute-audit-log-archive cfg params))
::jobs/decoder (sm/decoder schema:audit-log-archive-params sm/json-transformer)
::jobs/validator (sm/validator schema:audit-log-archive-params)})
uri (cf/get :audit-log-archive-uri)
uri (or uri (:uri props))
cfg (assoc cfg ::uri uri)]
(when (and (contains? cf/flags :nexus)
(not uri))
(ex/raise :type :internal
:code :task-not-configured
:hint "archive task not configured, missing uri"))
(when enabled
(loop [total 0]
(if-let [n (archive-events! cfg)]
(do
(px/sleep 100)
(recur (+ total ^long n)))
(when (pos? total)
(l/dbg :hint "events archived" :total total))))))))
(defn execute-audit-log-archive
"Plain job handler: archive the accumulated audit events in chunks
(heartbeat per iteration: the sent chunk batches can be long)."
[cfg params]
;; NOTE: this let allows overwrite default configured values from
;; the repl, when manually invoking the task. Prefer setting a send
;; flag (:admin-console and/or :nexus); :enabled alone
;; marks chunks without shipping.
(let [enabled (or (contains? cf/flags :nexus)
(contains? cf/flags :admin-console)
(:enabled params false))
uri (cf/get :audit-log-archive-uri)
uri (or uri (:uri params))
;; Normalize to an uri object; params may carry a plain string
;; on direct invocations (validation only applies on submit!).
uri (u/uri uri)
cfg (assoc cfg ::uri uri)]
(when (and (contains? cf/flags :nexus)
(not uri))
(ex/raise :type :internal
:code :task-not-configured
:hint "archive task not configured, missing uri"))
(when enabled
(loop [total 0]
(if-let [n (archive-events! cfg)]
(do
(jobs/heartbeat cfg)
(px/sleep 100)
(recur (+ total ^long n)))
(when (pos? total)
(l/dbg :hint "events archived" :total total)))))))

27
backend/src/app/loggers/audit/gc_task.clj
View File

@ -7,7 +7,9 @@
(ns app.loggers.audit.gc-task
(:require
[app.common.logging :as l]
[app.common.schema :as sm]
[app.db :as db]
[app.jobs :as jobs]
[integrant.core :as ig]))
(def ^:private sql:clean-archived
@ -21,11 +23,24 @@
(l/debug :hint "delete archived audit log entries" :deleted result)
result))
(defmethod ig/assert-key ::handler
[_ params]
(assert (db/pool? (::db/pool params)) "valid database pool expected"))
(declare execute-audit-log-gc)
(defmethod ig/init-key ::handler
(def schema:audit-log-gc-params
"Params map (no params needed; config-derived only)."
[:map {:closed true}])
(defmethod ig/init-key ::job-def
[_ cfg]
(fn [_]
(clean-archived! cfg)))
{::jobs/name :audit-log-gc
::jobs/schema schema:audit-log-gc-params
::jobs/handler
(fn [_context params]
(execute-audit-log-gc cfg params))
::jobs/decoder (sm/decoder schema:audit-log-gc-params sm/json-transformer)
::jobs/validator (sm/validator schema:audit-log-gc-params)})
(defn execute-audit-log-gc
"Plain job handler: delete the archived audit log entries."
([cfg] (execute-audit-log-gc cfg nil))
([cfg _params]
(clean-archived! cfg)))

17
backend/src/app/loggers/database.clj
View File

@ -96,12 +96,11 @@
"Convert the log record into a report object and persist it on the database"
[{:keys [::db/pool]} {:keys [::l/id] :as record}]
(try
(let [uri (cf/get :public-uri)
report (-> record log-record->report d/without-nils)]
(let [report (-> record log-record->report d/without-nils)]
(l/dbg :hint "registering error on database"
:id (str id)
:src "logging"
:uri (str uri "/dbg/error/" id))
:uri (cf/get-public-uri "dbg/error/" (str id)))
(persist-on-database! pool id 3 report))
(catch Throwable cause
(l/warn :hint "unexpected exception on database error logger" :cause cause))))
@ -139,12 +138,11 @@
"Convert the log record into a report object and persist it on the database"
[{:keys [::db/pool]} {:keys [id] :as event}]
(try
(let [uri (cf/get :public-uri)
report (-> event audit-event->report d/without-nils)]
(let [report (-> event audit-event->report d/without-nils)]
(l/dbg :hint "registering error on database"
:id (str id)
:src "audit-log"
:uri (str uri "/dbg/error/" id))
:uri (cf/get-public-uri "dbg/error/" (str id)))
(persist-on-database! pool id 4 report))
(catch Throwable cause
(l/warn :hint "unexpected exception on database error logger" :cause cause))))
@ -172,18 +170,17 @@
:value (pp/pprint-str result :length 50)
:tenant (cf/get :tenant)
:version (:full cf/version)
:href (str (cf/get :public-uri))}))
:href (cf/get-public-uri)}))
(defn- handle-rlimit-event
"Convert the log record into a report object and persist it on the database"
[{:keys [::db/pool]} {:keys [::rlimit/id] :as event}]
(try
(let [uri (cf/get :public-uri)
report (-> event rlimit-event->report d/without-nils)]
(let [report (-> event rlimit-event->report d/without-nils)]
(l/dbg :hint "registering rate limit rejection"
:id (str id)
:src "rlimit"
:uri (str uri "/dbg/error/" id))
:uri (cf/get-public-uri "dbg/error/" (str id)))
(persist-on-database! pool id 5 report))
(catch Throwable cause
(l/warn :hint "unexpected exception on database error logger" :cause cause))))

3
backend/src/app/loggers/mattermost.clj
View File

@ -11,7 +11,6 @@
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.common.pprint :as pp]
[app.common.uri :as u]
[app.config :as cf]
[app.http.client :as http]
[app.loggers.audit :as audit]
@ -28,7 +27,7 @@
(let [type (get report :type)
text (str "#" type " | " (d/escape-markdown (get report :hint)) "\n"
(when id
(str (u/join (cf/get :public-uri) "/dbg/error/" id) " "))
(str (cf/get-public-uri "dbg/error/" id) " "))
(when-let [pid (:profile-id report)]
(if (uuid? pid)

167
backend/src/app/loggers/webhooks.clj
View File

@ -10,14 +10,15 @@
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.logging :as l]
[app.common.schema :as sm]
[app.common.time :as ct]
[app.common.transit :as t]
[app.common.uri :as uri]
[app.config :as cf]
[app.db :as db]
[app.http.client :as http]
[app.jobs :as jobs]
[app.loggers.audit :as audit]
[app.worker :as wrk]
[clojure.data.json :as json]
[cuerdas.core :as str]
[integrant.core :as ig]))
@ -60,35 +61,54 @@
(some->> (:project-id props) (lookup-webhooks-by-project pool))
(some->> (:file-id props) (lookup-webhooks-by-file pool))))
(defmethod ig/assert-key ::process-event-handler
(defmethod ig/assert-key ::process-webhook-event-job-def
[_ params]
(assert (db/pool? (::db/pool params)) "expect valid database pool")
(assert (http/client? (::http/client params)) "expect valid http client"))
(defmethod ig/init-key ::process-event-handler
(defn process-event-impl
[cfg {:keys [event-blob]}]
;; The blob carries the original typed event; decode it once for the
;; lookups below and forward it untouched so deliveries keep the
;; exact instant/UUID/set types of the legacy worker.
(let [props (t/decode-str event-blob)
items (lookup-webhooks cfg props)
event {:profile-id (:profile-id props)
:name "webhook"
:type "trigger"
:props {:name (get props :name)
:event-id (get props :id)
:total-affected (count items)}}]
(audit/insert cfg event)
(when items
(l/trc :hint "webhooks found for event" :total (count items))
(db/tx-run! cfg (fn [cfg]
(doseq [item items]
(jobs/submit cfg
{::jobs/name :run-webhook
::jobs/queue :webhooks
::jobs/max-retries 3
::jobs/params {:event event-blob
:config (select-keys item [:id :uri :mtype])}})))))))
(def schema:process-webhook-event-params
"The audited event travels as an opaque transit blob: transit
preserves the instant/UUID/set types that plain JSON props cannot
carry, so no per-key type declarations are needed."
[:map [:event-blob :string]])
(defmethod ig/init-key ::process-webhook-event-job-def
[_ cfg]
(fn [{:keys [props] :as task}]
(let [items (lookup-webhooks cfg props)
event {:profile-id (:profile-id props)
:name "webhook"
:type "trigger"
:props {:name (get props :name)
:event-id (get props :id)
:total-affected (count items)}}]
(audit/insert cfg event)
(when items
(l/trc :hint "webhooks found for event" :total (count items))
(db/tx-run! cfg (fn [cfg]
(doseq [item items]
(wrk/submit! (-> cfg
(assoc ::wrk/task :run-webhook)
(assoc ::wrk/queue :webhooks)
(assoc ::wrk/max-retries 3)
(assoc ::wrk/params {:event props
:config item}))))))))))
{::jobs/name :process-webhook-event
::jobs/schema schema:process-webhook-event-params
::jobs/handler
(fn [_context params]
(process-event-impl cfg params))
::jobs/decoder (sm/decoder schema:process-webhook-event-params sm/json-transformer)
::jobs/validator (sm/validator schema:process-webhook-event-params)})
;; --- RUN
(declare interpret-exception)
@ -98,17 +118,17 @@
{:key-fn str/camel
:indent true})
(defmethod ig/assert-key ::run-webhook-handler
(defmethod ig/assert-key ::run-webhook-job-def
[_ params]
(assert (db/pool? (::db/pool params)) "expect valid database pool")
(assert (http/client? (::http/client params)) "expect valid http client"))
(defmethod ig/expand-key ::run-webhook-handler
(defmethod ig/expand-key ::run-webhook-job-def
[k v]
{k (merge {::max-errors 3} (d/without-nils v))})
(defmethod ig/init-key ::run-webhook-handler
[_ {:keys [::db/pool ::max-errors] :as cfg}]
(defn run-webhook-impl
[{:keys [::db/pool ::max-errors] :as cfg} props]
(letfn [(update-webhook! [whook err]
(if err
(let [sql [(str "update webhook "
@ -137,39 +157,68 @@
:req-data (db/tjson req)
:rsp-data (db/tjson rsp)}))]
(fn [{:keys [props] :as task}]
(let [event (:event props)
whook (:config props)
(let [event (t/decode-str (:event props))
whook (:config props)
body (case (:mtype whook)
"application/json" (json/write-str event json-write-opts)
"application/transit+json" (t/encode-str event)
"application/x-www-form-urlencoded" (uri/map->query-string event))]
body (case (:mtype whook)
"application/json" (json/write-str event json-write-opts)
"application/transit+json" (t/encode-str event)
"application/x-www-form-urlencoded" (uri/map->query-string event))]
(l/dbg :hint "run webhook"
:event-name (:name event)
:webhook-id (str (:id whook))
:webhook-uri (:uri whook)
:webhook-mtype (:mtype whook))
(l/dbg :hint "run webhook"
:event-name (:name event)
:webhook-id (str (:id whook))
:webhook-uri (:uri whook)
:webhook-mtype (:mtype whook))
(let [req {:uri (:uri whook)
:headers {"content-type" (:mtype whook)
"user-agent" (str/ffmt "penpot/%" (:main cf/version))}
:timeout (ct/duration "4s")
:method :post
:body body}]
(try
(let [rsp (http/req cfg req {:response-type :input-stream :sync? true})
err (interpret-response rsp)]
(report-delivery! whook req rsp err)
(update-webhook! whook err))
(catch Throwable cause
(let [err (interpret-exception cause)]
(report-delivery! whook req nil err)
(update-webhook! whook err)
(when (= err "unknown")
(l/err :hint "unknown error on webhook request"
:cause cause))))))))))
(let [req {:uri (:uri whook)
:headers {"content-type" (:mtype whook)
"user-agent" (str/ffmt "penpot/%" (:main cf/version))}
:timeout (ct/duration "4s")
:method :post
:body body}]
(try
(let [rsp (http/req cfg req {:response-type :input-stream :sync? true})
err (interpret-response rsp)]
(report-delivery! whook req rsp err)
(update-webhook! whook err))
(catch Throwable cause
(let [err (interpret-exception cause)]
(report-delivery! whook req nil err)
(update-webhook! whook err)
(when (= err "unknown")
(l/err :hint "unknown error on webhook request"
:cause cause)))))))))
(def schema:run-webhook-config
"Subset of the webhook row consumed by the run-webhook job. The uri
stays text on purpose: configs come straight from the database and
submit! validates raw params without coercion."
[:map
[:id ::sm/uuid]
[:uri ::sm/text]
[:mtype ::sm/text]])
(def schema:run-webhook-params
"The event travels as the original transit blob inside the JSON job
props: process-webhook-event receives the transit-encoded audited
event and forwards it untouched, and the handler transit-decodes it
before delivery. This keeps the wire payload identical to the legacy
worker for every mtype, whatever shape the event has."
[:map
[:event :string]
[:config schema:run-webhook-config]])
(defmethod ig/init-key ::run-webhook-job-def
[_ cfg]
{::jobs/name :run-webhook
::jobs/schema schema:run-webhook-params
::jobs/handler
(fn [_context params]
(run-webhook-impl cfg params))
::jobs/decoder (sm/decoder schema:run-webhook-params sm/json-transformer)
::jobs/validator (sm/validator schema:run-webhook-params)})
(defn interpret-response
[{:keys [status] :as response}]

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

@ -23,8 +23,10 @@
[app.http.link-preview :as-alias http.link-preview]
[app.http.management :as mgmt]
[app.http.session :as session]
[app.http.session.tasks :as-alias session.tasks]
[app.http.websocket :as http.ws]
[app.jobs :as-alias jobs]
[app.jobs.gc :as-alias jobs.gc]
[app.jobs.metrics :as jobs-metrics]
[app.loggers.webhooks :as-alias webhooks]
[app.metrics :as-alias mtx]
[app.metrics.definition :as-alias mdef]
@ -97,7 +99,12 @@
:tasks-timing
{::mdef/name "penpot_tasks_timing"
::mdef/help "Background tasks timing (milliseconds)."
;; Deprecated: superseded by `penpot_jobs_execution_ms`, which adds a
;; queue label. Kept only for existing dashboards and alerts. The help
;; text is what someone reading /metrics sees, so it is where the
;; redirect belongs: the name and the labels stay untouched, so no
;; panel or alert breaks.
::mdef/help "Deprecated: use penpot_jobs_execution_ms, which adds a queue label."
::mdef/labels ["name"]
::mdef/type :histogram}
@ -225,7 +232,126 @@
:http-connector-errors-total
{::mdef/name "penpot_http_connector_errors_total"
::mdef/help "Total number of handler errors in the http listener."
::mdef/type :counter}})
::mdef/type :counter}
:jobs-submitted
{::mdef/name "penpot_jobs_submitted_total"
::mdef/help "Total number of durable jobs submitted."
::mdef/labels ["name" "queue"]
::mdef/type :counter}
:jobs-dispatched
{::mdef/name "penpot_jobs_dispatched_total"
::mdef/help "Total number of jobs pushed to a worker queue."
::mdef/labels ["name" "queue"]
::mdef/type :counter}
:jobs-completed
{::mdef/name "penpot_jobs_completed_total"
::mdef/help "Total number of durable jobs reaching a terminal state."
::mdef/labels ["name" "queue" "outcome"]
::mdef/type :counter}
:jobs-retries
{::mdef/name "penpot_jobs_retries_total"
::mdef/help "Total number of durable jobs rescheduled for retry."
::mdef/labels ["name" "queue" "reason"]
::mdef/type :counter}
:jobs-events-total
{::mdef/name "penpot_jobs_events_total"
::mdef/help "Total number of job events stored."
::mdef/type :counter}
:jobs-orphaned
{::mdef/name "penpot_jobs_orphaned_total"
::mdef/help "Total number of running jobs marked as orphaned."
::mdef/labels ["queue"]
::mdef/type :counter}
:jobs-rescheduled
{::mdef/name "penpot_jobs_rescheduled_total"
::mdef/help "Total number of scheduled jobs recovered after transit loss."
::mdef/labels ["queue"]
::mdef/type :counter}
:jobs-queue-wait-timing
{::mdef/name "penpot_jobs_queue_wait_ms"
::mdef/help "Time from job scheduling to worker claim (milliseconds)."
::mdef/labels ["name" "queue"]
::mdef/type :histogram
::mdef/buckets [1 10 50 100 500 1000 5000 10000 30000 60000 300000 600000]}
:jobs-execution-timing
{::mdef/name "penpot_jobs_execution_ms"
::mdef/help "Time spent executing a job handler (milliseconds)."
::mdef/labels ["name" "queue"]
::mdef/type :histogram
::mdef/buckets [1 10 50 100 500 1000 5000 10000 30000 60000 300000 600000]}
:jobs-total-timing
{::mdef/name "penpot_jobs_total_ms"
::mdef/help "Time from job creation to a terminal state (milliseconds)."
::mdef/labels ["name" "queue" "outcome"]
::mdef/type :histogram
::mdef/buckets [10 50 100 500 1000 5000 10000 30000 60000 300000 600000 3600000]}
:jobs-dispatcher-timing
{::mdef/name "penpot_jobs_dispatcher_ms"
::mdef/help "Dispatcher batch processing time (milliseconds)."
::mdef/labels ["stage" "outcome"]
::mdef/type :histogram
::mdef/buckets [1 10 50 100 500 1000 5000 10000 30000 60000]}
:jobs-dispatcher-batch-size
{::mdef/name "penpot_jobs_dispatcher_batch_size"
::mdef/help "Number of jobs in a dispatcher queue batch."
::mdef/labels ["queue"]
::mdef/type :histogram
::mdef/buckets [1 5 10 25 50 100 250 500 1000]}
:jobs-backlog
{::mdef/name "penpot_jobs_backlog"
::mdef/help "Current number of jobs grouped by status."
::mdef/labels ["status"]
::mdef/type :gauge}
:jobs-oldest-pending-age
{::mdef/name "penpot_jobs_oldest_pending_age_seconds"
::mdef/help "Age in seconds of the oldest pending job."
::mdef/type :gauge}
:jobs-gc-rows
{::mdef/name "penpot_jobs_gc_rows_total"
::mdef/help "Rows removed or resources touched by the jobs garbage collector."
::mdef/labels ["kind" "action"]
::mdef/type :counter}
:jobs-gc-timing
{::mdef/name "penpot_jobs_gc_ms"
::mdef/help "Time spent in each jobs garbage collection pass (milliseconds)."
::mdef/labels ["kind"]
::mdef/type :histogram
::mdef/buckets [1 10 50 100 500 1000 5000 10000 30000 60000 300000]}
:jobs-cron-total
{::mdef/name "penpot_jobs_cron_total"
::mdef/help "Total number of cron scheduler events."
::mdef/labels ["outcome" "reason"]
::mdef/type :counter}
:jobs-requests-total
{::mdef/name "penpot_jobs_requests_total"
::mdef/help "Total number of ephemeral job request events."
::mdef/labels ["outcome"]
::mdef/type :counter}
:jobs-request-timing
{::mdef/name "penpot_jobs_request_ms"
::mdef/help "Time spent waiting for an ephemeral job reply (milliseconds)."
::mdef/labels ["outcome"]
::mdef/type :histogram
::mdef/buckets [1 10 50 100 500 1000 5000 10000 30000 60000 300000]}})
(def system-config
{::db/pool
@ -272,27 +398,12 @@
:app.storage.tmp/cleaner
{::wrk/executor (ig/ref ::wrk/executor)}
::sto.gc-deleted/handler
{::db/pool (ig/ref ::db/pool)
::sto/storage (ig/ref ::sto/storage)}
::sto.gc-touched/handler
{::db/pool (ig/ref ::db/pool)
::mtx/metrics (ig/ref ::mtx/metrics)}
::sto.pending-gc/handler
{::db/pool (ig/ref ::db/pool)
::sto/storage (ig/ref ::sto/storage)}
::http.client/client
{::wrk/executor (ig/ref ::wrk/executor)}
::session/manager
{::db/pool (ig/ref ::db/pool)}
::session.tasks/gc
{::db/pool (ig/ref ::db/pool)}
::http.awsns/routes
{::setup/props (ig/ref ::setup/props)
::db/pool (ig/ref ::db/pool)
@ -341,6 +452,7 @@
::oidc/routes
{::http.client/client (ig/ref ::http.client/client)
::jobs/defs (ig/ref ::jobs/defs)
::db/pool (ig/ref ::db/pool)
::setup/props (ig/ref ::setup/props)
::oidc/providers (ig/ref ::oidc/providers)
@ -413,6 +525,7 @@
:app.rpc/methods
{::http.client/client (ig/ref ::http.client/client)
::jobs/defs (ig/ref ::jobs/defs)
::db/pool (ig/ref ::db/pool)
::rds/pool (ig/ref ::rds/pool)
:app.nitrate/client (ig/ref :app.nitrate/client)
@ -441,10 +554,12 @@
:app.nitrate/client
{::http.client/client (ig/ref ::http.client/client)
::jobs/defs (ig/ref ::jobs/defs)
::setup/shared-keys (ig/ref ::setup/shared-keys)}
:app.rpc/management-methods
{::http.client/client (ig/ref ::http.client/client)
::jobs/defs (ig/ref ::jobs/defs)
::db/pool (ig/ref ::db/pool)
::rds/pool (ig/ref ::rds/pool)
::wrk/executor (ig/ref ::wrk/executor)
@ -466,31 +581,108 @@
::setup/props (ig/ref ::setup/props)
::setup/shared-keys (ig/ref ::setup/shared-keys)}
::wrk/registry
{::mtx/metrics (ig/ref ::mtx/metrics)
::wrk/tasks
{:sendmail (ig/ref ::email/handler)
:objects-gc (ig/ref :app.tasks.objects-gc/handler)
:file-gc (ig/ref :app.tasks.file-gc/handler)
:file-gc-scheduler (ig/ref :app.tasks.file-gc-scheduler/handler)
:offload-file-data (ig/ref :app.tasks.offload-file-data/handler)
:tasks-gc (ig/ref :app.tasks.tasks-gc/handler)
:telemetry (ig/ref :app.tasks.telemetry/handler)
:storage-gc-deleted (ig/ref ::sto.gc-deleted/handler)
:storage-gc-touched (ig/ref ::sto.gc-touched/handler)
:storage-pending-gc (ig/ref ::sto.pending-gc/handler)
:session-gc (ig/ref ::session.tasks/gc)
:audit-log-archive (ig/ref :app.loggers.audit.archive-task/handler)
:audit-log-gc (ig/ref :app.loggers.audit.gc-task/handler)
::jobs/defs
{:sendmail (ig/ref ::email/job-def)
:delete-object (ig/ref :app.tasks.delete-object/job-def)
:demo-purge (ig/ref :app.tasks.demo-purge/job-def)
:run-webhook (ig/ref ::webhooks/run-webhook-job-def)
:process-webhook-event (ig/ref ::webhooks/process-webhook-event-job-def)
:file-gc (ig/ref :app.tasks.file-gc/job-def)
:offload-file-data (ig/ref :app.tasks.offload-file-data/job-def)
:objects-gc (ig/ref :app.tasks.objects-gc/job-def)
:storage-gc-deleted (ig/ref ::sto.gc-deleted/job-def)
:storage-gc-touched (ig/ref ::sto.gc-touched/job-def)
:storage-pending-gc (ig/ref ::sto.pending-gc/job-def)
:jobs-gc (ig/ref :app.jobs.gc/job-def)
:telemetry (ig/ref :app.tasks.telemetry/job-def)
:session-gc (ig/ref ::session/job-def)
:file-gc-scheduler (ig/ref :app.tasks.file-gc-scheduler/job-def)
:audit-log-archive (ig/ref :app.loggers.audit.archive-task/job-def)
:audit-log-gc (ig/ref :app.loggers.audit.gc-task/job-def)}
:delete-object
(ig/ref :app.tasks.delete-object/handler)
:demo-purge
(ig/ref :app.tasks.demo-purge/handler)
:process-webhook-event
(ig/ref ::webhooks/process-event-handler)
:run-webhook
(ig/ref ::webhooks/run-webhook-handler)}}
::jobs/request-pool
{::rds/client (ig/ref ::rds/client)
::mtx/metrics (ig/ref ::mtx/metrics)}
:app.email/job-def
{::email/sendmail (ig/ref ::email/sendmail)
::mtx/metrics (ig/ref ::mtx/metrics)}
:app.tasks.delete-object/job-def
{::db/pool (ig/ref ::db/pool)
::sto/storage (ig/ref ::sto/storage)
::mtx/metrics (ig/ref ::mtx/metrics)}
:app.tasks.demo-purge/job-def
{::db/pool (ig/ref ::db/pool)
::mtx/metrics (ig/ref ::mtx/metrics)}
:app.loggers.webhooks/run-webhook-job-def
{::db/pool (ig/ref ::db/pool)
::http.client/client (ig/ref ::http.client/client)
::mtx/metrics (ig/ref ::mtx/metrics)}
:app.loggers.webhooks/process-webhook-event-job-def
{::db/pool (ig/ref ::db/pool)
::http.client/client (ig/ref ::http.client/client)
::mtx/metrics (ig/ref ::mtx/metrics)}
:app.tasks.file-gc/job-def
{::db/pool (ig/ref ::db/pool)
::sto/storage (ig/ref ::sto/storage)
::mtx/metrics (ig/ref ::mtx/metrics)}
:app.tasks.offload-file-data/job-def
{::db/pool (ig/ref ::db/pool)
::sto/storage (ig/ref ::sto/storage)
::mtx/metrics (ig/ref ::mtx/metrics)}
:app.tasks.objects-gc/job-def
{::db/pool (ig/ref ::db/pool)
::sto/storage (ig/ref ::sto/storage)
::mtx/metrics (ig/ref ::mtx/metrics)}
:app.storage.gc-deleted/job-def
{::db/pool (ig/ref ::db/pool)
::sto/storage (ig/ref ::sto/storage)
::mtx/metrics (ig/ref ::mtx/metrics)}
:app.storage.gc-touched/job-def
{::db/pool (ig/ref ::db/pool)
::mtx/metrics (ig/ref ::mtx/metrics)}
:app.storage.pending-gc/job-def
{::db/pool (ig/ref ::db/pool)
::sto/storage (ig/ref ::sto/storage)
::mtx/metrics (ig/ref ::mtx/metrics)}
:app.jobs.gc/job-def
{::db/pool (ig/ref ::db/pool)
::mtx/metrics (ig/ref ::mtx/metrics)}
:app.tasks.telemetry/job-def
{::db/pool (ig/ref ::db/pool)
::http.client/client (ig/ref ::http.client/client)
::setup/props (ig/ref ::setup/props)
::mtx/metrics (ig/ref ::mtx/metrics)}
::session/job-def
{::db/pool (ig/ref ::db/pool)
::mtx/metrics (ig/ref ::mtx/metrics)}
:app.tasks.file-gc-scheduler/job-def
{::db/pool (ig/ref ::db/pool)
::mtx/metrics (ig/ref ::mtx/metrics)}
:app.loggers.audit.archive-task/job-def
{::db/pool (ig/ref ::db/pool)
::http.client/client (ig/ref ::http.client/client)
::setup/shared-keys (ig/ref ::setup/shared-keys)
::mtx/metrics (ig/ref ::mtx/metrics)}
:app.loggers.audit.gc-task/job-def
{::db/pool (ig/ref ::db/pool)
::mtx/metrics (ig/ref ::mtx/metrics)}
::email/blacklist
{}
@ -508,38 +700,6 @@
::email/default-reply-to (cf/get :smtp-default-reply-to)
::email/default-from (cf/get :smtp-default-from)}
::email/handler
{::email/sendmail (ig/ref ::email/sendmail)}
:app.tasks.tasks-gc/handler
{::db/pool (ig/ref ::db/pool)}
:app.tasks.objects-gc/handler
{::db/pool (ig/ref ::db/pool)
::sto/storage (ig/ref ::sto/storage)}
:app.tasks.delete-object/handler
{::db/pool (ig/ref ::db/pool)
::sto/storage (ig/ref ::sto/storage)}
:app.tasks.demo-purge/handler
{::db/pool (ig/ref ::db/pool)}
:app.tasks.file-gc/handler
{::db/pool (ig/ref ::db/pool)
::sto/storage (ig/ref ::sto/storage)}
:app.tasks.file-gc-scheduler/handler
{::db/pool (ig/ref ::db/pool)}
:app.tasks.offload-file-data/handler
{::db/pool (ig/ref ::db/pool)
::sto/storage (ig/ref ::sto/storage)}
:app.tasks.telemetry/handler
{::db/pool (ig/ref ::db/pool)
::http.client/client (ig/ref ::http.client/client)
::setup/props (ig/ref ::setup/props)}
::srepl/urepl
{:port (cf/get :urepl-port 6062)
@ -573,23 +733,6 @@
::setup/clock
{}
:app.loggers.audit.archive-task/handler
{::setup/shared-keys (ig/ref ::setup/shared-keys)
::http.client/client (ig/ref ::http.client/client)
::db/pool (ig/ref ::db/pool)
:app.nitrate/client (ig/ref :app.nitrate/client)}
:app.loggers.audit.gc-task/handler
{::db/pool (ig/ref ::db/pool)}
::webhooks/process-event-handler
{::db/pool (ig/ref ::db/pool)
::http.client/client (ig/ref ::http.client/client)}
::webhooks/run-webhook-handler
{::db/pool (ig/ref ::db/pool)
::http.client/client (ig/ref ::http.client/client)}
:app.loggers.mattermost/reporter
{::http.client/client (ig/ref ::http.client/client)}
@ -629,42 +772,43 @@
(def worker-config
{::wrk/cron
{::wrk/registry (ig/ref ::wrk/registry)
{::jobs/defs (ig/ref ::jobs/defs)
::db/pool (ig/ref ::db/pool)
::mtx/metrics (ig/ref ::mtx/metrics)
::wrk/entries
[{:cron #penpot/cron "0 0 0 * * ?" ;; daily
:task :session-gc}
:job :session-gc}
{:cron #penpot/cron "0 0 0 * * ?" ;; daily
:task :objects-gc}
:job :objects-gc}
{:cron #penpot/cron "0 0 0 * * ?" ;; daily
:task :storage-gc-deleted}
:job :storage-gc-deleted}
{:cron #penpot/cron "0 0 0 * * ?" ;; daily
:task :storage-gc-touched}
:job :storage-gc-touched}
{:cron #penpot/cron "0 0 0 * * ?" ;; daily
:task :storage-pending-gc}
:job :storage-pending-gc}
{:cron #penpot/cron "0 0 0 * * ?" ;; daily
:task :tasks-gc}
:job :jobs-gc}
{:cron #penpot/cron "0 0 2 * * ?" ;; daily
:task :file-gc-scheduler}
:job :file-gc-scheduler}
{:cron #penpot/cron "0 30 */3,23 * * ?"
:task :telemetry}
:job :telemetry}
(when (or (contains? cf/flags :nexus)
(contains? cf/flags :admin-console))
{:cron #penpot/cron "0 */5 * * * ?" ;; every 5m
:task :audit-log-archive})
:job :audit-log-archive})
(when (or (contains? cf/flags :nexus)
(contains? cf/flags :admin-console))
{:cron #penpot/cron "30 */5 * * * ?" ;; every 5m
:task :audit-log-gc})]}
:job :audit-log-gc})]}
::wrk/dispatcher
{::rds/client (ig/ref ::rds/client)
@ -672,23 +816,39 @@
::db/pool (ig/ref ::db/pool)
::wrk/tenant (cf/get :tenant)}
::jobs-metrics/sampler
{::db/pool (ig/ref ::db/pool)
::mtx/metrics (ig/ref ::mtx/metrics)}
[::default ::wrk/runner]
{::wrk/parallelism (cf/get ::worker-default-parallelism 1)
{::wrk/parallelism (cf/get :worker-default-parallelism 1)
::wrk/queue :default
::wrk/tenant (cf/get :tenant)
::rds/client (ig/ref ::rds/client)
::wrk/registry (ig/ref ::wrk/registry)
::jobs/defs (ig/ref ::jobs/defs)
::mtx/metrics (ig/ref ::mtx/metrics)
::db/pool (ig/ref ::db/pool)}
::db/pool (ig/ref ::db/pool)
::mbus/msgbus (ig/ref ::mbus/msgbus)}
[::webhook ::wrk/runner]
{::wrk/parallelism (cf/get ::worker-webhook-parallelism 1)
{::wrk/parallelism (cf/get :worker-webhook-parallelism 1)
::wrk/queue :webhooks
::wrk/tenant (cf/get :tenant)
::rds/client (ig/ref ::rds/client)
::wrk/registry (ig/ref ::wrk/registry)
::jobs/defs (ig/ref ::jobs/defs)
::mtx/metrics (ig/ref ::mtx/metrics)
::db/pool (ig/ref ::db/pool)}})
::db/pool (ig/ref ::db/pool)
::mbus/msgbus (ig/ref ::mbus/msgbus)}
[::cron ::wrk/runner]
{::wrk/parallelism (cf/get :worker-cron-parallelism 2)
::wrk/queue :cron
::wrk/tenant (cf/get :tenant)
::rds/client (ig/ref ::rds/client)
::jobs/defs (ig/ref ::jobs/defs)
::mtx/metrics (ig/ref ::mtx/metrics)
::db/pool (ig/ref ::db/pool)
::mbus/msgbus (ig/ref ::mbus/msgbus)}})
(defn start

20
backend/src/app/metrics.clj
View File

@ -7,6 +7,7 @@
(ns app.metrics
(:refer-clojure :exclude [run!])
(:require
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.common.schema :as sm]
[app.metrics.definition :as-alias mdef]
@ -159,6 +160,25 @@
(swap! warned-hints conj hint)
(l/wrn :hint hint :cause cause))))
(defn instance
"Resolve the metrics instance from a cfg; raises when it is absent.
The shared resolver: a module that records metrics takes a cfg and
calls this, so no caller has to know where the instance lives or
capture it beforehand. That matters most inside an
`app.db/after-commit` callback, which closes over whatever it was
given and cannot read the cfg again later.
Raises on purpose. A cfg without metrics is a wiring bug, and it must
surface where the metric is recorded rather than disappear: a caller
that resolved this at the top of a write and dropped the value is
precisely the pattern this replaces."
[cfg]
(or (::metrics cfg)
(ex/raise :type :assertion
:code :missing-metrics
:hint "missing ::mtx/metrics on the provided cfg")))
(defn run!
"Record a metric.

3
backend/src/app/migrations.clj
View File

@ -507,6 +507,9 @@
{:name "0154-add-upload-session-chunk-table"
:fn (mg/resource "app/migrations/sql/0154-add-upload-session-chunk-table.sql")}
{:name "0154-add-job-table"
:fn (mg/resource "app/migrations/sql/0154-add-job-table.sql")}
{:name "0155-normalize-storage-object-metadata"
:fn (mg/resource "app/migrations/sql/0155-normalize-storage-object-metadata.sql")}

150
backend/src/app/migrations/sql/0154-add-job-table.sql Normal file
View File

@ -0,0 +1,150 @@
-- Migration: Add unified `job` table.
--
-- A single row per unit of work, replacing the generic `task` table as the
-- durable substrate for backend jobs. Columns combine the dispatch/lifecycle
-- fields of `task` with optional user-facing ledger fields (borrowed from the
-- planned export_job/import_job tables, which this migration supersedes).
--
-- Job kinds are identified by `name` (the job-def registry key); user jobs are
-- marked by `profile_id IS NOT NULL` and expirable jobs by `expires_at IS NOT
-- NULL`. There is no `modified_at` trigger: the application code updates it on
-- every UPDATE (used for the unified lease/orphan detection).
--
-- `params` carries the business payload (plain JSON) of the job. Progress is
-- not a column: it is an append-only `job_event` row, so a job keeps its whole
-- progress history instead of only the last value.
--
-- `tenant` is the instance the job belongs to and `queue` is its bare queue
-- name. They are separate columns because several instances can share one
-- database and the tenant is what keeps them from claiming each other's work:
-- as an equality the filter is something an index can serve, where a
-- `<tenant>:<queue>` prefix could only be matched with a LIKE over text. Every
-- query that acts on one instance's work (dispatch, orphan sweep, reschedule,
-- cron no-overlap check, submit dedupe) filters on `tenant` for that reason.
-- The prefix still exists, but only in the Redis key the queue's payloads
-- travel through, composed in one place by `app.worker/queue-key`.
--
-- The legacy `task` table stays in place (dormant) on purpose until the
-- next version, so PRE (legacy) and HOURLY (jobs) can run in parallel on
-- the same database and the deploy can roll back. During that window
-- each table is cleaned by its own version: `task` rows by the parallel
-- legacy `tasks-gc`, `job` rows by the new `:jobs-gc`.
CREATE TABLE job (
id uuid PRIMARY KEY DEFAULT gen_random_uuid(),
name text NOT NULL,
tenant text NOT NULL,
queue text NOT NULL,
label text,
priority int NOT NULL DEFAULT 100,
scheduled_at timestamptz NOT NULL DEFAULT now(),
retry_num int NOT NULL DEFAULT 0,
max_retries int NOT NULL DEFAULT 3,
status text NOT NULL DEFAULT 'new'
CHECK (status IN ('new', 'scheduled', 'running', 'retry',
'completed', 'failed', 'cancelled',
'aborted')),
created_at timestamptz NOT NULL DEFAULT now(),
modified_at timestamptz NOT NULL DEFAULT now(),
started_at timestamptz,
completed_at timestamptz,
params jsonb NOT NULL DEFAULT '{}',
-- optional ledger columns (user-facing jobs)
profile_id uuid NULL REFERENCES profile(id) ON DELETE NO ACTION DEFERRABLE,
error jsonb,
result jsonb,
resource_id uuid NULL REFERENCES storage_object(id) ON DELETE SET NULL DEFERRABLE,
expires_at timestamptz
);
-- Dispatcher claim index: the worker selects due `new`/`retry` rows of
-- its own tenant, orders them by priority and scheduled time, and locks
-- the batch with SKIP LOCKED. The partial predicate keeps terminal rows
-- out and `status` needs no key column for that reason; `tenant` leads
-- because it is an equality the index can answer, and the leading
-- columns then carry the ORDER BY unchanged. `queue` does not lead: the
-- dispatcher claims every queue of its tenant and groups them when
-- pushing, so filtering on one queue would be wrong.
CREATE INDEX job__dispatcher__idx
ON job (tenant, priority DESC, scheduled_at)
WHERE status IN ('new', 'retry');
-- Dispatcher orphan sweep: the worker finds the `running` rows of its
-- own tenant whose modified_at is older than the lease and marks them
-- `aborted` (system-side terminal, never retried).
CREATE INDEX job__orphan__idx
ON job (tenant, modified_at)
WHERE status = 'running';
-- User-facing job ledger index: it supports filtering by profile and
-- ordering a user's jobs by newest first. No current production query
-- uses it yet; it is kept for the user-facing ledger path.
CREATE INDEX job__profile__idx
ON job (profile_id, created_at DESC)
WHERE profile_id IS NOT NULL;
-- Cron no-overlap check and submit dedupe: both look for jobs of one
-- tenant with the same name and queue and label that have not started
-- yet, so one index serves the two queries.
CREATE INDEX job__name_label__idx
ON job (tenant, name, queue, label)
WHERE status IN ('new', 'scheduled', 'running', 'retry');
-- Storage GC reference check: it answers whether any job still points
-- to a candidate storage object. Rows without a resource are excluded.
CREATE INDEX job__resource__idx
ON job (resource_id)
WHERE resource_id IS NOT NULL;
-- Dispatcher recovery: it finds the `scheduled` jobs of its own tenant
-- that were pushed to Redis but not claimed within the recovery window.
CREATE INDEX job__scheduled__idx
ON job (tenant, scheduled_at)
WHERE status = 'scheduled';
-- Jobs GC expiration: it scans jobs past expires_at while excluding
-- running and retry jobs from the expiration delete.
CREATE INDEX job__expires__idx
ON job (expires_at)
WHERE expires_at IS NOT NULL;
-- Jobs GC retention: it finds old internal terminal jobs with no
-- profile, which are eligible for removal after the retention delay.
CREATE INDEX job__retention__idx
ON job (modified_at)
WHERE status IN ('completed', 'failed', 'cancelled', 'aborted')
AND profile_id IS NULL;
-- Append-only job event log: `start`, `progress`, `retry` and `end` rows in
-- insertion order. This is the only source of truth for progress; there is no
-- Redis key and no mutable progress column. The foreign key cascades so
-- deleting a job removes its whole history, and it is DEFERRABLE like every
-- other new reference of the substrate.
CREATE TABLE job_event (
id bigserial PRIMARY KEY,
job_id uuid NOT NULL REFERENCES job(id) ON DELETE CASCADE DEFERRABLE,
kind text NOT NULL
CHECK (kind IN ('start', 'progress', 'retry', 'end')),
payload jsonb NOT NULL DEFAULT '{}',
created_at timestamptz NOT NULL DEFAULT now()
);
-- Event history read: all events of a job, and the last progress report
-- (`WHERE job_id = ? AND kind = 'progress' ORDER BY created_at DESC LIMIT 1`).
CREATE INDEX job_event__job_kind_created_idx
ON job_event (job_id, kind, created_at DESC, id DESC);
-- Deletion protection, like the domain tables (`team`, `profile`, the
-- file thumbnail tables). The only intended deleter of `job` rows is the
-- jobs GC, which also marks the referenced storage objects as touched in
-- the same transaction; a stray `DELETE FROM job` would drop the row
-- (and cascade `job_event`) without touching the object, orphaning it
-- forever. The GC and the submit dedupe disable the guard inside their
-- transaction with `SET LOCAL rules.deletion_protection TO off`, the
-- same escape hatch used by `app.tasks.objects-gc`.
CREATE OR REPLACE TRIGGER deletion_protection__tgr
BEFORE DELETE ON job FOR EACH STATEMENT
WHEN ((current_setting('rules.deletion_protection', true) IN ('on', '')) OR
(current_setting('rules.deletion_protection', true) IS NULL))
EXECUTE PROCEDURE raise_deletion_protection();

19
backend/src/app/nitrate.clj
View File

@ -17,7 +17,6 @@
[app.common.time :as ct]
[app.common.types.organization :as cto
:refer [schema:nitrate-sso]]
[app.common.uri :as u]
[app.config :as cf]
[app.http.client :as http]
[app.http.session :as session]
@ -32,31 +31,17 @@
;; HELPERS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- join-path-segments
"Build a single relative path from Nitrate URI segments, normalizing slashes."
[segments]
(let [path (->> segments (map str) (str/join "/"))]
(->> (str/split path #"/")
(remove str/blank?)
(str/join "/"))))
(defn- join-base-uri
"Join path segments to a base URI."
[base-uri & segments]
(u/join (u/ensure-path-slash base-uri)
(join-path-segments segments)))
(defn- generate-nitrate-uri
"Joins relative path segments to the Nitrate backend URI.
Segments must not start with `/`"
[& segments]
(apply join-base-uri (cf/get :admin-console-uri) segments))
(apply cf/join-uri (cf/get :admin-console-uri) segments))
(defn- generate-public-uri
"Joins relative path segments to the public backend URI.
Segments must not start with `/`"
[& segments]
(apply join-base-uri (cf/get :public-uri) segments))
(apply cf/get-public-uri segments))
(defn- request-builder
[cfg method uri shared-key profile-id request-params]

10
backend/src/app/redis.clj
View File

@ -78,6 +78,7 @@
(-hget [_ key field])
(-set [_ key val args])
(-del [_ key-or-keys])
(-expire [_ key seconds])
(-ping [_]))
(defprotocol IPubSubConnection
@ -234,6 +235,10 @@
(let [keys (into-array String keys)]
(.del cmd ^String/1 keys)))
(-expire [_ key seconds]
(assert (string? key) "key expected to be string")
(.expire cmd ^String key ^long seconds))
(-ping [_]
(.ping cmd))
@ -511,6 +516,11 @@
[cause]
(instance? RedisCommandTimeoutException cause))
(defn expire
[conn key seconds]
(assert (string? key) "key must be string instance")
(-expire conn key seconds))
(defn exception?
[cause]
(instance? RedisException cause))

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

@ -13,7 +13,6 @@
[app.common.schema :as sm]
[app.common.spec :as us]
[app.common.time :as ct]
[app.common.uri :as u]
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
@ -426,7 +425,8 @@
(defn- resolve-management-methods
[cfg]
(let [cfg (assoc cfg ::module "management" ::type "command" ::metrics-id :rpc-management-timing)
mods (cond->> (list 'app.rpc.management.exporter)
mods (cond->> (list 'app.rpc.management.exporter
'app.rpc.management.jobs)
(contains? cf/flags :admin-console)
(cons 'app.rpc.management.nitrate))]
@ -482,42 +482,40 @@
(defmethod ig/init-key ::routes
[_ {:keys [::methods ::management-methods ::setup/shared-keys] :as cfg}]
["/api"
["/management"
["/methods/:method-name"
{:middleware [[mw/shared-key-auth shared-keys]
[session/authz cfg]]
:handler (make-rpc-handler management-methods)}]
(let [public-uri (cf/get :public-uri)]
["/api"
["/management"
["/methods/:method-name"
{:middleware [[mw/shared-key-auth shared-keys]
[session/authz cfg]]
:handler (make-rpc-handler management-methods)}]
(doc/routes :methods management-methods
:label "management"
:base-uri (cf/get-public-uri "api/management")
:description "MANAGEMENT API")]
(doc/routes :methods management-methods
:label "management"
:base-uri (u/join public-uri "/api/management")
:description "MANAGEMENT API")]
["/main"
["/methods/:method-name"
{:middleware [[mw/cors]
[sec/client-header-check]
[session/authz cfg]
[actoken/authz cfg]]
:handler (make-rpc-handler methods)}]
["/main"
["/methods/:method-name"
{:middleware [[mw/cors]
[sec/client-header-check]
[session/authz cfg]
[actoken/authz cfg]]
:handler (make-rpc-handler methods)}]
(doc/routes :methods methods
:label "main"
:base-uri (cf/get-public-uri "api/main")
:description "MAIN API")]
(doc/routes :methods methods
:label "main"
:base-uri (u/join public-uri "/api/main")
:description "MAIN API")]
;; BACKWARD COMPATIBILITY
["/_doc" {:handler (redirect (cf/get-public-uri "api/main/doc"))}]
["/doc" {:handler (redirect (cf/get-public-uri "api/main/doc"))}]
["/openapi" {:handler (redirect (cf/get-public-uri "api/main/doc/openapi"))}]
["/openapi.join" {:handler (redirect (cf/get-public-uri "api/main/doc/openapi.json"))}]
;; BACKWARD COMPATIBILITY
["/_doc" {:handler (redirect (u/join public-uri "/api/main/doc"))}]
["/doc" {:handler (redirect (u/join public-uri "/api/main/doc"))}]
["/openapi" {:handler (redirect (u/join public-uri "/api/main/doc/openapi"))}]
["/openapi.join" {:handler (redirect (u/join public-uri "/api/main/doc/openapi.json"))}]
["/rpc/command/:method-name"
{:middleware [[mw/cors]
[sec/client-header-check]
[session/authz cfg]
[actoken/authz cfg]]
:handler (make-rpc-handler methods)}]]))
["/rpc/command/:method-name"
{:middleware [[mw/cors]
[sec/client-header-check]
[session/authz cfg]
[actoken/authz cfg]]
:handler (make-rpc-handler methods)}]])

44
backend/src/app/rpc/commands/auth.clj
View File

@ -202,11 +202,11 @@
(update-password conn))]
(when profile
(login-lockout/clear-attempts! cfg (:id profile))
(eml/send! {::eml/conn conn
::eml/factory eml/password-changed
:public-uri (cf/get :public-uri)
:to (:email profile)
:name (:fullname profile)})))
(eml/send cfg {::eml/reuse-conn true
::eml/factory eml/password-changed
:public-uri (cf/get :public-uri)
:to (:email profile)
:name (:fullname profile)})))
nil))
@ -467,7 +467,7 @@
(defn send-email-verification!
([cfg profile] (send-email-verification! cfg profile nil))
([{:keys [::db/conn] :as cfg} profile invitation-token]
([cfg profile invitation-token]
(let [vclaims (cond-> {:iss :verify-email
:exp (ct/in-future "72h")
:profile-id (:id profile)
@ -485,13 +485,13 @@
{:iss :profile-identity
:profile-id (:id profile)
:exp (ct/in-future {:days 30})})]
(eml/send! {::eml/conn conn
::eml/factory eml/register
:public-uri (cf/get :public-uri)
:to (:email profile)
:name (:fullname profile)
:token vtoken
:extra-data ptoken}))))
(eml/send cfg {::eml/reuse-conn true
::eml/factory eml/register
:public-uri (cf/get :public-uri)
:to (:email profile)
:name (:fullname profile)
:token vtoken
:extra-data ptoken}))))
(defn register-profile
[{:keys [::db/conn] :as cfg} {:keys [token] :as params}]
@ -649,18 +649,18 @@
:profile-id id})]
(assoc profile :token token)))
(send-email-notification [conn profile]
(send-email-notification [profile]
(let [ptoken (tokens/generate cfg
{:iss :profile-identity
:profile-id (:id profile)
:exp (ct/in-future {:days 30})})]
(eml/send! {::eml/conn conn
::eml/factory eml/password-recovery
:public-uri (cf/get :public-uri)
:to (:email profile)
:token (:token profile)
:name (:fullname profile)
:extra-data ptoken})
(eml/send cfg {::eml/reuse-conn true
::eml/factory eml/password-recovery
:public-uri (cf/get :public-uri)
:to (:email profile)
:token (:token profile)
:name (:fullname profile)
:extra-data ptoken})
nil))]
(let [profile (->> (profile/clean-email email)
@ -698,7 +698,7 @@
{:id (:id profile)})
(->> profile
(create-recovery-token)
(send-email-notification conn)))))))
(send-email-notification)))))))
(def schema:request-profile-recovery
[:map {:title "request-profile-recovery"}

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

@ -83,7 +83,7 @@
(not= :none (-> props :notifications :email-comments)))
(defn send-comment-emails!
[conn profile comment thread file]
[{:keys [::db/conn] :as cfg} profile comment thread file]
(let [team-users (get-team-users conn (:team-id file))
comment-reference (format-comment-ref thread file)
comment-content (format-comment comment)
@ -113,8 +113,9 @@
(doseq [mention comment-mentions]
(let [{:keys [fullname email props]} (get team-users mention)]
(when (mention-email? props)
(eml/send!
{::eml/conn conn
(eml/send
cfg
{::eml/reuse-conn true
::eml/factory eml/comment-mention
:public-uri (cf/get :public-uri)
:to email
@ -128,8 +129,9 @@
(doseq [mention thread-mentions]
(let [{:keys [fullname email props]} (get team-users mention)]
(when (mention-email? props)
(eml/send!
{::eml/conn conn
(eml/send
cfg
{::eml/reuse-conn true
::eml/factory eml/comment-thread
:public-uri (cf/get :public-uri)
:to email
@ -143,8 +145,9 @@
(doseq [user-id notificate-users-ids]
(let [{:keys [id fullname email props]} (get team-users user-id)]
(when (notification-email? id (:owner-id thread) props)
(eml/send!
{::eml/conn conn
(eml/send
cfg
{::eml/reuse-conn true
::eml/factory eml/comment-notification
:public-uri (cf/get :public-uri)
:to email
@ -538,7 +541,7 @@
(update-thread-seqn conn file-id seqn)
;; Send mentions emails
(send-comment-emails! conn profile comment thread file)
(send-comment-emails! cfg profile comment thread file)
(-> thread
(add-owner profile)
@ -648,7 +651,7 @@
;; Update the current profile status in relation to the current thread
(upsert-comment-thread-status! conn profile-id thread-id)
(send-comment-emails! conn profile comment thread file)
(send-comment-emails! cfg profile comment thread file)
(vary-meta comment assoc ::audit/props comment))))

10
backend/src/app/rpc/commands/demo.clj
View File

@ -14,12 +14,12 @@
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
[app.jobs :as jobs]
[app.loggers.audit :as audit]
[app.rpc :as-alias rpc]
[app.rpc.commands.auth :as auth]
[app.rpc.doc :as-alias doc]
[app.util.services :as sv]
[app.worker :as wrk]
[buddy.core.codecs :as bc]
[buddy.core.nonce :as bn]))
@ -101,10 +101,10 @@
(->> (auth/create-profile cfg params)
(auth/create-profile-rels cfg))))]
(wrk/submit! (-> cfg
(assoc ::wrk/task :demo-purge)
(assoc ::wrk/delay deletion-delay)
(assoc ::wrk/params {:profile-id (:id profile)})))
(jobs/submit cfg
{::jobs/name :demo-purge
::jobs/delay deletion-delay
::jobs/params {:profile-id (:id profile)}})
(with-meta {:email email
:password password}

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

@ -32,20 +32,22 @@
(sv/defmethod ::send-user-feedback
{::climit/id [[:send-user-feedback/by-profile ::rpc/profile-id]
[:send-user-feedback/global]]
::db/transaction true
::doc/added "1.18"
::sm/params schema:send-user-feedback}
[{:keys [::db/pool]} {:keys [::rpc/profile-id] :as params}]
[cfg {:keys [::rpc/profile-id] :as params}]
(when-not (contains? cf/flags :user-feedback)
(ex/raise :type :restriction
:code :feedback-disabled
:hint "feedback not enabled"))
(let [profile (profile/get-profile pool profile-id)]
(send-user-feedback! pool profile params)
(let [pool (::db/pool cfg)
profile (profile/get-profile pool profile-id)]
(send-user-feedback! cfg profile params)
nil))
(defn- send-user-feedback!
[pool profile params]
[cfg profile params]
(let [destination
(or (cf/get :user-feedback-destination)
;; LEGACY
@ -55,16 +57,16 @@
(d/without-nils
{"error-report.txt" (:error-report params)})]
(eml/send! {::eml/conn pool
::eml/factory eml/user-feedback
:to destination
:reply-to (:email profile)
:email (:email profile)
:attachments attachments
(eml/send cfg {::eml/reuse-conn true
::eml/factory eml/user-feedback
:to destination
:reply-to (:email profile)
:email (:email profile)
:attachments attachments
:feedback-subject (:subject params)
:feedback-type (:type params "not-specified")
:feedback-content (:content params)
:feedback-error-href (:error-href params)
:profile profile})
:feedback-subject (:subject params)
:feedback-type (:type params "not-specified")
:feedback-content (:content params)
:feedback-error-href (:error-href params)
:profile profile})
nil))

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

@ -30,6 +30,7 @@
[app.features.fdata :as feat.fdata]
[app.features.logical-deletion :as ldel]
[app.http.sse :as sse]
[app.jobs :as jobs]
[app.loggers.audit :as-alias audit]
[app.loggers.webhooks :as-alias webhooks]
[app.msgbus :as mbus]
@ -45,7 +46,6 @@
[app.util.events :as events]
[app.util.pointer-map :as pmap]
[app.util.services :as sv]
[app.worker :as wrk]
[cuerdas.core :as str]))
;; --- FEATURES
@ -1055,7 +1055,7 @@
;; --- MUTATION COMMAND: delete-file
(defn- mark-file-deleted
[conn team file-id]
[{:keys [::db/conn] :as cfg} team file-id]
(let [delay (ldel/get-deletion-delay team)
file (db/update! conn :file
{:deleted-at (ct/in-future delay)}
@ -1067,11 +1067,11 @@
(db/delete! conn :file-library-rel
{:library-file-id file-id})
(wrk/submit! {::db/conn conn
::wrk/task :delete-object
::wrk/params {:object :file
:deleted-at (:deleted-at file)
:id file-id}})
(jobs/submit cfg
{::jobs/name :delete-object
::jobs/params {:object :file
:deleted-at (:deleted-at file)
:id file-id}})
file))
(def ^:private
@ -1085,7 +1085,7 @@
(let [team (teams/get-team conn
:profile-id profile-id
:file-id id)
file (mark-file-deleted conn team id)
file (mark-file-deleted cfg team id)
msgbus (::mbus/msgbus cfg)]
(mbus/pub! msgbus
@ -1265,7 +1265,7 @@
[:ids [::sm/set ::sm/uuid]]])
(defn- permanently-delete-team-files
[{:keys [::db/conn]} {:keys [::rpc/request-at team-id ids]}]
[{:keys [::db/conn] :as cfg} {:keys [::rpc/request-at team-id ids]}]
(let [ids (into #{}
d/xf:map-id
(db/exec! conn [sql:get-delete-team-files-candidates team-id
@ -1277,11 +1277,11 @@
{:deleted-at request-at}
{:id id}
{::db/return-keys false})
(wrk/submit! {::db/conn conn
::wrk/task :delete-object
::wrk/params {:object :file
:deleted-at request-at
:id id}})
(jobs/submit cfg
{::jobs/name :delete-object
::jobs/params {:object :file
:deleted-at request-at
:id id}})
(conj acc id))
#{}
ids)))

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

@ -171,7 +171,7 @@
{::doc/added "1.20"
::sm/params schema:remove-file-snapshot
::db/transaction true}
[{:keys [::db/conn]} {:keys [::rpc/profile-id id]}]
[{:keys [::db/conn] :as cfg} {:keys [::rpc/profile-id id]}]
(let [snapshot (fsnap/get-minimal-snapshot conn id)]
(files/check-edition-permissions! conn profile-id (:file-id snapshot))
@ -194,7 +194,7 @@
:profile-id profile-id
:file-id (:file-id snapshot))
delay (ldel/get-deletion-delay team)]
(fsnap/delete! conn (assoc snapshot :deleted-at (ct/in-future delay))))))
(fsnap/delete! cfg (assoc snapshot :deleted-at (ct/in-future delay))))))
;;; Lock/unlock version endpoints

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

@ -20,6 +20,7 @@
[app.db.sql :as-alias sql]
[app.email :as eml]
[app.http.session :as session]
[app.jobs :as jobs]
[app.loggers.audit :as audit]
[app.main :as-alias main]
[app.media :as media]
@ -33,7 +34,6 @@
[app.storage :as sto]
[app.tokens :as tokens]
[app.util.services :as sv]
[app.worker :as wrk]
[cuerdas.core :as str]))
(declare check-profile-existence!)
@ -225,11 +225,11 @@
(update-profile-password! cfg (assoc profile :password password))
(eml/send! {::eml/conn (::db/conn cfg)
::eml/factory eml/password-changed
:public-uri (cf/get :public-uri)
:to (:email profile)
:name (:fullname profile)})
(eml/send cfg {::eml/reuse-conn true
::eml/factory eml/password-changed
:public-uri (cf/get :public-uri)
:to (:email profile)
:name (:fullname profile)})
(->> (rph/get-request params)
(session/get-session)
@ -460,14 +460,14 @@
:email (:email profile)
:hint "looks like the email has spam complaint reports"))
(eml/send! {::eml/conn conn
::eml/factory eml/change-email
:public-uri (cf/get :public-uri)
:to (:email profile)
:name (:fullname profile)
:pending-email email
:token token
:extra-data ptoken})
(eml/send cfg {::eml/reuse-conn true
::eml/factory eml/change-email
:public-uri (cf/get :public-uri)
:to (:email profile)
:name (:fullname profile)
:pending-email email
:token token
:extra-data ptoken})
nil))
;; --- MUTATION: Update Profile Props
@ -570,11 +570,11 @@
{:profile-id profile-id}))
;; Schedule cascade deletion to a worker
(wrk/submit! {::db/conn conn
::wrk/task :delete-object
::wrk/params {:object :profile
:deleted-at deleted-at
:id profile-id}})
(jobs/submit cfg
{::jobs/name :delete-object
::jobs/params {:object :profile
:deleted-at deleted-at
:id profile-id}})
;; Invalidate all sessions for this profile to ensure immediate
;; access revocation across all devices

20
backend/src/app/rpc/commands/projects.clj
View File

@ -15,6 +15,7 @@
[app.db :as db]
[app.db.sql :as-alias sql]
[app.features.logical-deletion :as ldel]
[app.jobs :as jobs]
[app.loggers.audit :as-alias audit]
[app.loggers.webhooks :as webhooks]
[app.rpc :as-alias rpc]
@ -23,8 +24,7 @@
[app.rpc.helpers :as rph]
[app.rpc.permissions :as perms]
[app.rpc.quotes :as quotes]
[app.util.services :as sv]
[app.worker :as wrk]))
[app.util.services :as sv]))
;; --- Check Project Permissions
@ -272,7 +272,7 @@
;; --- MUTATION: Delete Project
(defn- delete-project
[conn team project-id]
[{:keys [::db/conn] :as cfg} team project-id]
(let [delay (ldel/get-deletion-delay team)
project (db/update! conn :project
{:deleted-at (ct/in-future delay)}
@ -284,11 +284,11 @@
:code :non-deletable-project
:hint "impossible to delete default project"))
(wrk/submit! {::db/conn conn
::wrk/task :delete-object
::wrk/params {:object :project
:deleted-at (:deleted-at project)
:id project-id}})
(jobs/submit cfg
{::jobs/name :delete-object
::jobs/params {:object :project
:deleted-at (:deleted-at project)
:id project-id}})
project))
@ -302,12 +302,12 @@
::sm/params schema:delete-project
::webhooks/event? true
::db/transaction true}
[{:keys [::db/conn]} {:keys [::rpc/profile-id id] :as params}]
[{:keys [::db/conn] :as cfg} {:keys [::rpc/profile-id id] :as params}]
(check-edition-permissions! conn profile-id id)
(let [team (teams/get-team conn
:profile-id profile-id
:project-id id)
project (delete-project conn team id)]
project (delete-project cfg team id)]
(rph/with-meta (rph/wrap)
{::audit/props {:team-id (:team-id project)
:name (:name project)

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

@ -20,6 +20,7 @@
[app.db.sql :as sql]
[app.email :as eml]
[app.features.logical-deletion :as ldel]
[app.jobs :as jobs]
[app.loggers.audit :as audit]
[app.main :as-alias main]
[app.media.validation :as media.v]
@ -33,7 +34,6 @@
[app.setup :as-alias setup]
[app.storage :as sto]
[app.util.services :as sv]
[app.worker :as wrk]
[clojure.set :as set]))
;; --- Helpers & Specs
@ -848,11 +848,11 @@
(when (contains? cf/flags :admin-console)
(nitrate/call cfg :delete-team {:profile-id profile-id :team-id team-id}))
(wrk/submit! {::db/conn conn
::wrk/task :delete-object
::wrk/params {:object :team
:deleted-at (:deleted-at team)
:id team-id}})
(jobs/submit cfg
{::jobs/name :delete-object
::jobs/params {:object :team
:deleted-at (:deleted-at team)
:id team-id}})
team)))
(def ^:private schema:delete-team

72
backend/src/app/rpc/commands/teams_invitations.clj
View File

@ -288,24 +288,24 @@
(not recent?))
(if organization
(when (contains? cf/flags :admin-console)
(eml/send! {::eml/conn conn
::eml/factory eml/invite-to-organization
:public-uri (cf/get :public-uri)
:to email
:invited-by (:fullname profile)
:user-name (:fullname member)
:organization organization
:token itoken
:extra-data ptoken}))
(eml/send! {::eml/conn conn
::eml/factory eml/invite-to-team
:public-uri (cf/get :public-uri)
:to email
:invited-by (:fullname profile)
:team (:name team)
:organization (:organization team)
:token itoken
:extra-data ptoken})))
(eml/send cfg {::eml/reuse-conn true
::eml/factory eml/invite-to-organization
:public-uri (cf/get :public-uri)
:to email
:invited-by (:fullname profile)
:user-name (:fullname member)
:organization organization
:token itoken
:extra-data ptoken}))
(eml/send cfg {::eml/reuse-conn true
::eml/factory eml/invite-to-team
:public-uri (cf/get :public-uri)
:to email
:invited-by (:fullname profile)
:team (:name team)
:organization (:organization team)
:token itoken
:extra-data ptoken})))
itoken)))))
@ -350,13 +350,13 @@
(db/delete! conn :team-invitation
{:team-id team-id :email-to (:email member)})
(eml/send! {::eml/conn conn
::eml/factory eml/join-team
:public-uri (cf/get :public-uri)
:to (:email member)
:invited-by (:fullname profile)
:team (:name team)
:team-id (:id team)})))
(eml/send cfg {::eml/reuse-conn true
::eml/factory eml/join-team
:public-uri (cf/get :public-uri)
:to (:email member)
:invited-by (:fullname profile)
:team (:name team)
:team-id (:id team)})))
(def ^:private sql:valid-access-request-profiles
"SELECT p.id, p.email, p.is_blocked
@ -814,17 +814,17 @@
:else
eml/request-team-access)]
(eml/send! {::eml/conn conn
::eml/factory factory
:public-uri (cf/get :public-uri)
:to (:email team-owner)
:requested-by (:fullname requester)
:requested-by-email (:email requester)
:team-name (:name team)
:team-id team-id
:file-name (:name file)
:file-id file-id
:page-id (:page-id file)})
(eml/send cfg {::eml/reuse-conn true
::eml/factory factory
:public-uri (cf/get :public-uri)
:to (:email team-owner)
:requested-by (:fullname requester)
:requested-by-email (:email requester)
:team-name (:name team)
:team-id team-id
:file-name (:name file)
:file-id file-id
:page-id (:page-id file)})
(with-meta {:request request}
{::audit/props {:request 1}}))))

140
backend/src/app/rpc/management/jobs.clj Normal file
View File

@ -0,0 +1,140 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS INC
(ns app.rpc.management.jobs
"Generic job management API for external workers (media and future
subsystems). External workers never touch the database: this API is
the ledger. The methods are family-agnostic (they operate on any row
of the `job` table) and use the plain JSON schemas of `app.jobs`.
Auth: every method declares ::rpc/auth false because these endpoints
do not require a profile. Actual authentication is enforced by the
management route resolver (resolve-management-methods in app.rpc),
which mandates a valid shared-key before dispatching to these methods.
If the route resolver changes, these methods must be updated accordingly."
(:require
[app.common.schema :as sm]
[app.common.time :as ct]
[app.jobs :as jobs]
[app.rpc :as-alias rpc]
[app.rpc.doc :as doc]
[app.util.services :as sv]))
;; ---- RPC METHOD: CLAIM-JOB
(def ^:private schema:claim-job-params
[:map {:title "claim-job-params"}
[:job-id ::sm/uuid]
[:scheduled-at ::ct/inst]])
(def ^:private schema:claim-job-result
[:map {:title "claim-job-result"}
[:action [:enum :run :skip]]
[:name {:optional true} ::sm/text]
;; Opaque per-job params blob; intentionally untyped.
[:params {:optional true} :any]])
(sv/defmethod ::claim-job
{::doc/added "2.20"
::sm/params schema:claim-job-params
::sm/result schema:claim-job-result
::rpc/auth false} ;; shared-key enforced by route resolver
[cfg {:keys [job-id scheduled-at]}]
(let [row (jobs/get-job cfg job-id)]
;; Race condition: if the job is claimed between get-job and claim! by
;; another worker, claim! returns 0 and we return :skip. The conditional
;; claim (UPDATE ... WHERE status IN ('new','scheduled','retry') AND
;; scheduled_at=?) handles this correctly: only a pending row with an
;; exact scheduled-at match is claimed, a stale payload is skipped.
(if (and row (pos? (jobs/claim cfg job-id scheduled-at)))
{:action :run
:name (:name row)
:params (:params row)}
{:action :skip})))
;; ---- RPC METHOD: REPORT-JOB-PROGRESS
(def ^:private schema:report-job-progress-params
[:map {:title "report-job-progress-params"}
;; The progress schema is the same one the jobs substrate validates:
;; `current` is mandatory, `total` and `stage` are optional, and no
;; other key is accepted.
[:job-id ::sm/uuid]
[:progress jobs/schema:progress]])
(def ^:private schema:report-job-progress-result
[:map {:title "report-job-progress-result"}
[:action [:enum :run :skip]]])
(sv/defmethod ::report-job-progress
{::doc/added "2.20"
::sm/params schema:report-job-progress-params
::sm/result schema:report-job-progress-result
::rpc/auth false} ;; shared-key enforced by route resolver
[cfg {:keys [job-id progress]}]
;; A lost race (row already terminal) reports :skip so the worker
;; stops retrying a report that can never land, mirroring claim-job.
;; The forced route propagates database errors: the external worker
;; must be able to retry a report it was not sure about.
(if (pos? (jobs/heartbeat cfg
:job-id job-id
:progress progress
::jobs/force? true))
{:action :run}
{:action :skip}))
;; ---- RPC METHOD: COMPLETE-JOB
(def ^:private schema:complete-job-params
[:map {:title "complete-job-params"}
[:job-id ::sm/uuid]
;; Per-job result: any JSON-encodable value, nil when the job returns
;; nothing. Nested maps and vectors are allowed; unserializable
;; values are dropped to nil by jobs/encode-result with a warning.
[:result [:maybe :any]]
;; Storage object the worker produced for this job. A resource is only
;; set, never replaced: a job that already has one is rejected.
[:resource-id {:optional true} ::sm/uuid]])
(def ^:private schema:complete-job-result
[:map {:title "complete-job-result"}
[:action [:enum :run :skip]]])
(sv/defmethod ::complete-job
{::doc/added "2.20"
::sm/params schema:complete-job-params
::sm/result schema:complete-job-result
::rpc/auth false} ;; shared-key enforced by route resolver
[cfg {:keys [job-id result resource-id]}]
(if (pos? (jobs/complete cfg
:job-id job-id
:result result
:resource-id resource-id))
{:action :run}
{:action :skip}))
;; ---- RPC METHOD: FAIL-JOB
(def ^:private schema:fail-job-params
[:map {:title "fail-job-params"}
[:job-id ::sm/uuid]
;; Rich error report: type/code/hint are required, the map stays
;; open to worker-defined details (see jobs/fail).
[:error jobs/schema:job-error]])
(def ^:private schema:fail-job-result
[:map {:title "fail-job-result"}
[:action [:enum :run :skip]]])
(sv/defmethod ::fail-job
{::doc/added "2.20"
::sm/params schema:fail-job-params
::sm/result schema:fail-job-result
::rpc/auth false} ;; shared-key enforced by route resolver
[cfg {:keys [job-id error]}]
(if (pos? (jobs/fail cfg job-id error))
{:action :run}
{:action :skip}))

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

@ -25,6 +25,7 @@
[app.email :as eml]
[app.http :as-alias http]
[app.http.session :as session]
[app.jobs :as jobs]
[app.loggers.audit :as audit]
[app.media.validation :as media.v]
[app.nitrate :as nitrate]
@ -42,7 +43,6 @@
[app.storage :as sto]
[app.util.services :as sv]
[app.util.ssrf :as ssrf]
[app.worker :as wrk]
[cuerdas.core :as str]))
@ -381,11 +381,11 @@ RETURNING id, deleted_at;")
deleted-at
(db/create-array conn "uuid" team-ids)])]
(doseq [{:keys [id deleted-at]} updated]
(wrk/submit! {::db/conn conn
::wrk/task :delete-object
::wrk/params {:object :team
:deleted-at deleted-at
:id id}}))))
(jobs/submit cfg
{::jobs/name :delete-object
::jobs/params {:object :team
:deleted-at deleted-at
:id id}}))))
nil)
(defn manage-deleted-organization-teams
@ -798,15 +798,15 @@ RETURNING id, deleted_at;")
user-name (if (nil? user-name)
(:fullname (profile/get-profile cfg profile-id))
(str/trim user-name))]
(db/tx-run! cfg (fn [{:keys [::db/conn]}]
(eml/send! {::eml/conn conn
::eml/factory eml/renewal-notice
:public-uri (cf/get :public-uri)
:to user-email
:user-name user-name
:renewal-date renewal-date
:estimated-amount amount-str
:organizations organizations}))))
(db/tx-run! cfg (fn [tx-cfg]
(eml/send tx-cfg {::eml/reuse-conn true
::eml/factory eml/renewal-notice
:public-uri (cf/get :public-uri)
:to user-email
:user-name user-name
:renewal-date renewal-date
:estimated-amount amount-str
:organizations organizations}))))
nil)
;; API: exists-organization-team-invitations-for-non-members /

20
backend/src/app/rpc/nitrate/emails_helper.clj
View File

@ -52,14 +52,14 @@
(defn- send-organization-setup-sso-email!
"Send the organization SSO setup email to a single recipient, when allowed."
[conn organization-name {:keys [email profile]}]
[{:keys [::db/conn] :as cfg} organization-name {:keys [email profile]}]
(when (or (nil? profile)
(eml/allow-send-emails? conn profile))
(eml/send! {::eml/conn conn
::eml/factory eml/organization-setup-sso
:public-uri (cf/get :public-uri)
:to email
:organization-name organization-name})))
(eml/send cfg {::eml/reuse-conn true
::eml/factory eml/organization-setup-sso
:public-uri (cf/get :public-uri)
:to email
:organization-name organization-name})))
(defn- get-organization-sso-notify-recipients
"Unique organization members and pending organization/team invitees for SSO activation emails."
@ -89,9 +89,9 @@
[cfg organization-id]
(let [organization-summary (nitrate/call cfg :get-organization-summary {:organization-id organization-id})]
(db/tx-run! cfg
(fn [{:keys [::db/conn]}]
(fn [{:keys [::db/conn] :as cfg}]
(doseq [recipient (get-organization-sso-notify-recipients conn cfg organization-id organization-summary)]
(send-organization-setup-sso-email! conn (:name organization-summary) recipient))))))
(send-organization-setup-sso-email! cfg (:name organization-summary) recipient))))))
(defn send-organization-setup-sso-emails-for-team!
"Notify team members who are not in `organization-member-ids-before` and pending team invitees."
@ -99,6 +99,6 @@
(when (organization-sso-active? cfg organization-id)
(let [organization-summary (nitrate/call cfg :get-organization-summary {:organization-id organization-id})]
(db/tx-run! cfg
(fn [{:keys [::db/conn]}]
(fn [{:keys [::db/conn] :as cfg}]
(doseq [recipient (get-team-sso-notify-recipients conn team-id organization-member-ids-before)]
(send-organization-setup-sso-email! conn (:name organization-summary) recipient)))))))
(send-organization-setup-sso-email! cfg (:name organization-summary) recipient)))))))

150
backend/src/app/rpc/quotes.clj
View File

@ -13,7 +13,7 @@
[app.common.time :as ct]
[app.config :as cf]
[app.db :as db]
[app.worker :as wrk]
[app.jobs :as jobs]
[cuerdas.core :as str]))
(defmulti check-quote ::id)
@ -73,39 +73,39 @@
(run! (partial check cfg) others)))))))
(defn- send-notification!
[{:keys [::db/conn] :as params}]
[cfg]
(l/warn :hint "max quote reached"
:target (::target params)
:profile-id (some-> params ::profile-id str)
:team-id (some-> params ::team-id str)
:project-id (some-> params ::project-id str)
:file-id (some-> params ::file-id str)
:quote (::quote params)
:total (::total params)
:incr (::inc params 1))
:target (::target cfg)
:profile-id (some-> cfg ::profile-id str)
:team-id (some-> cfg ::team-id str)
:project-id (some-> cfg ::project-id str)
:file-id (some-> cfg ::file-id str)
:quote (::quote cfg)
:total (::total cfg)
:incr (::inc cfg 1))
(when-let [admins (seq (cf/get :admins))]
(let [subject (str/istr "[quotes:notification]: max quote reached ~(::target params)")
content (str/istr "- Param: profile-id '~(::profile-id params)}'\n"
"- Param: team-id '~(::team-id params)'\n"
"- Param: project-id '~(::project-id params)'\n"
"- Param: file-id '~(::file-id params)'\n"
"- Quote ID: '~(::target params)'\n"
"- Max: ~(::quote params)\n"
"- Total: ~(::total params) (INCR ~(::incr params 1))\n")]
(wrk/submit! {::db/conn conn
::wrk/task :sendmail
::wrk/delay (ct/duration "30s")
::wrk/max-retries 4
::wrk/priority 200
::wrk/dedupe true
::wrk/label "quotes-notification"
::wrk/params {:to (vec admins)
:subject subject
:body content}}))))
(let [subject (str/istr "[quotes:notification]: max quote reached ~(::target cfg)")
content (str/istr "- Param: profile-id '~(::profile-id cfg)}'\n"
"- Param: team-id '~(::team-id cfg)'\n"
"- Param: project-id '~(::project-id cfg)'\n"
"- Param: file-id '~(::file-id cfg)'\n"
"- Quote ID: '~(::target cfg)'\n"
"- Max: ~(::quote cfg)\n"
"- Total: ~(::total cfg) (INCR ~(::incr cfg 1))\n")]
(jobs/submit cfg
{::jobs/name :sendmail
::jobs/delay (ct/duration "30s")
::jobs/max-retries 4
::jobs/priority 200
::jobs/dedupe true
::jobs/label "quotes-notification"
::jobs/params {:to (vec admins)
:subject subject
:body content}}))))
(defn- generic-check!
[{:keys [::db/conn ::incr ::quote-sql ::count-sql ::default ::target] :or {incr 1} :as params}]
[{:keys [::db/conn ::incr ::quote-sql ::count-sql ::default ::target] :or {incr 1} :as cfg}]
(let [quote (->> (db/exec! conn quote-sql)
(map :quote)
(reduce max (- Integer/MAX_VALUE)))
@ -114,7 +114,7 @@
(when (> (+ total incr) quote)
(if (contains? cf/flags :soft-quotes)
(send-notification! (assoc params ::quote quote ::total total))
(send-notification! (assoc cfg ::quote quote ::total total))
(ex/raise :type :restriction
:code :max-quote-reached
:target target
@ -170,9 +170,9 @@
WHERE profile_id = ?")
(defmethod check-quote ::teams-per-profile
[{:keys [::profile-id ::target] :as quote}]
(assert (valid-teams-per-profile-quote? quote) "invalid quote parameters")
(-> quote
[{:keys [::profile-id ::target] :as cfg}]
(assert (valid-teams-per-profile-quote? cfg) "invalid quote parameters")
(-> cfg
(assoc ::default (cf/get :quotes-teams-per-profile Integer/MAX_VALUE))
(assoc ::quote-sql [sql:get-quotes-1 target profile-id])
(assoc ::count-sql [sql:get-teams-per-profile profile-id])
@ -194,10 +194,10 @@
WHERE profile_id = ?")
(defmethod check-quote ::access-tokens-per-profile
[{:keys [::profile-id ::target] :as quote}]
(assert (valid-access-tokens-per-profile-quote? quote) "invalid quote parameters")
[{:keys [::profile-id ::target] :as cfg}]
(assert (valid-access-tokens-per-profile-quote? cfg) "invalid quote parameters")
(-> quote
(-> cfg
(assoc ::default (cf/get :quotes-access-tokens-per-profile Integer/MAX_VALUE))
(assoc ::quote-sql [sql:get-quotes-1 target profile-id])
(assoc ::count-sql [sql:get-access-tokens-per-profile profile-id])
@ -222,10 +222,10 @@
AND p.deleted_at IS NULL")
(defmethod check-quote ::projects-per-team
[{:keys [::profile-id ::team-id ::target] :as quote}]
(assert (valid-projects-per-team-quote? quote) "invalid quote parameters")
[{:keys [::profile-id ::team-id ::target] :as cfg}]
(assert (valid-projects-per-team-quote? cfg) "invalid quote parameters")
(-> quote
(-> cfg
(assoc ::default (cf/get :quotes-projects-per-team Integer/MAX_VALUE))
(assoc ::quote-sql [sql:get-quotes-2 target team-id profile-id profile-id])
(assoc ::count-sql [sql:get-projects-per-team team-id])
@ -249,10 +249,10 @@
WHERE v.team_id = ?")
(defmethod check-quote ::font-variants-per-team
[{:keys [::profile-id ::team-id ::target] :as quote}]
(assert (valid-font-variant-per-team-quote? quote) "invalid quote parameters")
[{:keys [::profile-id ::team-id ::target] :as cfg}]
(assert (valid-font-variant-per-team-quote? cfg) "invalid quote parameters")
(-> quote
(-> cfg
(assoc ::default (cf/get :quotes-font-variants-per-team Integer/MAX_VALUE))
(assoc ::quote-sql [sql:get-quotes-2 target team-id profile-id profile-id])
(assoc ::count-sql [sql:get-font-variants-per-team team-id])
@ -277,10 +277,10 @@
WHERE team_id = ?")
(defmethod check-quote ::invitations-per-team
[{:keys [::profile-id ::team-id ::target] :as quote}]
(assert (valid-invitations-per-team-quote? quote) "invalid quote parameters")
[{:keys [::profile-id ::team-id ::target] :as cfg}]
(assert (valid-invitations-per-team-quote? cfg) "invalid quote parameters")
(-> quote
(-> cfg
(assoc ::default (cf/get :quotes-invitations-per-team Integer/MAX_VALUE))
(assoc ::quote-sql [sql:get-quotes-2 target team-id profile-id profile-id])
(assoc ::count-sql [sql:get-invitations-per-team team-id])
@ -311,10 +311,10 @@
;; effective members plus ongoing valid invitations.
(defmethod check-quote ::profiles-per-team
[{:keys [::profile-id ::team-id ::target] :as quote}]
(assert (valid-profiles-per-team-quote? quote) "invalid quote parameters")
[{:keys [::profile-id ::team-id ::target] :as cfg}]
(assert (valid-profiles-per-team-quote? cfg) "invalid quote parameters")
(-> quote
(-> cfg
(assoc ::default (cf/get :quotes-profiles-per-team Integer/MAX_VALUE))
(assoc ::quote-sql [sql:get-quotes-2 target team-id profile-id profile-id])
(assoc ::count-sql [sql:get-profiles-per-team team-id team-id])
@ -340,10 +340,10 @@
AND f.deleted_at IS NULL")
(defmethod check-quote ::files-per-project
[{:keys [::profile-id ::project-id ::team-id ::target] :as quote}]
(assert (valid-files-per-project-quote? quote) "invalid quote parameters")
[{:keys [::profile-id ::project-id ::team-id ::target] :as cfg}]
(assert (valid-files-per-project-quote? cfg) "invalid quote parameters")
(-> quote
(-> cfg
(assoc ::default (cf/get :quotes-files-per-project Integer/MAX_VALUE))
(assoc ::quote-sql [sql:get-quotes-3 target project-id profile-id team-id profile-id profile-id])
(assoc ::count-sql [sql:get-files-per-project project-id])
@ -368,10 +368,10 @@
WHERE ct.file_id = ?")
(defmethod check-quote ::comment-threads-per-file
[{:keys [::profile-id ::file-id ::team-id ::project-id ::target] :as quote}]
(assert (valid-comment-threads-per-file-quote? quote) "invalid quote parameters")
[{:keys [::profile-id ::file-id ::team-id ::project-id ::target] :as cfg}]
(assert (valid-comment-threads-per-file-quote? cfg) "invalid quote parameters")
(-> quote
(-> cfg
(assoc ::default (cf/get :quotes-comment-threads-per-file Integer/MAX_VALUE))
(assoc ::quote-sql [sql:get-quotes-4 target file-id profile-id project-id
profile-id team-id profile-id profile-id])
@ -398,9 +398,9 @@
WHERE ct.file_id = ?")
(defmethod check-quote ::comments-per-file
[{:keys [::profile-id ::file-id ::team-id ::project-id ::target] :as quote}]
(assert (valid-comments-per-file-quote? quote) "invalid quote parameters")
(-> quote
[{:keys [::profile-id ::file-id ::team-id ::project-id ::target] :as cfg}]
(assert (valid-comments-per-file-quote? cfg) "invalid quote parameters")
(-> cfg
(assoc ::default (cf/get :quotes-comments-per-file Integer/MAX_VALUE))
(assoc ::quote-sql [sql:get-quotes-4 target file-id profile-id project-id
profile-id team-id profile-id profile-id])
@ -430,9 +430,9 @@
AND fc.data IS NOT NULL")
(defmethod check-quote ::snapshots-per-file
[{:keys [::profile-id ::file-id ::team-id ::project-id ::target] :as quote}]
(assert (valid-snapshots-per-file-quote? quote) "invalid quote parameters")
(-> quote
[{:keys [::profile-id ::file-id ::team-id ::project-id ::target] :as cfg}]
(assert (valid-snapshots-per-file-quote? cfg) "invalid quote parameters")
(-> cfg
(assoc ::default (cf/get :quotes-snapshots-per-file Integer/MAX_VALUE))
(assoc ::quote-sql [sql:get-quotes-4 target file-id profile-id project-id
profile-id team-id profile-id profile-id])
@ -463,9 +463,9 @@
AND fc.data IS NOT NULL")
(defmethod check-quote ::snapshots-per-team
[{:keys [::profile-id ::team-id ::target] :as quote}]
(assert (valid-snapshots-per-team-quote? quote) "invalid quote parameters")
(-> quote
[{:keys [::profile-id ::team-id ::target] :as cfg}]
(assert (valid-snapshots-per-team-quote? cfg) "invalid quote parameters")
(-> cfg
(assoc ::default (cf/get :quotes-snapshots-per-team Integer/MAX_VALUE))
(assoc ::quote-sql [sql:get-quotes-2 target team-id profile-id profile-id])
(assoc ::count-sql [sql:get-snapshots-per-team team-id])
@ -489,9 +489,9 @@
WHERE tar.team_id = ?")
(defmethod check-quote ::team-access-requests-per-team
[{:keys [::profile-id ::team-id ::target] :as quote}]
(assert (valid-team-access-requests-per-team-quote? quote) "invalid quote parameters")
(-> quote
[{:keys [::profile-id ::team-id ::target] :as cfg}]
(assert (valid-team-access-requests-per-team-quote? cfg) "invalid quote parameters")
(-> cfg
(assoc ::default (cf/get :quotes-team-access-requests-per-team Integer/MAX_VALUE))
(assoc ::quote-sql [sql:get-quotes-2 target team-id profile-id profile-id])
(assoc ::count-sql [sql:get-team-access-requests-per-team team-id])
@ -514,9 +514,9 @@
WHERE tar.requester_id = ?")
(defmethod check-quote ::team-access-requests-per-requester
[{:keys [::profile-id ::target] :as quote}]
(assert (valid-team-access-requests-per-requester-quote? quote) "invalid quote parameters")
(-> quote
[{:keys [::profile-id ::target] :as cfg}]
(assert (valid-team-access-requests-per-requester-quote? cfg) "invalid quote parameters")
(-> cfg
(assoc ::default (cf/get :quotes-team-access-requests-per-requester Integer/MAX_VALUE))
(assoc ::quote-sql [sql:get-quotes-1 target profile-id])
(assoc ::count-sql [sql:get-team-access-requests-per-requester profile-id])
@ -539,9 +539,9 @@
AND deleted_at IS NULL")
(defmethod check-quote ::upload-sessions-per-profile
[{:keys [::profile-id ::target] :as quote}]
(assert (valid-upload-sessions-per-profile-quote? quote) "invalid quote parameters")
(-> quote
[{:keys [::profile-id ::target] :as cfg}]
(assert (valid-upload-sessions-per-profile-quote? cfg) "invalid quote parameters")
(-> cfg
(assoc ::default (cf/get :quotes-upload-sessions-per-profile Integer/MAX_VALUE))
(assoc ::quote-sql [sql:get-quotes-1 target profile-id])
(assoc ::count-sql [sql:get-upload-sessions-per-profile profile-id])
@ -607,9 +607,9 @@
WHERE so.deleted_at IS NULL")
(defmethod check-quote ::media-storage-bytes-per-team
[{:keys [::profile-id ::team-id ::target] :as quote}]
(assert (valid-media-storage-bytes-per-team-quote? quote) "invalid quote parameters")
(-> quote
[{:keys [::profile-id ::team-id ::target] :as cfg}]
(assert (valid-media-storage-bytes-per-team-quote? cfg) "invalid quote parameters")
(-> cfg
(assoc ::default (cf/get :quotes-media-storage-bytes-per-team
(* 20 1024 1024 1024)))
(assoc ::quote-sql [sql:get-quotes-2 target team-id profile-id profile-id])

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

@ -26,6 +26,7 @@
[app.features.fdata :as fdata]
[app.features.file-snapshots :as fsnap]
[app.http.session :as session]
[app.jobs :as jobs]
[app.loggers.audit :as audit]
[app.msgbus :as mbus]
[app.rpc.commands.auth :as auth]
@ -39,7 +40,6 @@
[app.system :as sys]
[app.util.blob :as blob]
[app.util.pointer-map :as pmap]
[app.worker :as wrk]
[clojure.datafy :refer [datafy]]
[clojure.java.io :as io]
[clojure.pprint :refer [print-table]]
@ -56,38 +56,39 @@
;; TASKS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn print-tasks
(defn print-jobs
[]
(let [tasks (:app.worker/registry sys/system)]
(pp/pprint (keys tasks) :level 200)))
(let [jobs (:app.jobs/defs sys/system)]
(pp/pprint (into (sorted-set) (keys jobs)))))
(defn run-task!
(defn run-job
"Execute the job handler in-process (no job row)."
([tname]
(run-task! tname {}))
(run-job tname {}))
([tname params]
(wrk/invoke! (-> sys/system
(assoc ::wrk/task tname)
(assoc ::wrk/params params)))))
(jobs/invoke (-> sys/system
(assoc ::jobs/name tname)
(assoc ::jobs/params params)))))
(defn schedule-task!
(defn submit-job
"Submit a durable job to the queue."
([name]
(schedule-task! name {}))
(submit-job name {}))
([name params]
(wrk/submit! (-> sys/system
(assoc ::wrk/task name)
(assoc ::wrk/params params)))))
(jobs/submit sys/system
{::jobs/name name
::jobs/params params})))
(defn send-test-email!
(defn send-test-email
[destination]
(assert (string? destination) "destination should be provided")
(-> sys/system
(assoc ::wrk/task :sendmail)
(assoc ::wrk/params {:body "test email"
:subject "test email"
:to [destination]})
(wrk/invoke!)))
(jobs/submit sys/system
{::jobs/name :sendmail
::jobs/params {:body "test email"
:subject "test email"
:to [destination]}}))
(defn resend-email-verification-email!
(defn resend-email-verification-email
[email]
(db/tx-run! sys/system
(fn [{:keys [::db/conn] :as cfg}]
@ -177,11 +178,11 @@
:context {:triggered-by "srepl"
:cause cause}})
(wrk/invoke! (-> system
(assoc ::wrk/task :delete-object)
(assoc ::wrk/params {:object :profile
:deleted-at deleted-at
:id (:id profile)})))
(jobs/invoke (-> system
(assoc ::jobs/name :delete-object)
(assoc ::jobs/params {:object :profile
:deleted-at deleted-at
:id (:id profile)})))
(:id profile)))
(defn delete-profiles-by-email!
@ -667,11 +668,11 @@
:context {:triggered-by "srepl"
:cause "explicit call to delete-file!"}
:tracked-at tnow})
(wrk/invoke! (-> sys/system
(assoc ::wrk/task :delete-object)
(assoc ::wrk/params {:object :file
:deleted-at tnow
:id file-id})))
(jobs/invoke (-> sys/system
(assoc ::jobs/name :delete-object)
(assoc ::jobs/params {:object :file
:deleted-at tnow
:id file-id})))
:deleted))
(defn restore-file!
@ -708,11 +709,11 @@
:cause "explicit call to delete-project!"}
:tracked-at tnow})
(wrk/invoke! (-> sys/system
(assoc ::wrk/task :delete-object)
(assoc ::wrk/params {:object :project
:deleted-at tnow
:id project-id})))
(jobs/invoke (-> sys/system
(assoc ::jobs/name :delete-object)
(assoc ::jobs/params {:object :project
:deleted-at tnow
:id project-id})))
:deleted))
(defn- restore-project*
@ -760,11 +761,11 @@
:cause "explicit call to delete-profile!"}
:tracked-at tnow})
(wrk/invoke! (-> sys/system
(assoc ::wrk/task :delete-object)
(assoc ::wrk/params {:object :team
:deleted-at tnow
:id team-id})))
(jobs/invoke (-> sys/system
(assoc ::jobs/name :delete-object)
(assoc ::jobs/params {:object :team
:deleted-at tnow
:id team-id})))
:deleted))
(defn- restore-team*
@ -816,11 +817,11 @@
:cause "explicit call to delete-profile!"}
:tracked-at tnow})
(wrk/invoke! (-> sys/system
(assoc ::wrk/task :delete-object)
(assoc ::wrk/params {:object :profile
:deleted-at tnow
:id profile-id})))
(jobs/invoke (-> sys/system
(assoc ::jobs/name :delete-object)
(assoc ::jobs/params {:object :profile
:deleted-at tnow
:id profile-id})))
:deleted))
(defn restore-profile!
@ -879,41 +880,41 @@
[]
(->> (db/exec! sys/system ["select id, deleted_at from profile where deleted_at is not null"])
(run! (fn [{:keys [id deleted-at]}]
(wrk/invoke! (-> sys/system
(assoc ::wrk/task :delete-object)
(assoc ::wrk/params {:object :profile
:deleted-at deleted-at
:id id})))))))
(jobs/invoke (-> sys/system
(assoc ::jobs/name :delete-object)
(assoc ::jobs/params {:object :profile
:deleted-at deleted-at
:id id})))))))
(defn process-deleted-teams-cascade
[]
(->> (db/exec! sys/system ["select id, deleted_at from team where deleted_at is not null"])
(run! (fn [{:keys [id deleted-at]}]
(wrk/invoke! (-> sys/system
(assoc ::wrk/task :delete-object)
(assoc ::wrk/params {:object :team
:deleted-at deleted-at
:id id})))))))
(jobs/invoke (-> sys/system
(assoc ::jobs/name :delete-object)
(assoc ::jobs/params {:object :team
:deleted-at deleted-at
:id id})))))))
(defn process-deleted-projects-cascade
[]
(->> (db/exec! sys/system ["select id, deleted_at from project where deleted_at is not null"])
(run! (fn [{:keys [id deleted-at]}]
(wrk/invoke! (-> sys/system
(assoc ::wrk/task :delete-object)
(assoc ::wrk/params {:object :project
:deleted-at deleted-at
:id id})))))))
(jobs/invoke (-> sys/system
(assoc ::jobs/name :delete-object)
(assoc ::jobs/params {:object :project
:deleted-at deleted-at
:id id})))))))
(defn process-deleted-files-cascade
[]
(->> (db/exec! sys/system ["select id, deleted_at from file where deleted_at is not null"])
(run! (fn [{:keys [id deleted-at]}]
(wrk/invoke! (-> sys/system
(assoc ::wrk/task :delete-object)
(assoc ::wrk/params {:object :file
:deleted-at deleted-at
:id id})))))))
(jobs/invoke (-> sys/system
(assoc ::jobs/name :delete-object)
(assoc ::jobs/params {:object :file
:deleted-at deleted-at
:id id})))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SSO

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

@ -48,6 +48,13 @@
"Bucket name for chunked-upload chunks."
stsch/upload-session-bucket)
(def job-resource-bucket
"Bucket for storage objects referenced by job.resource_id (the
unified jobs substrate): transient artifacts owned by their job row,
reclaimed by storage-gc-touched (via the jobs GC touch) once no job
row references them anymore."
stsch/job-resource-bucket)
(def valid-buckets
stsch/metadata-buckets)

38
backend/src/app/storage/gc_deleted.clj
View File

@ -15,8 +15,10 @@
(:require
[app.common.data :as d]
[app.common.logging :as l]
[app.common.schema :as sm]
[app.common.time :as ct]
[app.db :as db]
[app.jobs :as jobs]
[app.storage :as sto]
[app.storage.impl :as impl]
[clojure.set :as set]
@ -172,18 +174,42 @@
(+ acc (process-chunk conn storage backend-id ids)))
0
by-backend))))))]
;; Heartbeat per chunk: each chunk commits on its own, so a long
;; sweep neither loses work on late failure nor outruns the lease.
(jobs/heartbeat cfg)
(if deleted
(recur (+ total deleted))
total))))
(defmethod ig/assert-key ::handler
(declare execute-storage-gc-deleted)
(defmethod ig/assert-key ::job-def
[_ params]
(assert (sto/valid-storage? (::sto/storage params)) "expect valid storage")
(assert (db/pool? (::db/pool params)) "expect valid db pool"))
(defmethod ig/init-key ::handler
(def schema:storage-gc-deleted-params
"Params map (no params needed; cfg-provided config only)."
[:map {:closed true}])
(defmethod ig/init-key ::job-def
[_ cfg]
(fn [_]
(let [total (clean-deleted cfg)]
(l/inf :hint "task finished" :total total)
{:deleted total})))
{::jobs/name :storage-gc-deleted
::jobs/schema schema:storage-gc-deleted-params
::jobs/handler
(fn [_context params]
(execute-storage-gc-deleted cfg params))
::jobs/decoder (sm/decoder schema:storage-gc-deleted-params sm/json-transformer)
::jobs/validator (sm/validator schema:storage-gc-deleted-params)})
(defn execute-storage-gc-deleted
"Plain job handler: clean the marked-deleted storage objects."
([cfg] (execute-storage-gc-deleted cfg {}))
([cfg _params]
;; NOTE: no outer transaction here on purpose — clean-deleted
;; commits each chunk in its own transaction, so a late failure
;; only loses the in-flight chunk.
(jobs/heartbeat cfg)
(let [total (clean-deleted cfg)]
(l/inf :hint "task finished" :total total)
{:deleted total})))

63
backend/src/app/storage/gc_touched.clj
View File

@ -22,8 +22,10 @@
[app.common.data.macros :as dm]
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.common.schema :as sm]
[app.common.time :as ct]
[app.db :as db]
[app.jobs :as jobs]
[app.metrics :as mtx]
[app.storage :as sto]
[app.storage.impl :as impl]
@ -68,8 +70,7 @@
(-> (db/exec-one! conn [sql:has-file-object-thumbnail-refs id])
(get :has-refs)))
(def ^:private
sql:has-file-thumbnail-refs
(def ^:private sql:has-file-thumbnail-refs
"SELECT EXISTS (SELECT 1 FROM file_thumbnail WHERE media_id = ?) AS has_refs")
(defn- has-file-thumbnails-refs?
@ -77,6 +78,24 @@
(-> (db/exec-one! conn [sql:has-file-thumbnail-refs id])
(get :has-refs)))
;; Objects in the job-resource bucket are referenced by the resource_id
;; column of job rows (the unified jobs substrate). A live job row of
;; any status keeps the object frozen; once no row references it (the
;; jobs GC deletes expiring/retained rows and marks the object as
;; touched before/at the same time) the object becomes deletable.
(def ^:private sql:has-job-resource-refs
"SELECT EXISTS (SELECT 1 FROM job WHERE resource_id = ?) AS has_refs")
(defn- has-job-resource-refs?
"Checks if ANY job row (any status) references the object. Terminal states
(completed, failed, cancelled, aborted) also freeze the object because the jobs GC
hasn't run yet to clean them up. Once the jobs GC deletes the row, the
object becomes eligible for storage GC."
[conn {:keys [id]}]
(-> (db/exec-one! conn [sql:has-job-resource-refs id])
(get :has-refs)))
(def sql:exists-file-data-refs
"SELECT EXISTS (
SELECT 1 FROM file_data
@ -179,6 +198,7 @@
(= bucket "file-data") (process-objects conn has-file-data-refs? bucket objects)
(= bucket sto/tempfile-bucket) (process-objects conn (constantly false) sto/tempfile-bucket objects)
(= bucket sto/upload-session-bucket) (process-objects conn (constantly false) sto/upload-session-bucket objects)
(= bucket sto/job-resource-bucket) (process-objects conn has-job-resource-refs? bucket objects)
(= bucket "organization") (process-objects conn (constantly false) bucket objects)
:else
(ex/raise :type :internal
@ -247,6 +267,7 @@
(let [[nfo ndo] (if (seq chunk)
(db/tx-run! cfg process-chunk chunk)
[0 0])]
(jobs/heartbeat cfg)
(recur (long (+ freezed nfo))
(long (+ deleted ndo))))
{:freeze freezed :delete deleted}))))
@ -255,20 +276,40 @@
;; HANDLER
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod ig/assert-key ::handler
(declare execute-storage-gc-touched)
(defmethod ig/assert-key ::job-def
[_ params]
(assert (db/pool? (::db/pool params)) "expect valid storage")
(assert (mtx/metrics? (::mtx/metrics params)) "expect valid metrics"))
(defmethod ig/expand-key ::handler
(defmethod ig/expand-key ::job-def
[k v]
{k (merge {::min-age (ct/duration {:hours 2})} v)})
(defmethod ig/init-key ::handler
[_ {:keys [::min-age] :as cfg}]
(fn [{:keys [props]}]
(let [threshold (if (:skip-delay props)
(ct/now)
(ct/minus (ct/now) min-age))]
(process-touched (assoc cfg ::timestamp threshold)))))
(def schema:storage-gc-touched-params
"Optional :skip-delay processes all touched objects immediately,
bypassing the min-age threshold (repl-driven deletion cascades)."
[:map {:closed true}
[:skip-delay {:optional true} :boolean]])
(defmethod ig/init-key ::job-def
[_ cfg]
{::jobs/name :storage-gc-touched
::jobs/schema schema:storage-gc-touched-params
::jobs/handler
(fn [_context params]
(execute-storage-gc-touched cfg params))
::jobs/decoder (sm/decoder schema:storage-gc-touched-params sm/json-transformer)
::jobs/validator (sm/validator schema:storage-gc-touched-params)})
(defn execute-storage-gc-touched
"Plain job handler: analyze the touched storage objects and freeze or
delete them depending on their references."
([cfg] (execute-storage-gc-touched cfg {}))
([cfg params]
(let [threshold (if (:skip-delay params)
(ct/now)
(ct/minus (ct/now) (::min-age cfg)))]
(process-touched (assoc cfg ::timestamp threshold)))))

33
backend/src/app/storage/pending_gc.clj
View File

@ -14,7 +14,9 @@
ever iterating the whole physical store."
(:require
[app.common.logging :as l]
[app.common.schema :as sm]
[app.db :as db]
[app.jobs :as jobs]
[app.storage :as sto]
[app.storage.impl :as impl]
[integrant.core :as ig]))
@ -75,14 +77,33 @@
(recur (long (+ total (count rows)))))
total)))
(defmethod ig/assert-key ::handler
(declare execute-storage-pending-gc)
(defmethod ig/assert-key ::job-def
[_ params]
(assert (db/pool? (::db/pool params)) "expected valid db pool")
(assert (sto/valid-storage? (::sto/storage params)) "expect valid storage"))
(defmethod ig/init-key ::handler
(def schema:storage-pending-gc-params
"Params map (no params needed; cfg-provided config only)."
[:map {:closed true}])
(defmethod ig/init-key ::job-def
[_ cfg]
(fn [_]
(let [total (process! cfg)]
(l/inf :hint "task finished" :total total)
{:processed total})))
{::jobs/name :storage-pending-gc
::jobs/schema schema:storage-pending-gc-params
::jobs/handler
(fn [_context params]
(execute-storage-pending-gc cfg params))
::jobs/decoder (sm/decoder schema:storage-pending-gc-params sm/json-transformer)
::jobs/validator (sm/validator schema:storage-pending-gc-params)})
(defn execute-storage-pending-gc
"Plain job handler: reclaim storage objects created in 'pending' state
that were never promoted to 'valid'."
([cfg] (execute-storage-pending-gc cfg {}))
([cfg _params]
(jobs/heartbeat cfg)
(let [total (process! cfg)]
(l/inf :hint "task finished" :total total)
{:processed total})))

6
backend/src/app/storage/schema.clj
View File

@ -33,6 +33,11 @@
"Bucket name for chunked-upload chunks."
"upload-session")
(def job-resource-bucket
"Bucket name for storage objects owned by a job row
(`job.resource_id`)."
"job-resource")
(def bucket-requirements
"Canonical buckets and the extra keys each one must carry, so a new
bucket and its contract live in one place. Listed keys are declared as
@ -48,6 +53,7 @@
"organization" #{:organization-id}
tempfile-bucket #{}
upload-session-bucket #{}
job-resource-bucket #{}
"file-data" #{:file-id :id}
"file-data-fragment" #{}
"file-change" #{}})

29
backend/src/app/tasks/delete_object.clj
View File

@ -8,9 +8,11 @@
"A generic task for object deletion cascade handling"
(:require
[app.common.logging :as l]
[app.common.schema :as sm]
[app.common.time :as ct]
[app.db :as db]
[app.db.sql :as-alias sql]
[app.jobs :as jobs]
[app.rpc.commands.files :as files]
[app.rpc.commands.profile :as profile]
[app.storage :as sto]
@ -140,6 +142,7 @@
{::db/return-keys false})
(doseq [team (profile/get-owned-teams conn id)]
(jobs/heartbeat cfg)
(delete-object cfg (assoc team
:object :team
:deleted-at deleted-at))))
@ -148,12 +151,30 @@
[_cfg props]
(l/wrn :obj (:object props) :hint "not implementation found"))
(defmethod ig/assert-key ::handler
(def schema:delete-object-params
[:map
[:object [:enum :snapshot :team :project :profile :file]]
[:deleted-at ::ct/inst]
[:id ::sm/uuid]
[:file-id {:optional true} ::sm/uuid]])
(defn execute-delete-object
"Plain job handler: run the delete-object multimethod on the provided
params inside a single transaction."
[cfg params]
(db/tx-run! cfg delete-object params))
(defmethod ig/assert-key ::job-def
[_ params]
(assert (db/pool? (::db/pool params)) "expected a valid database pool")
(assert (sto/valid-storage? (::sto/storage params)) "expected valid storage to be provided"))
(defmethod ig/init-key ::handler
(defmethod ig/init-key ::job-def
[_ cfg]
(fn [{:keys [props] :as task}]
(db/tx-run! cfg delete-object props)))
{::jobs/name :delete-object
::jobs/schema schema:delete-object-params
::jobs/handler
(fn [_context params]
(execute-delete-object cfg params))
::jobs/decoder (sm/decoder schema:delete-object-params sm/json-transformer)
::jobs/validator (sm/validator schema:delete-object-params)})

54
backend/src/app/tasks/demo_purge.clj
View File

@ -9,33 +9,47 @@
creation time with a delay matching the configured deletion-delay."
(:require
[app.common.logging :as l]
[app.common.schema :as sm]
[app.common.time :as ct]
[app.db :as db]
[app.worker :as wrk]
[app.jobs :as jobs]
[integrant.core :as ig]))
(defmethod ig/assert-key ::handler
(def schema:demo-purge-params
[:map
[:profile-id ::sm/uuid]])
(declare execute-demo-purge)
(defmethod ig/assert-key ::job-def
[_ params]
(assert (db/pool? (::db/pool params)) "expected a valid database pool"))
(defmethod ig/init-key ::handler
(defmethod ig/init-key ::job-def
[_ cfg]
(fn [{:keys [props]}]
(let [profile-id (get props :profile-id)
now (ct/now)]
{::jobs/name :demo-purge
::jobs/schema schema:demo-purge-params
::jobs/handler
(fn [_context params]
(execute-demo-purge cfg params))
::jobs/decoder (sm/decoder schema:demo-purge-params sm/json-transformer)
::jobs/validator (sm/validator schema:demo-purge-params)})
(l/trc :hint "demo-purge" :profile-id (str profile-id))
(defn execute-demo-purge
"Plain job handler: mark the demo profile as deleted and submit the
corresponding delete-object job."
[cfg params]
(let [profile-id (:profile-id params)
now (ct/now)]
(l/trc :hint "demo-purge" :profile-id (str profile-id))
;; Mark the profile for immediate deletion
(db/tx-run! cfg
(fn [{:keys [::db/conn] :as cfg}]
(db/update! conn :profile
{:deleted-at now}
{:id profile-id}
{::db/return-keys false})
(wrk/submit!
(-> cfg
(assoc ::wrk/task :delete-object)
(assoc ::wrk/params {:object :profile
:deleted-at now
:id profile-id}))))))))
(db/tx-run! cfg
(fn [{:keys [::db/conn] :as cfg}]
(db/update! conn :profile
{:deleted-at now}
{:id profile-id}
{::db/return-keys false})
(jobs/submit cfg
{::jobs/name :delete-object
::jobs/params {:object :profile
:deleted-at now
:id profile-id}})))))

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

@ -15,6 +15,7 @@
[app.common.files.helpers :as cfh]
[app.common.files.validate :as cfv]
[app.common.logging :as l]
[app.common.schema :as sm]
[app.common.thumbnails :as thc]
[app.common.time :as ct]
[app.common.types.components-list :as ctkl]
@ -24,8 +25,8 @@
[app.db :as db]
[app.features.fdata :as feat.fdata]
[app.features.file-snapshots :as fsnap]
[app.jobs :as jobs]
[app.storage :as sto]
[app.worker :as wrk]
[integrant.core :as ig]))
(declare get-file)
@ -57,6 +58,7 @@
(->> (db/exec! conn [sql:mark-file-media-object-deleted timestamp id used-media])
(into #{} (map :id)))]
(jobs/heartbeat cfg)
(doseq [id unused-media]
(l/trc :obj "media-object"
:file-id (str id)
@ -71,7 +73,7 @@
RETURNING object_id")
(defn- clean-file-object-thumbnails!
[{:keys [::db/conn ::timestamp]} {:keys [data] :as file}]
[{:keys [::db/conn ::timestamp] :as cfg} {:keys [data] :as file}]
(let [file-id (:id file)
using (->> (vals (:pages-index data))
(into #{} (comp
@ -87,6 +89,7 @@
unused (->> (db/exec! conn [sql:mark-file-object-thumbnails-deleted timestamp file-id ids])
(into #{} (map :object-id)))]
(jobs/heartbeat cfg)
(doseq [object-id unused]
(l/trc :obj "object-thumbnail"
:file-id (str file-id)
@ -101,10 +104,11 @@
RETURNING revn")
(defn- clean-file-thumbnails!
[{:keys [::db/conn ::timestamp]} {:keys [id revn] :as file}]
[{:keys [::db/conn ::timestamp] :as cfg} {:keys [id revn] :as file}]
(let [unused (->> (db/exec! conn [sql:mark-file-thumbnails-deleted timestamp id revn])
(into #{} (map :revn)))]
(jobs/heartbeat cfg)
(doseq [revn unused]
(l/trc :obj "thumbnail"
:file-id (str id)
@ -182,12 +186,13 @@
(mapcat feat.fdata/get-used-pointer-ids)))
(defn- clean-fragments!
[{:keys [::db/conn ::timestamp]} {:keys [id] :as file}]
[{:keys [::db/conn ::timestamp] :as cfg} {:keys [id] :as file}]
(let [used (into #{} xf:collect-pointers [file])
unused (->> (db/exec! conn [sql:mark-deleted-data-fragments timestamp id
(db/create-array conn "uuid" used)])
(into #{} bfc/xf-map-id))]
(jobs/heartbeat cfg)
(doseq [id unused]
(l/trc :obj "fragment"
:file-id (str id)
@ -240,28 +245,41 @@
;; HANDLER
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod ig/assert-key ::handler
[_ params]
(assert (db/pool? (::db/pool params)) "expected a valid database pool")
(assert (sto/valid-storage? (::sto/storage params)) "expected valid storage to be provided"))
(defn execute-file-gc
"Plain job handler: clean the media/thumbnails/fdata of one file."
[cfg params]
(try
(-> cfg
(assoc ::db/rollback (:rollback? params))
(db/tx-run! (fn [{:keys [::db/conn] :as cfg}]
(let [cfg (-> cfg
(update ::sto/storage sto/configure conn)
(assoc ::timestamp (ct/now)))
processed? (process-file! cfg params)]
(defmethod ig/init-key ::handler
(when (and processed? (contains? cf/flags :tiered-file-data-storage))
(jobs/submit cfg
{::jobs/name :offload-file-data
::jobs/params params
::jobs/priority 10
::jobs/delay 1000}))
processed?))))
(catch Throwable cause
(l/err :hint "error on cleaning file"
:file-id (str (:file-id params))
:cause cause))))
(def schema:file-gc-params
[:map
[:file-id ::sm/uuid]
[:revn ::sm/int]])
(defmethod ig/init-key ::job-def
[_ cfg]
(fn [{:keys [props] :as task}]
(try
(-> cfg
(assoc ::db/rollback (:rollback? props))
(assoc ::timestamp (ct/now))
(db/tx-run! (fn [cfg]
(let [processed? (process-file! cfg props)]
(when (and processed? (contains? cf/flags :tiered-file-data-storage))
(wrk/submit! (-> cfg
(assoc ::wrk/task :offload-file-data)
(assoc ::wrk/params props)
(assoc ::wrk/priority 10)
(assoc ::wrk/delay 1000))))
processed?))))
(catch Throwable cause
(l/err :hint "error on cleaning file"
:file-id (str (:file-id props))
:cause cause)))))
{::jobs/name :file-gc
::jobs/schema schema:file-gc-params
::jobs/handler
(fn [_context params]
(execute-file-gc cfg params))
::jobs/decoder (sm/decoder schema:file-gc-params sm/json-transformer)
::jobs/validator (sm/validator schema:file-gc-params)})

52
backend/src/app/tasks/file_gc_scheduler.clj
View File

@ -9,10 +9,11 @@
file-gc task for all files that matches the eligibility threshold."
(:require
[app.common.logging :as l]
[app.common.schema :as sm]
[app.common.time :as ct]
[app.config :as cf]
[app.db :as db]
[app.worker :as wrk]
[app.jobs :as jobs]
[integrant.core :as ig]))
(def ^:private
@ -36,29 +37,50 @@
:file-id (str id)
:revn revn
:modified-at (ct/format-inst modified-at))
(wrk/submit! (assoc cfg ::wrk/params params))
(jobs/submit cfg
{::jobs/name :file-gc
::jobs/params params
::jobs/priority 10
::jobs/delay 10000})
(jobs/heartbeat cfg)
(inc total)))
0
(db/plan conn [sql:get-candidates threshold] {:fetch-size 10}))]
{:processed total}))
(defmethod ig/assert-key ::handler
(declare execute-file-gc-scheduler)
(defmethod ig/assert-key ::job-def
[_ params]
(assert (db/pool? (::db/pool params)) "expected a valid database pool"))
(defmethod ig/expand-key ::handler
(defmethod ig/expand-key ::job-def
[k v]
{k (assoc v ::min-age (cf/get-file-clean-delay))})
(defmethod ig/init-key ::handler
(def schema:file-gc-scheduler-params
"min-age: int millis or text over the job pipeline, duration object
in-process (repl runs)."
[:map
[:min-age {:optional true} [:or :int :string ::ct/duration]]])
(defmethod ig/init-key ::job-def
[_ cfg]
(fn [{:keys [props] :as task}]
(let [threshold (-> (ct/duration (or (:min-age props) (::min-age cfg)))
(ct/in-past))]
(-> cfg
(assoc ::db/rollback (:rollback? props))
(assoc ::wrk/task :file-gc)
(assoc ::wrk/priority 10)
(assoc ::wrk/mark-retries 0)
(assoc ::wrk/delay 10000)
(db/tx-run! schedule! threshold)))))
{::jobs/name :file-gc-scheduler
::jobs/schema schema:file-gc-scheduler-params
::jobs/handler
(fn [_context params]
(execute-file-gc-scheduler cfg params))
::jobs/decoder (sm/decoder schema:file-gc-scheduler-params sm/json-transformer)
::jobs/validator (sm/validator schema:file-gc-scheduler-params)})
(defn execute-file-gc-scheduler
"Plain job handler: select the file gc candidates (media-trim pending
files before threshold) and schedule one file-gc job per file; no props
needed (min-age default from config; overridable for the repl runs)."
[cfg params]
(let [threshold (-> (ct/duration (or (:min-age params) (::min-age cfg)))
(ct/in-past))]
(-> cfg
(assoc ::db/rollback (:rollback? params))
(db/tx-run! schedule! threshold))))

120
backend/src/app/tasks/objects_gc.clj
View File

@ -9,9 +9,11 @@
of deleted or unreachable objects."
(:require
[app.common.logging :as l]
[app.common.schema :as sm]
[app.common.time :as ct]
[app.db :as db]
[app.features.fdata :as fdata]
[app.jobs :as jobs]
[app.storage :as sto]
[app.tasks.delete-object :as dobj]
[integrant.core :as ig]))
@ -44,9 +46,9 @@
pending purge. Referenced storage objects are touched so the storage GC
reclaims them with its usual delay; chunk mappings are removed before the
session row (NO ACTION foreign keys)."
[{:keys [::db/conn ::timestamp ::chunk-size ::sto/storage] :as cfg}]
(let [stalled-threshold (ct/minus timestamp {:hours 1})]
(->> (db/plan conn [sql:get-upload-sessions timestamp stalled-threshold timestamp chunk-size]
[{:keys [::db/conn ::threshold ::chunk-size ::sto/storage] :as cfg}]
(let [stalled-threshold (ct/minus threshold {:hours 1})]
(->> (db/plan conn [sql:get-upload-sessions threshold stalled-threshold threshold chunk-size]
{:fetch-size 5})
(reduce (fn [total {:keys [id]}]
(l/trc :obj "upload-session" :id (str id))
@ -71,8 +73,8 @@
SKIP LOCKED")
(defn- delete-profiles!
[{:keys [::db/conn ::timestamp ::chunk-size ::sto/storage] :as cfg}]
(->> (db/plan conn [sql:get-profiles timestamp chunk-size] {:fetch-size 5})
[{:keys [::db/conn ::timestamp ::threshold ::chunk-size ::sto/storage] :as cfg}]
(->> (db/plan conn [sql:get-profiles threshold chunk-size] {:fetch-size 5})
(reduce (fn [total {:keys [id photo-id]}]
(l/trc :obj "profile" :id (str id))
@ -99,8 +101,8 @@
SKIP LOCKED")
(defn- delete-teams!
[{:keys [::db/conn ::timestamp ::chunk-size ::sto/storage] :as cfg}]
(->> (db/plan conn [sql:get-teams timestamp chunk-size] {:fetch-size 5})
[{:keys [::db/conn ::threshold ::chunk-size ::sto/storage] :as cfg}]
(->> (db/plan conn [sql:get-teams threshold chunk-size] {:fetch-size 5})
(reduce (fn [total {:keys [id photo-id deleted-at]}]
(l/trc :obj "team"
:id (str id)
@ -126,8 +128,8 @@
SKIP LOCKED")
(defn- delete-fonts!
[{:keys [::db/conn ::timestamp ::chunk-size ::sto/storage] :as cfg}]
(->> (db/plan conn [sql:get-fonts timestamp chunk-size] {:fetch-size 5})
[{:keys [::db/conn ::threshold ::chunk-size ::sto/storage] :as cfg}]
(->> (db/plan conn [sql:get-fonts threshold chunk-size] {:fetch-size 5})
(reduce (fn [total {:keys [id team-id deleted-at] :as font}]
(l/trc :obj "font-variant"
:id (str id)
@ -156,8 +158,8 @@
SKIP LOCKED")
(defn- delete-projects!
[{:keys [::db/conn ::timestamp ::chunk-size] :as cfg}]
(->> (db/plan conn [sql:get-projects timestamp chunk-size] {:fetch-size 5})
[{:keys [::db/conn ::threshold ::chunk-size] :as cfg}]
(->> (db/plan conn [sql:get-projects threshold chunk-size] {:fetch-size 5})
(reduce (fn [total {:keys [id team-id deleted-at]}]
(l/trc :obj "project"
:id (str id)
@ -182,8 +184,8 @@
SKIP LOCKED")
(defn- delete-files!
[{:keys [::db/conn ::timestamp ::chunk-size] :as cfg}]
(->> (db/plan conn [sql:get-files timestamp chunk-size] {:fetch-size 5})
[{:keys [::db/conn ::threshold ::chunk-size] :as cfg}]
(->> (db/plan conn [sql:get-files threshold chunk-size] {:fetch-size 5})
(reduce (fn [total {:keys [id deleted-at project-id] :as file}]
(l/trc :obj "file"
:id (str id)
@ -206,8 +208,8 @@
SKIP LOCKED")
(defn delete-file-thumbnails!
[{:keys [::db/conn ::timestamp ::chunk-size ::sto/storage] :as cfg}]
(->> (db/plan conn [sql:get-file-thumbnails timestamp chunk-size] {:fetch-size 5})
[{:keys [::db/conn ::threshold ::chunk-size ::sto/storage] :as cfg}]
(->> (db/plan conn [sql:get-file-thumbnails threshold chunk-size] {:fetch-size 5})
(reduce (fn [total {:keys [file-id revn media-id deleted-at]}]
(l/trc :obj "file-thumbnail"
:file-id (str file-id)
@ -233,8 +235,8 @@
SKIP LOCKED")
(defn delete-file-object-thumbnails!
[{:keys [::db/conn ::timestamp ::chunk-size ::sto/storage] :as cfg}]
(->> (db/plan conn [sql:get-file-object-thumbnails timestamp chunk-size] {:fetch-size 5})
[{:keys [::db/conn ::threshold ::chunk-size ::sto/storage] :as cfg}]
(->> (db/plan conn [sql:get-file-object-thumbnails threshold chunk-size] {:fetch-size 5})
(reduce (fn [total {:keys [file-id object-id media-id deleted-at]}]
(l/trc :obj "file-object-thumbnail"
:file-id (str file-id)
@ -261,8 +263,8 @@
SKIP LOCKED")
(defn- delete-file-media-objects!
[{:keys [::db/conn ::timestamp ::chunk-size ::sto/storage] :as cfg}]
(->> (db/plan conn [sql:get-file-media-objects timestamp chunk-size] {:fetch-size 5})
[{:keys [::db/conn ::threshold ::chunk-size ::sto/storage] :as cfg}]
(->> (db/plan conn [sql:get-file-media-objects threshold chunk-size] {:fetch-size 5})
(reduce (fn [total {:keys [id file-id deleted-at] :as fmo}]
(l/trc :obj "file-media-object"
:id (str id)
@ -289,8 +291,8 @@
SKIP LOCKED")
(defn- delete-file-data!
[{:keys [::db/conn ::timestamp ::chunk-size] :as cfg}]
(->> (db/plan conn [sql:get-file-data timestamp chunk-size] {:fetch-size 5})
[{:keys [::db/conn ::threshold ::chunk-size] :as cfg}]
(->> (db/plan conn [sql:get-file-data threshold chunk-size] {:fetch-size 5})
(reduce (fn [total {:keys [file-id id type deleted-at metadata backend]}]
(some->> metadata
@ -323,8 +325,8 @@
SKIP LOCKED")
(defn- delete-file-changes!
[{:keys [::db/conn ::timestamp ::chunk-size] :as cfg}]
(->> (db/plan conn [sql:get-file-change timestamp chunk-size] {:fetch-size 5})
[{:keys [::db/conn ::threshold ::chunk-size] :as cfg}]
(->> (db/plan conn [sql:get-file-change threshold chunk-size] {:fetch-size 5})
(reduce (fn [total {:keys [id file-id deleted-at] :as xlog}]
(l/trc :obj "file-change"
:id (str id)
@ -352,9 +354,12 @@
#'delete-fonts!
#'delete-teams!])
(defn- execute-proc!
(defn- execute-proc
"A generic function that executes the specified proc iterativelly
until 0 results is returned"
until 0 results is returned. Heartbeats after each committed chunk so
a long backlog in a single proc cannot outrun the orphan lease
(mirrors storage/gc-deleted clean-deleted, which heartbeats per
chunk)."
[cfg proc-fn]
(loop [total 0]
(let [result (db/tx-run! cfg
@ -362,32 +367,59 @@
(db/exec-one! conn ["SET LOCAL rules.deletion_protection TO off"])
(proc-fn cfg)))]
(if (pos? result)
(recur (long (+ total result)))
(do
(jobs/heartbeat cfg)
(recur (long (+ total result))))
total))))
(defmethod ig/assert-key ::handler
(defmethod ig/assert-key ::job-def
[_ params]
(assert (db/pool? (::db/pool params)) "expected a valid database pool")
(assert (sto/valid-storage? (::sto/storage params)) "expected valid storage to be provided"))
(defmethod ig/expand-key ::handler
(defmethod ig/expand-key ::job-def
[k v]
{k (assoc v ::chunk-size 100)})
(declare execute-objects-gc)
(defmethod ig/init-key ::handler
(def schema:objects-gc-params
"Optional :skip-delay processes everything immediately, ignoring
deleted-at schedules (operator/repl escape hatch, mirrors
storage-gc-touched). Optional :chunk-size overrides the per-proc batch
size from config."
[:map {:closed true}
[:skip-delay {:optional true} :boolean]
[:chunk-size {:optional true} :int]])
(defmethod ig/init-key ::job-def
[_ cfg]
(fn [{:keys [props]}]
(let [skip-delay (:skip-delay props)
chunk-size (or (:chunk-size props) (::chunk-size cfg))
cfg (-> cfg
(assoc ::chunk-size chunk-size)
(assoc ::timestamp (if skip-delay
(ct/in-future {:days 3650})
(ct/now))))]
(loop [procs (map deref deletion-proc-vars)
total 0]
(if-let [proc-fn (first procs)]
(let [result (execute-proc! cfg proc-fn)]
(recur (rest procs)
(long (+ total result))))
{:processed total})))))
{::jobs/name :objects-gc
::jobs/schema schema:objects-gc-params
::jobs/handler
(fn [_context params]
(execute-objects-gc cfg params))
::jobs/decoder (sm/decoder schema:objects-gc-params sm/json-transformer)
::jobs/validator (sm/validator schema:objects-gc-params)})
(defn execute-objects-gc
"Plain job handler: garbage collect orphan storage objects."
([cfg] (execute-objects-gc cfg {}))
([cfg params]
(let [now (ct/now)
threshold (if (:skip-delay params)
(ct/in-future {:days 3650})
now)
cfg (assoc cfg
::timestamp now
::threshold threshold
::chunk-size (or (:chunk-size params)
(::chunk-size cfg)))]
(loop [procs (map deref deletion-proc-vars)
total 0]
(if-let [proc-fn (first procs)]
(let [result (execute-proc cfg proc-fn)]
(jobs/heartbeat cfg)
(recur (rest procs)
(long (+ total result))))
{:processed total})))))

35
backend/src/app/tasks/offload_file_data.clj
View File

@ -9,8 +9,10 @@
storage (the database row) to a cold storage (fs or s3)."
(:require
[app.common.logging :as l]
[app.common.schema :as sm]
[app.db :as db]
[app.features.fdata :as fdata]
[app.jobs :as jobs]
[app.storage :as sto]
[integrant.core :as ig]))
@ -23,6 +25,7 @@
(defn- offload-file-data
[cfg {:keys [id file-id type] :as fdata}]
(jobs/heartbeat cfg)
(fdata/upsert! cfg (assoc fdata :backend "storage"))
(l/trc :file-id (str file-id)
:id (str id)
@ -32,17 +35,31 @@
;; HANDLER
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod ig/assert-key ::handler
(defn execute-offload-file-data
"Plain job handler: offload the file data rows of one file."
[cfg params]
(let [file-id (:file-id params)]
(-> cfg
(assoc ::db/rollback (:rollback? params))
(db/tx-run! (fn [{:keys [::db/conn] :as cfg}]
(run! (partial offload-file-data cfg)
(db/plan conn [sql:get-file-data file-id])))))))
(def schema:offload-file-data-params
[:map
[:file-id ::sm/uuid]])
(defmethod ig/assert-key ::job-def
[_ params]
(assert (db/pool? (::db/pool params)) "expected a valid database pool")
(assert (sto/valid-storage? (::sto/storage params)) "expected valid storage to be provided"))
(defmethod ig/init-key ::handler
(defmethod ig/init-key ::job-def
[_ cfg]
(fn [{:keys [props] :as task}]
(let [file-id (:file-id props)]
(-> cfg
(assoc ::db/rollback (:rollback? props))
(db/tx-run! (fn [{:keys [::db/conn] :as cfg}]
(run! (partial offload-file-data cfg)
(db/plan conn [sql:get-file-data file-id]))))))))
{::jobs/name :offload-file-data
::jobs/schema schema:offload-file-data-params
::jobs/handler
(fn [_context params]
(execute-offload-file-data cfg params))
::jobs/decoder (sm/decoder schema:offload-file-data-params sm/json-transformer)
::jobs/validator (sm/validator schema:offload-file-data-params)})

39
backend/src/app/tasks/tasks_gc.clj
View File

@ -1,39 +0,0 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS SUBSIDIARY SL
(ns app.tasks.tasks-gc
"A maintenance task that performs a cleanup of already executed tasks
from the database table."
(:require
[app.common.logging :as l]
[app.config :as cf]
[app.db :as db]
[integrant.core :as ig]))
(def ^:private
sql:delete-completed-tasks
"DELETE FROM task WHERE scheduled_at < now() - ?::interval")
(defmethod ig/assert-key ::handler
[_ params]
(assert (db/pool? (::db/pool params)) "expected a valid database pool"))
(defmethod ig/expand-key ::handler
[k v]
{k (assoc v ::min-age (cf/get-deletion-delay))})
(defmethod ig/init-key ::handler
[_ {:keys [::min-age] :as cfg}]
(fn [{:keys [props] :as task}]
(let [min-age (or (:min-age props) min-age)]
(-> cfg
(assoc ::db/rollback (:rollback? props))
(db/tx-run! (fn [{:keys [::db/conn]}]
(let [interval (db/interval min-age)
result (db/exec-one! conn [sql:delete-completed-tasks interval])
result (db/get-update-count result)]
(l/debug :hint "task finished" :total result)
result)))))))

106
backend/src/app/tasks/telemetry.clj
View File

@ -12,9 +12,11 @@
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.common.schema :as sm]
[app.config :as cf]
[app.db :as db]
[app.http.client :as http]
[app.jobs :as jobs]
[app.main :as-alias main]
[app.setup :as-alias setup]
[app.util.json :as json]
@ -300,58 +302,76 @@
;; TASK ENTRY POINT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod ig/assert-key ::handler
(declare execute-telemetry)
(defmethod ig/assert-key ::job-def
[_ params]
(assert (http/client? (::http/client params)) "expected a valid http client")
(assert (db/pool? (::db/pool params)) "expected a valid database pool")
(assert (some? (::setup/props params)) "expected setup props to be available"))
(defmethod ig/init-key ::handler
(def schema:telemetry-params
[:map
[:send? {:optional true} :boolean]
[:enabled? {:optional true} :boolean]])
(defmethod ig/init-key ::job-def
[_ cfg]
(fn [task]
(let [params (:props task)
send? (get params :send? true)
enabled? (or (get params :enabled? false)
(contains? cf/flags :telemetry))
;; Deferred so the query runs only when a report is
;; actually going to be sent.
subs (delay (get-subscriptions cfg))]
{::jobs/name :telemetry
::jobs/schema schema:telemetry-params
::jobs/handler
(fn [_context params]
(execute-telemetry cfg params))
::jobs/decoder (sm/decoder schema:telemetry-params sm/json-transformer)
::jobs/validator (sm/validator schema:telemetry-params)})
;; If we have telemetry enabled, then proceed the normal
;; operation sending legacy report
(defn execute-telemetry
"Plain job handler: send periodic telemetry data."
[cfg params]
(let [send? (get params :send? true)
enabled? (or (get params :enabled? false)
(contains? cf/flags :telemetry))
;; Deferred so the query runs only when a report is
;; actually going to be sent.
subs (delay (get-subscriptions cfg))]
(if enabled?
(when send?
(db/run! cfg gc-events)
;; Randomize start time to avoid thundering herd when multiple
;; instances restart at the same time.
(px/sleep (rand-int 10000))
(jobs/heartbeat cfg)
;; If we have telemetry enabled, then proceed the normal
;; operation sending legacy report
(if enabled?
(when send?
(db/run! cfg gc-events)
;; Randomize start time to avoid thundering herd when multiple
;; instances restart at the same time.
(px/sleep (rand-int 10000))
(try
(let [stats (db/run! cfg get-legacy-stats)]
(send-legacy-data cfg stats @subs))
(catch Exception cause
(l/wrn :hint "unable to send legacy report"
:cause cause)))
;; Ship any anonymous audit-log events accumulated in
;; telemetry mode (only when audit-log feature is off).
(when-not (contains? cf/flags :audit-log)
(try
(let [stats (db/run! cfg get-legacy-stats)]
(send-legacy-data cfg stats @subs))
(db/run! cfg collect-and-send-audit-events)
(catch Exception cause
(l/wrn :hint "unable to send legacy report"
:cause cause)))
(l/wrn :hint "unable to send events"
:cause cause)))))
;; Ship any anonymous audit-log events accumulated in
;; telemetry mode (only when audit-log feature is off).
(when-not (contains? cf/flags :audit-log)
(try
(db/run! cfg collect-and-send-audit-events)
(catch Exception cause
(l/wrn :hint "unable to send events"
:cause cause)))))
;; If we have telemetry disabled, but there are users that are
;; explicitly checked the newsletter subscription on the
;; onboarding dialog or the profile section, then proceed to
;; send a limited telemetry data, that consists in the list of
;; subscribed emails and the running penpot version.
;; Official instances (penpot.dev / penpot.app) are excluded:
;; they must never send subscriber emails to the telemetry
;; endpoint (which is ourselves).
(when (and (not (cf/telemetry-excluded?)) send? @subs)
(px/sleep (rand-int 10000))
(ex/ignoring
(send-legacy-data cfg nil @subs)))))))
;; If we have telemetry disabled, but there are users that are
;; explicitly checked the newsletter subscription on the
;; onboarding dialog or the profile section, then proceed to
;; send a limited telemetry data, that consists in the list of
;; subscribed emails and the running penpot version.
;; Official instances (penpot.dev / penpot.app) are excluded:
;; they must never send subscriber emails to the telemetry
;; endpoint (which is ourselves).
(when (and (not (cf/telemetry-excluded?)) send? @subs)
(px/sleep (rand-int 10000))
(ex/ignoring
(send-legacy-data cfg nil @subs))))))

158
backend/src/app/worker.clj
View File

@ -5,145 +5,25 @@
;; Copyright (c) KALEIDOS SUBSIDIARY SL
(ns app.worker
"Async tasks abstraction (impl)."
"Conventions shared by the job execution machinery (impl).
Handlers that fail with a transient error can throw an exception with
`{:type ::retry}` in ex-data (optionally `:delay` with a duration or
milliseconds, and `:strategy ::noop` to retry without counting the
attempt); the runner will schedule the job for retry (respecting
max-retries) with exponential backoff. The public submit/invoke API
lives in `app.jobs`."
(:require
[app.common.data :as d]
[app.common.logging :as l]
[app.common.schema :as sm]
[app.common.time :as ct]
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
[app.metrics :as mtx]
[cuerdas.core :as str]
[integrant.core :as ig]))
[app.common.data :as d]))
(set! *warn-on-reflection* true)
(defn queue-key
"The Redis list the payloads of a queue travel through:
`penpot.worker.queue:<tenant>:<queue>`.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TASKS REGISTRY
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defprotocol IRegistry
(get-task [_ name]))
(defn- wrap-with-metrics
[f metrics tname]
(let [labels (into-array String [tname])]
(fn [params]
(let [tp (ct/tpoint)]
(try
(f params)
(finally
(mtx/run! metrics
{:id :tasks-timing
:val (inst-ms (tp))
:labels labels})))))))
(def ^:private schema:tasks
[:map-of :keyword ::sm/fn])
(def ^:private valid-tasks?
(sm/validator schema:tasks))
(defmethod ig/assert-key ::registry
[_ params]
(assert (mtx/metrics? (::mtx/metrics params)) "expected valid metrics instance")
(assert (valid-tasks? (::tasks params)) "expected a valid map of tasks"))
(defmethod ig/init-key ::registry
[_ {:keys [::mtx/metrics ::tasks]}]
(l/inf :hint "registry initialized" :tasks (count tasks))
(let [tasks (reduce-kv (fn [registry k f]
(let [tname (name k)]
(l/trc :hint "register task" :name tname)
(assoc registry tname (wrap-with-metrics f metrics tname))))
{}
tasks)]
(reify
clojure.lang.Counted
(count [_] (count tasks))
IRegistry
(get-task [_ name]
(get tasks (d/name name))))))
(sm/register!
{:type ::registry
:pred #(satisfies? IRegistry %)})
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SUBMIT API
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def ^:private sql:insert-new-task
"insert into task (id, name, props, queue, label, priority, max_retries, created_at, modified_at, scheduled_at)
values (?, ?, ?, ?, ?, ?, ?, ?, ?, ?)
returning id")
(def ^:private
sql:remove-not-started-tasks
"DELETE FROM task
WHERE name=?
AND queue=?
AND label=?
AND status = 'new'
AND scheduled_at > ?")
(def ^:private schema:options
[:map {:title "submit-options"}
[::task [:or ::sm/text :keyword]]
[::label {:optional true} ::sm/text]
[::delay {:optional true}
[:or ::sm/int ::ct/duration]]
[::queue {:optional true} [:or ::sm/text :keyword]]
[::priority {:optional true} ::sm/int]
[::max-retries {:optional true} ::sm/int]
[::dedupe {:optional true} ::sm/boolean]])
(def check-options!
(sm/check-fn schema:options))
(defn submit!
[& {:keys [::params ::task ::delay ::queue ::priority ::max-retries ::dedupe ::label]
:or {delay 0 queue :default priority 100 max-retries 3 label ""}
:as options}]
(check-options! options)
(let [delay (ct/duration delay)
now (ct/now)
scheduled-at (-> (ct/plus now delay)
(ct/truncate :millisecond))
props (db/tjson params)
id (uuid/next)
tenant (cf/get :tenant)
task (d/name task)
queue (str/ffmt "%:%" tenant (d/name queue))
conn (db/get-connectable options)
deleted (when dedupe
(-> (db/exec-one! conn [sql:remove-not-started-tasks task queue label now])
(db/get-update-count)))]
(l/trc :hint "submit task"
:name task
:task-id (str id)
:queue queue
:label label
:dedupe (boolean dedupe)
:delay (ct/format-duration delay)
:replace (or deleted 0))
(db/exec-one! conn [sql:insert-new-task id task props queue
label priority max-retries
now now scheduled-at])
id))
(defn invoke!
[{:keys [::task ::params] :as cfg}]
(assert (contains? cfg :app.worker/registry)
"missing worker registry on `cfg`")
(let [registry (get cfg ::registry)
task-fn (get-task registry task)]
(task-fn {:props params})))
The tenant prefix is what keeps two instances sharing one Redis from
handing each other jobs, and `job.queue` stores the bare queue name, so
the prefix has to be composed here. Three callers push or pop on it (the
dispatcher, the runner and `app.jobs/request`), so the shape lives in
one place."
[tenant queue]
(str "penpot.worker.queue:" tenant ":" (d/name queue)))

155
backend/src/app/worker/cron.clj
View File

@ -5,17 +5,28 @@
;; Copyright (c) KALEIDOS SUBSIDIARY SL
(ns app.worker.cron
"Cron pure scheduler: each tick claims the scheduled_task entry and
submits a system job (no profile_id, no user ledger) for it to the
dedicated `:cron` queue. Execution happens via the standard
dispatcher -> runner path, and so with the same lease, orphan
detection, retries and telemetry as for every other job. To keep the
no-overlap semantics (one entry is not re-fired while the previous
instance lives), the scheduler only submits when there is no active
instance (`new`/`scheduled`/`running`/`retry` with the same `name`
and `label` of the entry). The `FOR UPDATE SKIP LOCKED` claim on the
scheduled_task row already serializes the tick between nodes."
(:require
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.common.schema :as sm]
[app.common.time :as ct]
[app.config :as cf]
[app.db :as db]
[app.jobs :as jobs]
[app.jobs.metrics :as metrics]
[app.metrics :as-alias mtx]
[app.util.cron :as cron]
[app.worker :as wrk]
[app.worker.runner :refer [get-error-context]]
[cuerdas.core :as str]
[app.worker :as-alias wrk]
[integrant.core :as ig]
[promesa.core :as p]
[promesa.exec :as px])
@ -30,7 +41,19 @@
on conflict (id)
do nothing")
(defn- synchronize-cron-entries!
;; The tenant filter is what makes the no-overlap check per instance: the
;; job this count decides about is submitted to this tenant's queue, so
;; counting other tenants' active jobs would let one instance skip a tick
;; for work that is none of its business.
(def ^:private sql:count-active-jobs
"SELECT count(*) AS n
FROM job
WHERE name = ?
AND label = ?
AND tenant = ?
AND status IN ('new','scheduled','running','retry')")
(defn- synchronize-cron-entries
[{:keys [::db/conn ::entries]}]
(doseq [{:keys [id cron]} entries]
(let [result (db/exec-one! conn [sql:upsert-cron-task id (str cron)])
@ -38,48 +61,86 @@
(l/dbg :hint "register task" :id id :cron (str cron)
:status (if updated? "created" "exists")))))
(defn- lock-scheduled-task!
(defn- lock-scheduled-task
[conn id]
(let [sql (str "SELECT id FROM scheduled_task "
" WHERE id=? FOR UPDATE SKIP LOCKED")]
(some? (db/exec-one! conn [sql (d/name id)]))))
(defn submit-cron-job
"Submit the system job for the entry to the `:cron` queue. Uses the
entry id as the job label (stable per entry) and returns the created
job-id. No-overlap pre-check lives in the caller."
[cfg {:keys [job props id]}]
(jobs/submit
cfg
{::jobs/name job
::jobs/params (or props {}) ;; entries don't carry props; default to empty map
::jobs/queue :cron
::jobs/label (name id)}))
(declare ^:private schedule-cron-task)
(defn- execute-cron-task
[cfg {:keys [id cron] :as task}]
"Tick thread for one entry: claim the scheduled_task row and submit
the system job; no in-process execution of the handler here."
[cfg {:keys [id cron job] :as entry}]
(px/thread
{:name (str "penpot/cron-task/" id)}
(let [tpoint (ct/tpoint)]
(try
(db/tx-run! cfg (fn [{:keys [::db/conn]}]
(db/tx-run! cfg (fn [{:keys [::db/conn] :as cfg}]
(db/exec-one! conn ["SET LOCAL statement_timeout=0;"])
(db/exec-one! conn ["SET LOCAL idle_in_transaction_session_timeout=0;"])
(when (lock-scheduled-task! conn id)
(when (lock-scheduled-task conn id)
(db/update! conn :scheduled-task
{:cron-expr (str cron)
:modified-at (ct/now)}
{:id id}
{::db/return-keys false})
(l/dbg :hint "start" :id id)
((:fn task) task)
(let [elapsed (ct/format-duration (tpoint))]
(l/dbg :hint "end" :id id :elapsed elapsed)))))
;; The count query is not locked, so a job could
;; transition from running to completed between the
;; count and the submit. This is acceptable: the
;; next tick will submit if needed. The FOR UPDATE
;; SKIP LOCKED on the scheduled_task row prevents
;; race conditions between nodes.
(let [tenant (cf/get :tenant)
row (db/exec-one! conn [sql:count-active-jobs (d/name job) (str id) tenant])
active (or (get row :n) 0)]
(if (pos? active)
(do
(db/after-commit #(metrics/record-cron cfg :skipped :active))
(l/dbg :hint "skip"
:reason "scheduling, active instance exists"
:id id :job (d/name job)))
(let [job-id (submit-cron-job cfg entry)
elapsed (ct/format-duration (tpoint))]
(db/after-commit #(metrics/record-cron cfg :submitted :none))
(l/dbg :hint "submit"
:id id
:job (d/name job)
:job-id (str job-id)
:elapsed elapsed)))))))
(catch InterruptedException _
(metrics/record-cron cfg :error :interrupted)
(let [elapsed (ct/format-duration (tpoint))]
(l/debug :hint "task interrupted" :id id :elapsed elapsed)))
(catch Throwable cause
(let [elapsed (ct/format-duration (tpoint))]
(binding [l/*context* (get-error-context cause task)]
(metrics/record-cron cfg :error :failure)
(let [elapsed (ct/format-duration (tpoint))
context (assoc (cf/logging-context) :params entry)]
(binding [l/*context* context]
(l/err :hint "unhandled exception on running task"
:id id
:elapsed elapsed
:cause cause))))
(finally
(when-not (px/interrupted? :current)
(schedule-cron-task cfg task)))))))
(schedule-cron-task cfg entry)))))))
(defn- ms-until-valid
[cron]
@ -89,9 +150,9 @@
(ct/diff now next)))
(defn- schedule-cron-task
[{:keys [::running] :as cfg} {:keys [cron id] :as task}]
[{:keys [::running] :as cfg} {:keys [cron id] :as entry}]
(let [ts (ms-until-valid cron)
ft (px/schedule! ts (partial execute-cron-task cfg task))]
ft (px/schedule! ts (partial execute-cron-task cfg entry))]
(l/dbg :hint "schedule" :id id
:ts (ct/format-duration ts)
@ -106,48 +167,51 @@
[:maybe
[:map
[:cron [:fn cron/cron-expr?]]
[:task :keyword]
[:job :keyword]
[:props {:optional true} :map]
[:id {:optional true} :keyword]]]]]
::wrk/registry
::db/pool])
::jobs/defs
::db/pool
::mtx/metrics])
(defmethod ig/assert-key ::wrk/cron
[_ params]
(assert (sm/check schema:params params)))
(defmethod ig/init-key ::wrk/cron
[_ {:keys [::wrk/entries ::wrk/registry ::db/pool] :as cfg}]
[_ {:keys [::wrk/entries ::jobs/defs ::db/pool] :as cfg}]
(if (db/read-only? pool)
(l/wrn :hint "service not started (db is read-only)")
(let [running (atom #{})
entries (->> entries
(filter some?)
;; If id is not defined, use the task as id.
(map (fn [{:keys [id task] :as item}]
(if (some? id)
(assoc item :id (d/name id))
(assoc item :id (d/name task)))))
(map (fn [item]
(update item :task d/name)))
(map (fn [{:keys [task] :as item}]
(let [f (wrk/get-task registry task)]
(when-not f
(ex/raise :type :internal
:code :task-not-found
:hint (str/fmt "task %s not configured" task)))
(-> item
(dissoc :task)
(assoc :fn f))))))
cfg (assoc cfg ::entries entries ::running running)]
;; doall sits outside the threading: it forces the lazy
;; validation above (unknown job names fail fast here).
;; NOTE: it must not go inside ->> — the threaded value
;; would land as doall's count arg and explode.
entries (doall
(->> entries
(filter some?)
;; If id is not defined, use the job as id.
;; The job stays a keyword (the canonical job
;; name): only the id is stringified, because it
;; becomes the job label and the scheduled_task
;; row id.
(map (fn [{:keys [id job] :as item}]
(if (some? id)
(assoc item :id (d/name id))
(assoc item :id (d/name job)))))
(map (fn [item]
;; fail fast when the entry references
;; an unknown job name
(jobs/get-job-def defs (:job item))
item))))]
(l/inf :hint "started" :tasks (count entries))
(db/tx-run! cfg synchronize-cron-entries!)
(let [cfg (assoc cfg ::entries entries ::running running)]
(db/tx-run! cfg synchronize-cron-entries)
(->> (filter some? entries)
(run! (partial schedule-cron-task cfg)))
(->> (filter some? entries)
(run! (partial schedule-cron-task cfg))))
(reify
clojure.lang.IDeref
@ -163,4 +227,3 @@
(defmethod ig/halt-key! ::wrk/cron
[_ instance]
(some-> instance d/close!))

319
backend/src/app/worker/dispatcher.clj
View File

@ -7,15 +7,17 @@
(ns app.worker.dispatcher
(:require
[app.common.data :as d]
[app.common.json :as json]
[app.common.logging :as l]
[app.common.schema :as sm]
[app.common.time :as ct]
[app.common.transit :as t]
[app.config :as cf]
[app.db :as db]
[app.jobs :as jobs]
[app.jobs.metrics :as metrics]
[app.metrics :as mtx]
[app.redis :as rds]
[app.worker :as-alias wrk]
[cuerdas.core :as str]
[app.worker :as wrk]
[integrant.core :as ig]
[promesa.exec :as px])
(:import
@ -26,6 +28,7 @@
(def ^:private schema:dispatcher
[:map
[::wrk/tenant ::sm/text]
[::lease {:optional true} ::ct/duration]
::mtx/metrics
::db/pool
::rds/client])
@ -35,154 +38,232 @@
{k (-> (d/without-nils v)
(assoc ::timeout (ct/duration "10s"))
(assoc ::batch-size 100)
(assoc ::wait-duration (ct/duration "5s")))})
(assoc ::wait-duration (ct/duration "5s"))
(assoc ::lease (cf/get-jobs-lease)))})
(defmethod ig/assert-key ::wrk/dispatcher
[_ cfg]
(assert (sm/check schema:dispatcher cfg)))
(def ^:private sql:select-next-tasks
"SELECT id, queue, scheduled_at from task AS t
(def ^:private sql:select-next-jobs
"SELECT id, name, queue, scheduled_at from job AS t
WHERE t.scheduled_at <= ?::timestamptz
AND (t.status = 'new' OR t.status = 'retry')
AND queue ~~* ?::text
AND t.tenant = ?
ORDER BY t.priority DESC, t.scheduled_at
LIMIT ?
FOR UPDATE
SKIP LOCKED")
(def ^:private sql:mark-task-scheduled
"UPDATE task SET status = 'scheduled'
(def ^:private sql:mark-job-scheduled
"UPDATE job SET status = 'scheduled', modified_at = ?
WHERE id = ANY(?)")
;; Both sweeps are bulk UPDATEs that run before every dispatch batch, so
;; they are the two queries where a missing tenant filter does the most
;; damage: without it any instance with a worker requeues another
;; instance's scheduled rows and, worse, aborts its running jobs once
;; their lease expires.
(def ^:private sql:reschedule-lost
"UPDATE task
"UPDATE job
SET status='new', scheduled_at=?::timestamptz
FROM (SELECT t.id
FROM task AS t
FROM job AS t
WHERE status = 'scheduled'
AND (?::timestamptz - t.scheduled_at) > '5 min'::interval) AS subquery
WHERE task.id=subquery.id
RETURNING task.id, task.queue")
AND t.tenant = ?
AND t.scheduled_at < ?::timestamptz - '5 min'::interval) AS subquery
WHERE job.id=subquery.id
RETURNING job.id, job.queue")
(def ^:private sql:clean-orphan
"UPDATE task
SET status='failed', modified_at=?::timestamptz,
error='orphan with running status'
(def ^:private sql:mark-orphan
"UPDATE job
SET status='aborted', modified_at=?::timestamptz, error=?::jsonb
FROM (SELECT t.id
FROM task AS t
FROM job AS t
WHERE status = 'running'
AND (?::timestamptz - t.modified_at) > '24 hour'::interval) AS subquery
WHERE task.id=subquery.id
RETURNING task.id, task.queue")
AND t.tenant = ?
AND t.modified_at < ?::timestamptz) AS subquery
WHERE job.id=subquery.id
RETURNING job.id, job.queue, job.name, job.created_at")
;; the error travels as text and PostgreSQL casts it: a PGobject parameter
;; on a `::jsonb` placeholder is not what the driver expects here. Same
;; for the orphan `end` event payload below.
(def ^:private orphan-error-json
(json/encode jobs/orphan-error))
(def ^:private aborted-outcome-json
(json/encode {:outcome "aborted"}))
(def ^:private sql:insert-orphan-events
"INSERT INTO job_event (job_id, kind, payload)
SELECT unnest(?::uuid[]), 'end', ?::jsonb")
(defn- encode-payload
[{:keys [id scheduled-at]}]
(json/encode [(str id) (ct/format-inst scheduled-at)]))
(defn- reschedule-lost-jobs
[{:keys [::db/conn ::timestamp ::wrk/tenant] :as cfg}]
(let [rows (db/exec! conn [sql:reschedule-lost timestamp tenant timestamp]
{:return-keys true})]
(db/after-commit
(fn []
(doseq [{:keys [id queue]} rows]
(metrics/record-rescheduled cfg queue)
(l/wrn :hint "reschedule"
:id (str id)
:tenant tenant
:queue queue))))))
(defn- mark-orphan-jobs
[{:keys [::db/conn ::timestamp ::lease ::wrk/tenant] :as cfg}]
(let [cutoff (ct/minus timestamp (or lease (cf/get-jobs-lease)))
rows (db/exec! conn [sql:mark-orphan timestamp orphan-error-json
tenant cutoff]
{:return-keys true})]
;; The sweep is the only status change outside `app.jobs`, so it owns
;; its `end` events too: one bulk insert in the same transaction (never
;; one insert per orphan) keeps the history consistent with the rows.
;; No msgbus notification: orphans alert through the error log and the
;; orphaned counter, like before.
(when (seq rows)
(db/exec-one! conn [sql:insert-orphan-events
(db/create-array conn "uuid" (map :id rows))
aborted-outcome-json]))
(db/after-commit
(fn []
(doseq [{:keys [id queue name created-at]} rows]
(metrics/record-orphan cfg queue)
(metrics/record-outcome cfg name queue :aborted)
(when (ct/inst? created-at)
(metrics/record-total cfg name queue :aborted
(- (inst-ms timestamp) (inst-ms created-at))))
(l/err :hint "marked job as aborted (orphan lease expired)"
:id (str id)
:tenant tenant
:queue queue))))))
(defn- get-jobs
[{:keys [::db/conn ::timestamp ::batch-size ::wrk/tenant]}]
(let [result (db/exec! conn [sql:select-next-jobs timestamp tenant batch-size])]
(not-empty result)))
(defn- mark-as-scheduled
[{:keys [::db/conn]} items]
(let [ids (map :id items)
sql [sql:mark-job-scheduled
(ct/now)
(db/create-array conn "uuid" ids)]]
(db/exec-one! conn sql)))
(defn- push-jobs
[{:keys [::rds/conn ::wrk/tenant] :as cfg} [queue jobs]]
;; Mark first, push last: a crash between mark and push leaves a
;; `scheduled` row that reschedule-lost-jobs re-queues, while the
;; reverse order leaves a duplicate payload nothing deduplicates.
(mark-as-scheduled cfg jobs)
(let [items (mapv encode-payload jobs)
key (wrk/queue-key tenant queue)]
(rds/rpush conn key items)
(metrics/record-dispatcher-size cfg queue (count jobs))
(doseq [{:keys [id name queue]} jobs]
(metrics/record-dispatched cfg name queue 1)
(l/trc :hist "schedule"
:tenant tenant
:queue queue
:job-id (str id)))))
(defn- run-batch'
[cfg]
(let [cfg (assoc cfg ::timestamp (ct/now))
tpoint (ct/tpoint)]
;; Reschedule lost in transit jobs (can happen when
;; redis server is restarted just after job is pushed)
(reschedule-lost-jobs cfg)
;; Mark as aborted all jobs that are still marked as running but
;; their last modification (heartbeat or progress) is older than
;; the configured lease
(mark-orphan-jobs cfg)
;; Then, schedule the next jobs in queue
(let [result (if-let [jobs (get-jobs cfg)]
(do
(->> (group-by :queue jobs)
(run! (partial push-jobs cfg)))
nil)
;; If no jobs found on this batch run, we signal the
;; run-loop to wait for some time before start running
;; the next batch iteration
::wait)]
(db/after-commit
#(metrics/record-dispatcher-batch cfg :dispatch :completed (inst-ms (tpoint))))
result)))
(defn- sleep-after-error
[cfg]
(px/sleep (or (::timeout cfg) (ct/duration "10s"))))
(defn run-batch
"Execute a single dispatch batch: reschedule lost jobs, mark orphans
(lease-based) and claim pending jobs into their Redis queues. Exposed
as a function for testability; the dispatcher thread loops on it."
[cfg]
(let [tpoint (ct/tpoint)
tenant (::wrk/tenant cfg)]
(try
(let [rconn (rds/connect cfg)]
(try
(-> cfg
(assoc ::rds/conn rconn)
(db/tx-run! run-batch'))
(finally
(.close ^AutoCloseable rconn))))
(catch InterruptedException cause
(throw cause))
(catch Exception cause
(cond
(rds/exception? cause)
(do
(metrics/record-dispatcher-batch cfg :redis :failed (inst-ms (tpoint)))
(l/wrn :hint "redis exception (will retry in an instant)" :tenant tenant :cause cause)
(sleep-after-error cfg))
(db/sql-exception? cause)
(do
(metrics/record-dispatcher-batch cfg :database :failed (inst-ms (tpoint)))
(l/wrn :hint "database exception (will retry in an instant)" :tenant tenant :cause cause)
(sleep-after-error cfg))
:else
(do
(metrics/record-dispatcher-batch cfg :execution :failed (inst-ms (tpoint)))
(l/err :hint "unhandled exception (will retry in an instant)" :tenant tenant :cause cause)
(sleep-after-error cfg)))))))
(defmethod ig/init-key ::wrk/dispatcher
[_ {:keys [::db/pool ::wrk/tenant ::batch-size ::timeout] :as cfg}]
(letfn [(reschedule-lost-tasks [{:keys [::db/conn ::timestamp]}]
(doseq [{:keys [id queue]} (db/exec! conn [sql:reschedule-lost timestamp timestamp]
{:return-keys true})]
(l/wrn :hint "reschedule"
:id (str id)
:queue queue)))
(clean-orphan [{:keys [::db/conn ::timestamp]}]
(doseq [{:keys [id queue]} (db/exec! conn [sql:clean-orphan timestamp timestamp]
{:return-keys true})]
(l/wrn :hint "mark as orphan failed"
:id (str id)
:queue queue)))
(get-tasks [{:keys [::db/conn ::timestamp] :as cfg}]
(let [prefix (str tenant ":%")
result (db/exec! conn [sql:select-next-tasks timestamp prefix batch-size])]
(not-empty result)))
(mark-as-scheduled [{:keys [::db/conn]} items]
(let [ids (map :id items)
sql [sql:mark-task-scheduled
(db/create-array conn "uuid" ids)]]
(db/exec-one! conn sql)))
(push-tasks [{:keys [::rds/conn] :as cfg} [queue tasks]]
(let [items (mapv (juxt :id :scheduled-at) tasks)
key (str/ffmt "penpot.worker.queue:%" queue)]
(rds/rpush conn key (mapv t/encode-str items))
(mark-as-scheduled cfg tasks)
(doseq [{:keys [id queue]} tasks]
(l/trc :hist "schedule"
:id (str id)
:queue queue))))
(run-batch' [cfg]
(let [cfg (assoc cfg ::timestamp (ct/now))]
;; Reschedule lost in transit tasks (can happen when
;; redis server is restarted just after task is pushed)
(reschedule-lost-tasks cfg)
;; Mark as failed all tasks that are still marked as
;; running but it's been more than 24 hours since its
;; last modification
(clean-orphan cfg)
;; Then, schedule the next tasks in queue
(if-let [tasks (get-tasks cfg)]
(->> (group-by :queue tasks)
(run! (partial push-tasks cfg)))
;; If no tasks found on this batch run, we signal the
;; run-loop to wait for some time before start running
;; the next batch interation
::wait)))
(run-batch []
(try
(let [rconn (rds/connect cfg)]
(try
(-> cfg
(assoc ::rds/conn rconn)
(db/tx-run! run-batch'))
(finally
(.close ^AutoCloseable rconn))))
(catch InterruptedException cause
(throw cause))
(catch Exception cause
(cond
(rds/exception? cause)
(do
(l/wrn :hint "redis exception (will retry in an instant)" :cause cause)
(px/sleep timeout))
(db/sql-exception? cause)
(do
(l/wrn :hint "database exception (will retry in an instant)" :cause cause)
(px/sleep timeout))
:else
(do
(l/err :hint "unhandled exception (will retry in an instant)" :cause cause)
(px/sleep timeout))))))
(dispatcher []
(l/inf :hint "started")
[_ {:keys [::db/pool ::wait-duration ::wrk/tenant] :as cfg}]
(letfn [(dispatcher []
(l/inf :hint "started" :tenant tenant)
(try
(loop []
(let [result (run-batch)]
(let [result (run-batch cfg)]
(when (= result ::wait)
(px/sleep (::wait-duration cfg)))
(px/sleep wait-duration))
(recur)))
(catch InterruptedException _
(l/trc :hint "interrupted"))
(l/trc :hint "interrupted" :tenant tenant))
(catch Throwable cause
(l/err :hint "unexpected exception" :cause cause))
(l/err :hint "unexpected exception" :tenant tenant :cause cause))
(finally
(l/inf :hint "terminated"))))]
(l/inf :hint "terminated" :tenant tenant))))]
(if (db/read-only? pool)
(l/wrn :hint "not started (db is read-only)")
(l/wrn :hint "not started (db is read-only)" :tenant tenant)
(px/fn->thread dispatcher :name "penpot/worker-dispatcher"))))
(defmethod ig/halt-key! ::wrk/dispatcher

388
backend/src/app/worker/runner.clj
View File

@ -5,17 +5,21 @@
;; Copyright (c) KALEIDOS SUBSIDIARY SL
(ns app.worker.runner
"Async tasks abstraction (impl)."
"Job execution over the unified `job` table (impl)."
(:require
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.json :as json]
[app.common.logging :as l]
[app.common.schema :as sm]
[app.common.time :as ct]
[app.common.transit :as t]
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
[app.jobs :as jobs]
[app.jobs.metrics :as jobs-metrics]
[app.metrics :as mtx]
[app.msgbus :as-alias mbus]
[app.redis :as rds]
[app.worker :as wrk]
[cuerdas.core :as str]
@ -26,232 +30,292 @@
(set! *warn-on-reflection* true)
(def schema:task
[:map {:title "Task"}
[:id ::sm/uuid]
[:queue :string]
[:name :string]
[:created-at ::ct/inst]
[:modified-at ::ct/inst]
[:scheduled-at {:optional true} ::ct/inst]
[:completed-at {:optional true} ::ct/inst]
[:error {:optional true} :string]
[:max-retries :int]
[:retry-num :int]
[:priority :int]
[:status [:enum "scheduled" "running" "completed" "new" "retry" "failed"]]
[:label {:optional true} :string]
[:props :map]])
(defn- claim-job
"Conditional claim: only transition pending jobs (new/scheduled/retry)
to running. Delegates to the shared jobs/claim so internal and
external workers can never drift. A cancelled, aborted or otherwise
terminal job produces
0 affected rows and is skipped without touching its state
(first-terminal-wins companion). Also predicates the payload
scheduled_at: a row rescheduled after the payload was pushed
(dispatcher re-pushes on reschedule) is never claimed with the stale
payload."
[cfg job-id scheduled-at]
(jobs/claim cfg job-id scheduled-at))
(def schema:result
[:map {:title "TaskResult"}
[:status [:enum "retry" "failed" "completed"]]
[:error {:optional true} [:fn ex/exception?]]
[:inc-by {:optional true} :int]
[:delay {:optional true} :int]])
(defn- get-exception-type
"Extract a human-readable exception type for observability."
[error]
(cond
(and (ex/exception? error) (instance? clojure.lang.ExceptionInfo error))
(or (:type (ex-data error)) :ex-info)
(def valid-task-result?
(sm/validator schema:result))
(instance? java.util.concurrent.TimeoutException error)
:timeout
(defn- decode-task-row
[{:keys [props] :as row}]
(cond-> row
(db/pgobject? props)
(assoc :props (db/decode-transit-pgobject props))))
(instance? java.sql.SQLTimeoutException error)
:timeout
(defn get-error-context
[_ item]
(-> (cf/logging-context)
(assoc :params item)))
:else
(keyword (str/lower (.getSimpleName (class error))))))
(defn- get-task
[{:keys [::db/pool]} task-id]
(defn- error-report
"Build the error stored in `job.error` out of an exception, conforming to
`app.jobs/schema:job-error`. The exception type and its own type/code are
kept as extra details for triage, on top of the three contract keys."
[error]
(let [data (ex-data error)
as-keyword (fn [v]
(cond (keyword? v) v
(string? v) (keyword v)))]
(jobs/check-job-error
{:type (or (as-keyword (:type data)) :internal)
:code (or (as-keyword (:code data)) :failed)
:hint (or (:hint data)
(when (ex/exception? error) (ex-message error))
(str error))
:ex-type (get-exception-type error)})))
;; A handler result may be the reserved completion envelope, which carries
;; the storage object the job produced. The key is reserved: a handler that
;; wants to return a business map with :resource-id in it cannot.
(defn- completion-envelope?
[result]
(and (map? result) (contains? result :resource-id)))
(defn- get-job
"Fetch the job row (params kept as raw pgobject; decoded later with the
job-def decoder)."
[cfg job-id]
(ex/try!
(some-> (db/get* pool :task {:id task-id})
(decode-task-row))))
(some-> (db/get* cfg :job {:id job-id}))))
(defn- run-task
[{:keys [::db/pool ::wrk/registry ::id ::queue] :as cfg} task]
(defn- execute-job
[{:keys [::jobs/defs ::id ::queue ::wrk/tenant] :as cfg} job]
(try
(l/dbg :hint "start"
:name (:name task)
:task-id (str (:id task))
:name (:name job)
:job-id (str (:id job))
:tenant tenant
:queue queue
:runner-id id
:retry (:retry-num task))
:retry (:retry-num job))
;; Mark task as running
(db/update! pool :task
{:status "running"
:modified-at (ct/now)}
{:id (:id task)}
{::db/return-keys false})
(let [tpoint (ct/tpoint)
task-fn (wrk/get-task registry (:name task))
result (when task-fn (task-fn task))
elapsed (ct/format-duration (tpoint))
result (if (valid-task-result? result)
result
{:status "completed"})]
(when-not task-fn
(l/wrn :hint "no task handler found" :name (:name task)))
(l/dbg :hint "end"
:name (:name task)
:task-id (str (:id task))
(if (zero? (claim-job cfg (:id job) (:scheduled-at job)))
(l/wrn :hint "skipping job, not claimable"
:id (str (:id job))
:name (:name job)
:tenant tenant
:queue queue
:runner-id id
:retry (:retry-num task)
:elapsed elapsed)
:status (:status job))
result)
(do
(let [job-def (jobs/get-job-def defs (:name job))
_ (jobs-metrics/record-queue-wait
cfg
(::jobs/name job-def)
queue
(- (inst-ms (ct/now)) (inst-ms (:scheduled-at job))))
params (try
(->> (:params job)
(jobs/decode-params job-def)
(jobs/validate-params job-def))
(catch Throwable cause
;; Decode/validation of stored params is pure: any
;; failure here is permanent (e.g. schema tightened
;; after submit), never transient. Tag it so the
;; generic catch below fails fast instead of
;; burning max-retries.
(throw (ex-info "job params failed validation"
{:type :assertion
:code :data-validation}
cause))))
handler (::jobs/handler job-def)
context (jobs/make-context job)
tpoint (ct/tpoint)
result (binding [jobs/*job-id* (:id job)]
(try
(handler context params)
(finally
(jobs-metrics/record-execution
cfg
(:name job)
queue
(inst-ms (tpoint)))
(jobs-metrics/record-legacy-execution
cfg
(:name job)
(inst-ms (tpoint))))))]
(l/dbg :hint "end"
:name (:name job)
:job-id (str (:id job))
:tenant tenant
:queue queue
:runner-id id
:retry (:retry-num job)
:elapsed (ct/format-duration (tpoint)))
{:status "completed"
:result result})))
(catch InterruptedException cause
(throw cause))
(catch Throwable cause
(let [edata (ex-data cause)]
(if (and (< (:retry-num task)
(:max-retries task))
(= ::retry (:type edata)))
(if (and (< (:retry-num job)
(:max-retries job))
(= ::wrk/retry (:type edata)))
(cond-> {:status "retry" :error cause}
(ct/duration? (:delay edata))
(assoc :delay (:delay edata))
(assoc :delay-ms (inst-ms (:delay edata)))
(int? (:delay edata))
(assoc :delay-ms (:delay edata))
(= ::noop (:strategy edata))
(= ::wrk/noop (:strategy edata))
(assoc :inc-by 0))
(do
(l/err :hint "unhandled exception on task"
::l/context (get-error-context cause task)
(l/err :hint "unhandled exception on job"
::l/context (assoc (cf/logging-context) :params job)
:tenant tenant
:cause cause)
(if (>= (:retry-num task) (:max-retries task))
;; Unknown job names and invalid params never heal by retrying
;; (no rolling deploy will register them on this backend), so
;; they fail fast without burning max-retries or churning
;; modified_at.
(if (or (>= (:retry-num job) (:max-retries job))
(contains? #{:no-job-definition :data-validation}
(:code edata)))
{:status "failed" :error cause}
{:status "retry" :error cause})))))))
{:status "retry" :error cause})))))
(finally
(jobs/cleanup-throttle (:id job)))))
(defn- run-task!
[{:keys [::id ::timeout] :as cfg} task-id scheduled-at]
(loop [task (get-task cfg task-id)]
(defn- run-job
[{:keys [::id ::timeout ::wrk/tenant] :as cfg} job-id scheduled-at]
(loop [job (get-job cfg job-id)]
(cond
(nil? task)
(l/wrn :hint "no task found on the database"
(nil? job)
(l/wrn :hint "no job found on the database"
:runner-id id
:task-id task-id)
:tenant tenant
:job-id (str job-id))
(ex/exception? task)
(if (or (db/connection-error? task)
(db/serialization-error? task))
(ex/exception? job)
(if (or (db/connection-error? job)
(db/serialization-error? job))
(do
(l/wrn :hint "connection error on retrieving task from database (retrying in some instants)"
(l/wrn :hint "connection error on retrieving job from database (retrying in some instants)"
:runner-id id
:cause task)
:tenant tenant
:cause job)
(px/sleep timeout)
(recur (get-task cfg task-id)))
(recur (get-job cfg job-id)))
(do
(l/err :hint "unhandled exception on retrieving task from database (retrying in some instants)"
(l/err :hint "unhandled exception on retrieving job from database (retrying in some instants)"
:runner-id id
:cause task)
:tenant tenant
:cause job)
(px/sleep timeout)
(recur (get-task cfg task-id))))
(recur (get-job cfg job-id))))
(not= (inst-ms scheduled-at)
(inst-ms (:scheduled-at task)))
(l/wrn :hint "skiping task, rescheduled"
:task-id task-id
(inst-ms (:scheduled-at job)))
(l/wrn :hint "skipping job, rescheduled"
:job-id (str job-id)
:runner-id id
:scheduled-at (ct/format-inst (:scheduled-at task))
:tenant tenant
:scheduled-at (ct/format-inst (:scheduled-at job))
:expected-scheduled-at (ct/format-inst scheduled-at))
:else
(let [result (run-task cfg task)]
(let [result (execute-job cfg job)]
(with-meta result
{::task task})))))
{::job job})))))
(defn- run-worker-loop!
[{:keys [::db/pool ::rds/conn ::timeout ::queue] :as cfg}]
(letfn [(handle-task-retry [{:keys [error inc-by delay] :or {inc-by 1 delay 1000} :as result}]
(let [explain (if (ex/exception? error)
(ex-message error)
(str error))
task (-> result meta ::task)
nretry (+ (:retry-num task) inc-by)
now (ct/now)
delay (->> (iterate #(* % 2) delay) (take nretry) (last))]
(db/update! pool :task
{:error explain
:status "retry"
:modified-at now
:scheduled-at (-> (ct/plus now delay)
(ct/truncate :millisecond))
:retry-num nretry}
{:id (:id task)})
(defn- run-worker-loop
[{:keys [::rds/conn ::timeout ::queue ::wrk/tenant] :as cfg}]
(letfn [(handle-job-retry [{:keys [error delay-ms inc-by] :or {inc-by 1 delay-ms 1000} :as result}]
(let [job (-> result meta ::job)
nretry (+ (:retry-num job) inc-by)
now (ct/now)
delay (->> (iterate #(* 2 %) delay-ms) (take (max 1 nretry)) (last))]
(jobs/retry-job cfg
(:id job)
nretry
(-> (ct/plus now (ct/duration {:millis delay}))
(ct/truncate :millisecond))
(error-report error)
(if (zero? inc-by) :noop :backoff))
nil))
(handle-task-failure [{:keys [error] :as result}]
(let [task (-> result meta ::task)
explain (ex-message error)]
(db/update! pool :task
{:error explain
:modified-at (ct/now)
:status "failed"}
{:id (:id task)})
(handle-job-failure [{:keys [error] :as result}]
(let [job (-> result meta ::job)]
(jobs/fail cfg (:id job) (error-report error))
nil))
(handle-task-completion [result]
(let [task (-> result meta ::task)
now (ct/now)]
(db/update! pool :task
{:completed-at now
:modified-at now
:error nil
:status "completed"}
{:id (:id task)})
(handle-job-completion [result]
(let [job (-> result meta ::job)
returned (:result result)
envelope? (completion-envelope? returned)]
(jobs/complete cfg
:job-id (:id job)
:result (if envelope? (:result returned) returned)
:resource-id (when envelope? (:resource-id returned)))
nil))
(decode-payload [payload]
(try
(let [[task-id scheduled-at :as payload] (t/decode-str payload)]
(if (and (uuid? task-id)
(ct/inst? scheduled-at))
payload
(l/err :hint "received unexpected payload"
:payload payload)))
(let [payload (json/decode payload)
job-id (uuid/parse (first payload))
sched-at (ct/inst (second payload))]
(if (and (uuid? job-id)
(ct/inst? sched-at))
[job-id sched-at]
(do
(l/err :hint "received unexpected payload"
:tenant tenant
:payload payload)
nil)))
(catch Throwable cause
(l/err :hint "unable to decode payload"
::l/context (cf/logging-context)
:tenant tenant
:payload payload
:length (alength ^String/1 payload)
:length (count payload)
:cause cause))))
(process-result [{:keys [status] :as result}]
(ex/try!
(case status
"retry" (handle-task-retry result)
"failed" (handle-task-failure result)
"completed" (handle-task-completion result)
"retry" (handle-job-retry result)
"failed" (handle-job-failure result)
"completed" (handle-job-completion result)
(throw (IllegalArgumentException.
(str "invalid status received: '" status "'"))))))
(run-task-loop [[task-id scheduled-at]]
(loop [result (run-task! cfg task-id scheduled-at)]
(run-job-loop [[job-id scheduled-at]]
(loop [result (run-job cfg job-id scheduled-at)]
(when-let [cause (some-> result process-result)]
(if (or (db/connection-error? cause)
(db/serialization-error? cause))
(do
(l/wrn :hint "database exeption on processing task result (retrying in some instants)"
(l/wrn :hint "database exeption on processing job result (retrying in some instants)"
:tenant tenant
:cause cause)
(px/sleep timeout)
(recur result))
(l/err :hint "unhandled exception on processing task result"
(l/err :hint "unhandled exception on processing job result"
::l/context (cf/logging-context)
:tenant tenant
:cause cause)))))]
(try
(let [key (str/ffmt "penpot.worker.queue:%" queue)
(let [key (wrk/queue-key tenant queue)
[_ payload] (rds/blpop conn [key] timeout)]
(some-> payload
decode-payload
run-task-loop))
run-job-loop))
(catch InterruptedException cause
(throw cause))
@ -261,46 +325,50 @@
(do
(l/err :hint "redis pop operation timeout, consider increasing redis timeout (will retry in some instants)"
::l/context (cf/logging-context)
:tenant tenant
:timeout timeout
:cause cause)
(px/sleep timeout))
(l/err :hint "unhandled exception"
::l/context (cf/logging-context)
:tenant tenant
:cause cause))))))
(defn- start-thread!
(defn- start-thread
[{:keys [::id ::queue ::wrk/tenant] :as cfg}]
(px/thread
{:name (str "penpot/job-runner/" id)}
(l/inf :hint "started" :id id :queue queue)
(l/inf :hint "started" :id id :tenant tenant :queue queue)
(let [rconn (rds/connect cfg)]
(try
(loop [cfg (-> cfg
(assoc ::rds/conn rconn)
(assoc ::queue (str/ffmt "%:%" tenant queue))
(assoc ::timeout (ct/duration "5s")))]
(when (px/interrupted?)
(throw (InterruptedException. "interrupted")))
(run-worker-loop! cfg)
(run-worker-loop cfg)
(recur cfg))
(catch InterruptedException _
(l/dbg :hint "interrupted"
:id id
:tenant tenant
:queue queue))
(catch Throwable cause
(l/err :hint "unexpected exception"
::l/context (cf/logging-context)
:id id
:tenant tenant
:queue queue
:cause cause))
(finally
(.close ^AutoCloseable rconn)
(l/inf :hint "terminated"
:id id
:tenant tenant
:queue queue))))))
(def ^:private schema:params
@ -308,10 +376,12 @@
[::wrk/parallelism {:optional true} ::sm/int]
[::wrk/queue :keyword]
[::wrk/tenant ::sm/text]
::wrk/registry
::jobs/defs
::mtx/metrics
::db/pool
::rds/client])
::rds/client
;; job events of a profile job are published on the profile topic
::mbus/msgbus])
(defmethod ig/assert-key ::wrk/runner
[_ params]
@ -322,15 +392,15 @@
{k (merge {::wrk/parallelism 1} (d/without-nils v))})
(defmethod ig/init-key ::wrk/runner
[_ {:keys [::db/pool ::wrk/queue ::wrk/parallelism] :as cfg}]
[_ {:keys [::db/pool ::wrk/queue ::wrk/parallelism ::wrk/tenant] :as cfg}]
(let [queue (d/name queue)
cfg (assoc cfg ::queue queue)]
(if (db/read-only? pool)
(l/wrn :hint "not started (db is read-only)" :queue queue :parallelism parallelism)
(l/wrn :hint "not started (db is read-only)" :tenant tenant :queue queue :parallelism parallelism)
(doall
(->> (range parallelism)
(map #(assoc cfg ::id (str queue "/" %)))
(map start-thread!))))))
(map start-thread))))))
(defmethod ig/halt-key! ::wrk/runner
[_ threads]

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

@ -180,6 +180,7 @@
(let [result (-> th/*system*
(assoc ::bfc/project-id (:default-project-id profile))
(assoc ::bfc/profile-id (:id profile))
(assoc ::bfc/team-id (:default-team-id profile))
(assoc ::bfc/input output)
(v3/import-files!))
file-id (first (:file-ids result))
@ -213,6 +214,7 @@
result (-> th/*system*
(assoc ::bfc/project-id (:default-project-id profile))
(assoc ::bfc/profile-id (:id profile))
(assoc ::bfc/team-id (:default-team-id profile))
(assoc ::bfc/input input)
(v3/import-files!))]
(bfc/get-file th/*system* (first (:file-ids result)))))
@ -267,6 +269,7 @@
(let [result (-> th/*system*
(assoc ::bfc/project-id (:default-project-id profile))
(assoc ::bfc/profile-id (:id profile))
(assoc ::bfc/team-id (:default-team-id profile))
(assoc ::bfc/input output)
(v3/import-files!))]
(t/is (map? result))
@ -300,6 +303,7 @@
(let [result (-> th/*system*
(assoc ::bfc/project-id (:default-project-id profile))
(assoc ::bfc/profile-id (:id profile))
(assoc ::bfc/team-id (:default-team-id profile))
(assoc ::bfc/input output)
(v3/import-files!))
imported (bfc/get-file th/*system* (first (:file-ids result)))]
@ -1962,6 +1966,7 @@
(let [cfg (-> th/*system*
(assoc ::bfc/project-id (:default-project-id profile))
(assoc ::bfc/profile-id (:id profile))
(assoc ::bfc/team-id (:default-team-id profile))
(assoc ::bfc/input output)
(assoc ::bfc/import-max-zip-entries 1))
out (try
@ -2018,6 +2023,7 @@
(let [cfg (-> th/*system*
(assoc ::bfc/project-id (:default-project-id profile))
(assoc ::bfc/profile-id (:id profile))
(assoc ::bfc/team-id (:default-team-id profile))
(assoc ::bfc/input output)
(assoc ::bfc/import-max-binary-entry-size 1))
out (try
@ -2106,6 +2112,7 @@
(let [cfg (-> th/*system*
(assoc ::bfc/project-id (:default-project-id profile))
(assoc ::bfc/profile-id (:id profile))
(assoc ::bfc/team-id (:default-team-id profile))
(assoc ::bfc/input bombed))
out (try-import-files! cfg)]
(t/is (= :validation (:type out)))
@ -2147,6 +2154,7 @@
(let [cfg (-> th/*system*
(assoc ::bfc/project-id (:default-project-id profile))
(assoc ::bfc/profile-id (:id profile))
(assoc ::bfc/team-id (:default-team-id profile))
(assoc ::bfc/input output)
(assoc ::bfc/import-max-text-total-size 100))
out (try-import-files! cfg)]
@ -2194,6 +2202,7 @@
(let [cfg (-> th/*system*
(assoc ::bfc/project-id (:default-project-id profile))
(assoc ::bfc/profile-id (:id profile))
(assoc ::bfc/team-id (:default-team-id profile))
(assoc ::bfc/input exported)
(assoc ::bfc/import-max-text-total-size budget))
out (try-import-files! cfg)]
@ -2381,6 +2390,7 @@
(let [result (:file-ids (-> th/*system*
(assoc ::bfc/project-id (:default-project-id profile))
(assoc ::bfc/profile-id (:id profile))
(assoc ::bfc/team-id (:default-team-id profile))
(assoc ::bfc/input output)
(v3/import-files!)))
files (map #(bfc/get-file th/*system* %) result)
@ -2459,6 +2469,7 @@
(let [result (:file-ids (-> th/*system*
(assoc ::bfc/project-id (:default-project-id profile))
(assoc ::bfc/profile-id (:id profile))
(assoc ::bfc/team-id (:default-team-id profile))
(assoc ::bfc/input output)
(v3/import-files!)))
mobjs (db/query th/*system* :file-media-object

21
backend/test/backend_tests/config_test.clj
View File

@ -38,3 +38,24 @@
(t/testing "a leading slash would drop the subpath, so it fails fast"
(t/is (thrown? AssertionError
(cf/join-uri "https://example.com/penpot" "/assets/by-id/123")))))
(t/deftest tenant-allows-only-alphanumeric
(t/testing "default and plain alphanumeric tenants validate"
(doseq [tenant ["default" "acme42" "my-company"]]
(t/is (cf/validate-config (assoc cf/config :tenant tenant)))))
(t/testing "LIKE wildcards and separators are rejected"
(doseq [tenant ["my_tenant" "a%b" "a:b" "a b" "" "acme.example.com"]]
(t/is (not (cf/validate-config (assoc cf/config :tenant tenant)))))))
(t/deftest worker-parallelism-keys
(t/testing "schema decodes all runner parallelism keys (env strings to int)"
(let [decoded (cf/decode-config {:worker-default-parallelism "4"
:worker-webhook-parallelism "2"
:worker-cron-parallelism "3"})]
(t/is (= 4 (:worker-default-parallelism decoded)))
(t/is (= 2 (:worker-webhook-parallelism decoded)))
(t/is (= 3 (:worker-cron-parallelism decoded)))))
(t/testing "lookups resolve configured values (unnamespaced keys, as main uses)"
(with-redefs [cf/config (assoc cf/config
:worker-default-parallelism 4)]
(t/is (= 4 (cf/get :worker-default-parallelism 1))))))

80
backend/test/backend_tests/db_transaction_test.clj Normal file
View File

@ -0,0 +1,80 @@
;; 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.db-transaction-test
(:require
[app.common.uuid :as uuid]
[app.db :as db]
[backend-tests.helpers :as th]
[clojure.test :as t]))
(t/use-fixtures :once th/state-init)
(t/deftest after-commit-runs-after-a-successful-transaction
(let [events (atom [])]
(db/tx-run! th/*pool*
(fn [_]
(db/after-commit #(swap! events conj :committed))))
(t/is (= [:committed] @events))))
(t/deftest after-commit-is-discarded-on-rollback
(let [events (atom [])]
(t/is (thrown? Exception
(db/tx-run! th/*pool*
(fn [_]
(db/after-commit #(swap! events conj :committed))
(throw (ex-info "rollback" {}))))))
(t/is (empty? @events))))
(t/deftest nested-transactions-share-the-outer-commit
(let [events (atom [])]
(db/tx-run! th/*pool*
(fn [cfg]
(db/after-commit #(swap! events conj :outer))
(db/tx-run! cfg
(fn [_]
(db/after-commit #(swap! events conj :inner))))))
(t/is (= [:outer :inner] @events))))
(t/deftest after-commit-runs-immediately-outside-a-transaction
(let [events (atom [])]
(db/after-commit #(swap! events conj :immediate))
(t/is (= [:immediate] @events))))
(t/deftest a-rollback-only-transaction-runs-no-callbacks
(let [events (atom [])]
(db/tx-run! {::db/pool th/*pool*
::db/rollback true}
(fn [_]
(db/after-commit #(swap! events conj :committed))))
(t/is (= [] @events)
"the transaction rolled back, so there is no commit to follow")))
(t/deftest an-independent-transaction-owns-its-callbacks
(let [events (atom [])
job-id (uuid/next)]
(try
(try
(db/tx-run! th/*pool*
(fn [_]
(db/after-commit #(swap! events conj :outer))
;; a different connection: its own unit of work, so
;; it commits on its own and owns its own callbacks
(db/tx-run! th/*pool*
(fn [cfg]
(db/after-commit #(swap! events conj :inner))
(db/exec-one! cfg ["INSERT INTO job (id, name, tenant, queue)
VALUES (?, ?, ?, ?)"
job-id "test" "acme" "default"])))
(throw (ex-info "rollback" {}))))
(catch Exception _ nil))
(t/testing "the row written by the inner transaction survives the caller rollback"
(t/is (= 1 (:cnt (th/db-exec-one! ["SELECT count(*) AS cnt FROM job WHERE id = ?"
job-id])))))
(t/testing "its callback ran with its own commit, the caller one was dropped"
(t/is (= [:inner] @events)))
(finally
(th/db-force-delete :job {:id job-id})))))

46
backend/test/backend_tests/demo_test.clj
View File

@ -8,9 +8,9 @@
(:require
[app.common.time :as ct]
[app.db :as db]
[app.jobs :as jobs]
[app.rpc.commands.profile :as profile]
[app.tasks.demo-purge :as demo-purge]
[app.worker :as wrk]
[backend-tests.helpers :as th]
[clojure.test :as t]
[integrant.core :as ig]))
@ -34,14 +34,44 @@
(t/deftest demo-purge-handler-submits-delete-object
(let [profile (th/create-profile* 996 {:is-demo true})
handler (ig/init-key :app.tasks.demo-purge/handler
{::db/pool th/*pool*})
handler (ig/init-key :app.tasks.demo-purge/job-def
{::db/pool th/*pool*
::jobs/defs {:delete-object {::jobs/name :delete-object
::jobs/schema [:map]
::jobs/handler (fn [_context params] params)
::jobs/decoder identity
::jobs/validator (fn [_] true)}}})
submitted (atom nil)]
(with-redefs [wrk/submit! (fn [& {:keys [::wrk/task ::wrk/params]}]
(reset! submitted {:task task :params params}))]
(handler {:props {:profile-id (:id profile)
:deleted-at (ct/now)}}))
(t/is (= :delete-object (:task @submitted)))
(with-redefs [jobs/submit (fn [cfg options]
(reset! submitted
{:name (get options ::jobs/name)
:params (get options ::jobs/params)}))]
((::jobs/handler handler) nil {:profile-id (:id profile)}))
(t/is (= :delete-object (:name @submitted)))
(t/is (= :profile (:object (:params @submitted))))
(t/is (= (:id profile) (:id (:params @submitted))))
(t/is (some? (:deleted-at (:params @submitted))))))
(t/deftest job-handler-uses-its-closed-cfg
"The handler is [context params]: the job-def keeps the dependencies it
closed over at init time, so it still reaches the database through its
own pool and needs nothing from the caller."
(let [profile (th/create-profile* 997 {:is-demo true})
handler (ig/init-key :app.tasks.demo-purge/job-def
{::db/pool th/*pool*
::jobs/defs {:delete-object {::jobs/name :delete-object
::jobs/schema [:map]
::jobs/handler (fn [_context params] params)
::jobs/decoder identity
::jobs/validator (fn [_] true)}}})
submitted (atom nil)]
(with-redefs [jobs/submit (fn [cfg options]
(reset! submitted
{:pool (::db/pool cfg)
:params (get options ::jobs/params)}))]
((::jobs/handler handler) nil {:profile-id (:id profile)})
(t/testing "the closed pool is the one the handler submitted with"
(t/is (db/pool? (:pool @submitted)))
(t/is (identical? th/*pool* (:pool @submitted)))
(t/is (= (:id profile) (:id (:params @submitted))))))))

24
backend/test/backend_tests/email_sending_test.clj
View File

@ -9,9 +9,12 @@
[app.config :as cf]
[app.db :as db]
[app.email :as emails]
[app.jobs :as jobs]
[app.metrics :as-alias mtx]
[backend-tests.helpers :as th]
[clojure.test :as t]
[cuerdas.core :as str]
[integrant.core :as ig]
[promesa.core :as p]))
(t/use-fixtures :once th/state-init)
@ -118,3 +121,24 @@
(t/is (not (str/includes? (email-text-body result) "Hi ,")))
(t/is (str/includes? (get-in result [:body "text/html"]) "Hi,"))
(t/is (not (str/includes? (get-in result [:body "text/html"]) "Hi ,")))))
(t/deftest send-with-reuse-conn-and-no-conn-raises
(t/testing "reuse-conn without a caller connection fails fast"
(t/is (thrown-with-msg? clojure.lang.ExceptionInfo #"reuse-conn"
(emails/send {}
{::emails/reuse-conn true
::emails/factory (fn [_] {:to "a@example.com"})})))))
(t/deftest send-with-reuse-conn-joins-caller-transaction
(let [job-def (ig/init-key ::emails/job-def
{::emails/sendmail (fn [_] nil)})
defs {:sendmail job-def}
email {:to "a@example.com" :subject "hi" :body "hello"}
job-id (db/tx-run! {::db/pool th/*pool*}
(fn [cfg]
(emails/send (assoc cfg
::jobs/defs defs
::mtx/metrics (get th/*system* :app.metrics/metrics))
(assoc email ::emails/reuse-conn true))))]
(t/testing "the email job is submitted through the caller conn"
(t/is (= "sendmail" (:name (th/db-get :job {:id job-id})))))))

28
backend/test/backend_tests/file_gc_scheduler_test.clj Normal file
View File

@ -0,0 +1,28 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS INC
(ns backend-tests.file-gc-scheduler-test
(:require
[app.jobs :as jobs]
[backend-tests.helpers :as th]
[clojure.test :as t]))
(t/use-fixtures :once th/state-init)
(t/use-fixtures :each th/database-reset)
(t/deftest min-age-validation
(let [cfg th/*system*]
(t/testing "int millis, text and absence validate"
(t/is (uuid? (jobs/submit cfg {::jobs/name :file-gc-scheduler
::jobs/params {:min-age 3600000}})))
(t/is (uuid? (jobs/submit cfg {::jobs/name :file-gc-scheduler
::jobs/params {:min-age "1h"}})))
(t/is (uuid? (jobs/submit cfg {::jobs/name :file-gc-scheduler
::jobs/params {}}))))
(t/testing "garbage fails at submit instead of burning retries"
(t/is (thrown-with-msg? Exception #"check error"
(jobs/submit cfg {::jobs/name :file-gc-scheduler
::jobs/params {:min-age {:bogus true}}}))))))

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

@ -20,6 +20,7 @@
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
[app.jobs :as jobs]
[app.main :as main]
[app.media]
[app.media :as-alias mtx]
@ -35,7 +36,6 @@
[app.rpc.helpers :as rph]
[app.util.blob :as blob]
[app.util.services :as sv]
[app.worker :as wrk]
[app.worker.runner]
[clojure.java.io :as io]
[clojure.spec.alpha :as s]
@ -134,7 +134,8 @@
:app.worker/cron
:app.worker/dispatcher
[:app.main/default :app.worker/runner]
[:app.main/webhook :app.worker/runner]))
[:app.main/webhook :app.worker/runner]
[:app.main/cron :app.worker/runner]))
_ (ig/load-namespaces system)
system (-> (ig/expand system) (ig/init))]
(try
@ -238,8 +239,10 @@
(defn mark-file-deleted*
([params]
(mark-file-deleted* *system* params))
([conn {:keys [id] :as params}]
(#'files/mark-file-deleted conn {} id)))
([system {:keys [id] :as params}]
(db/tx-run! system
(fn [cfg]
(#'files/mark-file-deleted cfg {} id)))))
(defn create-team*
([i params] (create-team* *system* i params))
@ -494,28 +497,37 @@
(try-on! (method-fn params)))))
(defn run-task!
"Execute a job handler directly (in-process, no row): the handler gets a
nil context, because there is no job to describe."
([name]
(run-task! name {}))
([name params]
(wrk/invoke! (-> *system*
(assoc ::wrk/task name)
(assoc ::wrk/params params)))))
(jobs/invoke (-> *system*
(assoc ::jobs/name name)
(assoc ::jobs/params params)))))
(def sql:pending-tasks
"select t.* from task as t
where t.status = 'new'
order by t.priority desc, t.scheduled_at")
(def sql:pending-jobs
"select * from job
where status = 'new'
order by priority desc, scheduled_at")
(defn run-pending-tasks!
(defn run-pending-jobs
"Execute the pending (status='new') `job` rows in-process (simulating
the dispatcher + runner for the tests). Each row gets its context and its
job-id, so heartbeats and progress reach it exactly like in the runner.
Does not touch the row status; only the handler side effects matter."
[]
(db/tx-run! *system* (fn [{:keys [::db/conn] :as cfg}]
(let [tasks (->> (db/exec! conn [sql:pending-tasks])
(map #'app.worker.runner/decode-task-row))]
(doseq [task tasks]
(let [cfg (-> cfg
(assoc :app.worker.runner/queue (:queue task))
(assoc :app.worker.runner/id 0))]
(#'app.worker.runner/run-task cfg task)))))))
(db/tx-run! *system*
(fn [{:keys [::db/conn]}]
(let [jobs-rows (db/exec! conn [sql:pending-jobs])]
(doseq [row jobs-rows]
(jobs/invoke (-> *system*
;; the row stores a string; invoke
;; takes the canonical keyword
(assoc ::jobs/name (keyword (:name row)))
(assoc ::jobs/params (:params row))
(assoc ::jobs/context (jobs/make-context row))
(assoc ::jobs/job-id (:id row)))))))))
;; --- UTILS
@ -627,6 +639,17 @@
[& params]
(apply db/delete! *pool* params))
(defn db-force-delete
"Deletes rows whose table is guarded by `raise_deletion_protection`,
inside a transaction that disables the guard. Test-only escape hatch:
production delete paths disable protection in their own transaction
(see `app.jobs.gc`)."
[& params]
(db/tx-run! *pool*
(fn [{:keys [::db/conn]}]
(db/exec-one! conn ["SET LOCAL rules.deletion_protection TO off"])
(apply db/delete! conn params))))
(defn db-query
[& params]
(apply db/query *pool* params))

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

@ -412,25 +412,25 @@
:auth-token-cookie-max-age idle
:auth-token-cookie-max-age-absolute absolute
default)))]
(let [expanded (ig/expand-key :app.http.session.tasks/gc {})]
(let [expanded (ig/expand-key :app.http.session/job-def {})]
(t/is (= idle
(get-in expanded [:app.http.session.tasks/gc
(get-in expanded [:app.http.session/job-def
:app.http.session.tasks/max-age]))
"task max-age should carry the configured idle window")
(t/is (= absolute
(get-in expanded [:app.http.session.tasks/gc
(get-in expanded [:app.http.session/job-def
:app.http.session.tasks/max-age-absolute]))
"task max-age-absolute should carry the configured absolute cap")))
(with-redefs [cf/get (fn
([_k] nil)
([_k default] default))]
(let [expanded (ig/expand-key :app.http.session.tasks/gc {})]
(let [expanded (ig/expand-key :app.http.session/job-def {})]
(t/is (= session/default-cookie-max-age
(get-in expanded [:app.http.session.tasks/gc
(get-in expanded [:app.http.session/job-def
:app.http.session.tasks/max-age]))
"task max-age should fall back to the default idle window")
(t/is (= session/default-cookie-max-age-absolute
(get-in expanded [:app.http.session.tasks/gc
(get-in expanded [:app.http.session/job-def
:app.http.session.tasks/max-age-absolute]))
"task max-age-absolute should fall back to the default absolute cap")))))
@ -439,15 +439,15 @@
params {:app.db/pool pool
:app.http.session.tasks/max-age (ct/duration {:days 7})
:app.http.session.tasks/max-age-absolute (ct/duration {:days 30})}]
(t/is (nil? (ig/assert-key :app.http.session.tasks/gc params))
(t/is (nil? (ig/assert-key :app.http.session/job-def params))
"absolute cap above the idle window should pass")
(t/is (nil? (ig/assert-key :app.http.session.tasks/gc
(t/is (nil? (ig/assert-key :app.http.session/job-def
(assoc params
:app.http.session.tasks/max-age-absolute
(ct/duration {:days 7}))))
"absolute cap equal to the idle window should pass")
(t/is (thrown? IllegalArgumentException
(ig/assert-key :app.http.session.tasks/gc
(ig/assert-key :app.http.session/job-def
(assoc params
:app.http.session.tasks/max-age-absolute
(ct/duration {:days 3}))))

361
backend/test/backend_tests/jobs_gc_test.clj Normal file
View File

@ -0,0 +1,361 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS INC
(ns backend-tests.jobs-gc-test
(:require
[app.common.schema :as sm]
[app.common.time :as ct]
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
[app.jobs :as jobs]
[app.jobs.gc :as gc]
[app.main :as main]
[app.metrics :as-alias mtx]
[app.metrics.definition :as-alias mdef]
[app.storage :as sto]
[backend-tests.helpers :as th]
[backend-tests.storage-test :refer [configure-storage-backend]]
[clojure.test :as t]
[integrant.core :as ig])
(:import
io.prometheus.client.Counter
io.prometheus.client.Counter$Child))
(t/use-fixtures :once th/state-init)
(t/use-fixtures :each (th/serial
th/database-reset
th/clean-storage))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HELPERS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- make-metrics []
(ig/init-key :app.metrics/metrics
{:default (select-keys main/default-metrics
[:jobs-gc-rows])}))
(defn- counter-value [metrics labels]
(let [collector (mtx/get-collector metrics :jobs-gc-rows)
instance (::mdef/instance collector)
child (.labels ^Counter instance (into-array String labels))]
(.get ^Counter$Child child)))
(defn- mk-storage-object
[]
(let [storage (-> (:app.storage/storage th/*system*)
(configure-storage-backend))]
(sto/put-object! storage {::sto/content (sto/content "content")
:content-type "text/plain"})))
(defn- mk-job
[{:keys [status profile-id resource-id expires-at modified-at]
:or {status "new"}}]
(let [id (uuid/next)]
(th/db-insert! :job {:id id
:name "test-job"
:tenant (cf/get :tenant)
:queue "default"
:params (db/json {})
:priority 100
:max-retries 3
:retry-num 0
:status status
:profile-id profile-id
:resource-id resource-id
:expires-at expires-at
:scheduled-at (ct/now)
:created-at (ct/now)
:modified-at (or modified-at (ct/now))})
id))
(t/deftest gc-records-deleted-rows
(let [metrics (make-metrics)
cfg {::db/pool th/*pool*
::mtx/metrics metrics}]
(th/db-insert! :job {:id (uuid/next)
:name "test-job"
:tenant (cf/get :tenant)
:queue "default"
:params (db/json {})
:priority 100
:max-retries 3
:retry-num 0
:status "completed"
:expires-at (ct/in-past {:minutes 5})
:scheduled-at (ct/now)
:created-at (ct/now)
:modified-at (ct/now)})
(gc/execute-jobs-gc cfg {})
(t/is (= 1.0 (counter-value metrics ["expired" "deleted"])))))
(t/deftest job-rows-are-protected-against-unintended-deletes
(let [job-id (mk-job {:expires-at (ct/in-past {:minutes 5})})]
(t/testing "a stray DELETE is blocked by the deletion protection trigger"
(t/is (thrown-with-msg? Exception #"unable to proceed to delete row"
(th/db-exec! ["DELETE FROM job WHERE id = ?" job-id])))
(t/is (some? (th/db-get :job {:id job-id} :id :status))))
(t/testing "the jobs GC is the intended deleter and disables the guard"
(th/run-task! :jobs-gc {})
(t/is (nil? (th/db-get :job {:id job-id} :id :status))))))
(t/deftest gc-deletes-expired-jobs-and-touches-their-resources
(let [old-object (mk-storage-object)
live-object (mk-storage-object)
expired-id (uuid/next)
live-id (uuid/next)]
(th/db-insert! :job {:id expired-id
:name "test-job"
:tenant (cf/get :tenant)
:queue "default"
:params (db/json {})
:priority 100
:max-retries 3
:retry-num 0
:status "completed"
:resource-id (:id old-object)
:expires-at (ct/in-past {:minutes 5})
:scheduled-at (ct/now)
:created-at (ct/now)
:modified-at (ct/now)})
(th/db-insert! :job {:id live-id
:name "test-job"
:tenant (cf/get :tenant)
:queue "default"
:params (db/json {})
:priority 100
:max-retries 3
:retry-num 0
:status "running"
:resource-id (:id live-object)
:expires-at (ct/in-future {:minutes 5})
:scheduled-at (ct/now)
:created-at (ct/now)
:modified-at (ct/now)})
(th/run-task! :jobs-gc {})
(t/is (nil? (th/db-get :job {:id expired-id} :id :status)))
(t/is (some? (th/db-get :job {:id live-id} :id :status)))
(t/is (some? (:touched-at (th/db-get :storage-object {:id (:id old-object)}
:id :touched-at))))
(t/is (nil? (:touched-at (th/db-get :storage-object {:id (:id live-object)}
:id :touched-at)))))
;; a row without resource is deleted without touching anything
(let [expired-id (uuid/next)]
(th/db-insert! :job {:id expired-id
:name "test-job"
:tenant (cf/get :tenant)
:queue "default"
:params (db/json {})
:priority 100
:max-retries 3
:retry-num 0
:status "new"
:expires-at (ct/in-past {:minutes 5})
:scheduled-at (ct/now)
:created-at (ct/now)
:modified-at (ct/now)})
(th/run-task! :jobs-gc {})
(t/is (nil? (th/db-get :job {:id expired-id} :id :status)))))
(t/deftest gc-params-accept-string-min-age
(t/testing "duration strings validate like durations and millis"
(t/is ((sm/validator gc/schema:jobs-gc-params) {:min-age "1h"}))
(t/is ((sm/validator gc/schema:jobs-gc-params) {:min-age 3600000}))
(t/is ((sm/validator gc/schema:jobs-gc-params) {:min-age (ct/duration {:hours 1})})))
(t/testing "string min-age runs like a duration"
(t/is (map? (th/run-task! :jobs-gc {:min-age "1h"})))))
(t/deftest submit-normalizes-durations-to-millis
(let [defs {:jobs-gc (ig/init-key ::gc/job-def {})}
cfg {::jobs/defs defs
::db/pool th/*pool*
::mtx/metrics (get th/*system* :app.metrics/metrics)}
job-id (jobs/submit cfg {::jobs/name :jobs-gc
::jobs/params {:min-age (ct/duration {:hours 1})}})]
(t/testing "a Duration object does not reach JSON encoding"
(t/is (= 3600000 (:min-age (:params (jobs/get-job cfg job-id))))))))
(t/deftest gc-retention-deletes-old-internal-terminal-rows
(let [profile (th/create-profile* 1 {})
;; old internal terminal row -> deleted
old-id (uuid/next)]
(th/db-insert! :job {:id old-id
:name "test-job"
:tenant (cf/get :tenant)
:queue "default"
:params (db/json {})
:priority 100
:max-retries 3
:retry-num 0
:status "completed"
:scheduled-at (ct/now)
:created-at (ct/now)
:modified-at (ct/in-past {:days 10})})
;; recent internal terminal row: inside the retention window, survives
(let [recent-id (uuid/next)]
(th/db-insert! :job {:id recent-id
:name "test-job"
:tenant (cf/get :tenant)
:queue "default"
:params (db/json {})
:priority 100
:max-retries 3
:retry-num 0
:status "completed"
:scheduled-at (ct/now)
:created-at (ct/now)
:modified-at (ct/now)})
;; non-terminal internal row: never swept by retention, survives
(let [running-id (uuid/next)]
(th/db-insert! :job {:id running-id
:name "test-job"
:tenant (cf/get :tenant)
:queue "default"
:params (db/json {})
:priority 100
:max-retries 3
:retry-num 0
:status "running"
:scheduled-at (ct/now)
:created-at (ct/now)
:modified-at (ct/in-past {:days 10})})
;; old USER terminal row (profile set): retention does not sweep
;; the user ledger, survives
(let [user-id (uuid/next)]
(th/db-insert! :job {:id user-id
:name "test-job"
:tenant (cf/get :tenant)
:queue "default"
:params (db/json {})
:priority 100
:max-retries 3
:retry-num 0
:status "completed"
:profile-id (:id profile)
:scheduled-at (ct/now)
:created-at (ct/now)
:modified-at (ct/in-past {:days 10})})
(th/run-task! :jobs-gc {})
(t/is (nil? (th/db-get :job {:id old-id} :id :status)))
(t/is (= 3 (count (th/db-query :job {:queue "default"}))))
(t/is (some? (th/db-get :job {:id recent-id} :id :status)))
(t/is (some? (th/db-get :job {:id running-id} :id :status)))
(t/is (some? (th/db-get :job {:id user-id} :id :status))))))))
(t/deftest gc-retention-deletes-old-aborted-rows
"Aborted jobs are terminal like failed/cancelled: old internal aborted
rows are swept by retention, recent ones survive."
(let [old-id (uuid/next)
recent-id (uuid/next)]
(doseq [[id modified-at] [[old-id (ct/in-past {:days 10})]
[recent-id (ct/now)]]]
(th/db-insert! :job {:id id
:name "test-job"
:tenant (cf/get :tenant)
:queue "default"
:params (db/json {})
:priority 100
:max-retries 3
:retry-num 0
:status "aborted"
:scheduled-at (ct/now)
:created-at (ct/now)
:modified-at modified-at}))
(th/run-task! :jobs-gc {})
(t/is (nil? (th/db-get :job {:id old-id} :id :status)))
(t/is (some? (th/db-get :job {:id recent-id} :id :status)))))
(t/deftest gc-retention-touches-resources-of-retained-rows
(let [object (mk-storage-object)
job-id (uuid/next)]
(th/db-insert! :job {:id job-id
:name "test-job"
:tenant (cf/get :tenant)
:queue "default"
:params (db/json {})
:priority 100
:max-retries 3
:retry-num 0
:status "failed"
:resource-id (:id object)
:scheduled-at (ct/now)
:created-at (ct/now)
:modified-at (ct/in-past {:days 10})})
(th/run-task! :jobs-gc {})
(t/is (nil? (th/db-get :job {:id job-id} :id :status)))
(t/is (some? (:touched-at (th/db-get :storage-object {:id (:id object)}
:id :touched-at))))))
(t/deftest gc-deletes-expired-jobs-in-bounded-batches
(let [total 2500]
(th/db-exec! [(str "INSERT INTO job (name, tenant, queue, status, expires_at) "
"SELECT 'test-job', '" (cf/get :tenant) "', 'default', 'completed', "
"now() - interval '1 hour' "
"FROM generate_series(1, " total ")")])
;; spread a few resources across batches so every batch touches
(let [objects (repeatedly 3 mk-storage-object)]
(doseq [[object n] (map vector objects (range))]
(th/db-exec! ["UPDATE job SET resource_id = ?
WHERE id = (SELECT id FROM job OFFSET ? LIMIT 1)"
(:id object) (* n 1000)]))
(let [{:keys [deleted-expired touched-expired]} (th/run-task! :jobs-gc {})]
(t/is (= total deleted-expired))
(t/is (= (count objects) touched-expired))
(t/is (= 0 (count (th/db-query :job {:queue "default"}))))
(doseq [object objects]
(t/is (some? (:touched-at (th/db-get :storage-object {:id (:id object)}
:id :touched-at)))))))))
(t/deftest gc-commits-each-batch-separately
(let [total 2500
calls (atom 0)
orig @#'gc/touch-resources]
(th/db-exec! [(str "INSERT INTO job (name, tenant, queue, status, expires_at) "
"SELECT 'test-job', '" (cf/get :tenant) "', 'default', 'completed', "
"now() - interval '1 hour' "
"FROM generate_series(1, " total ")")])
;; blow up on the 3rd batch: earlier batches must stay committed
(alter-var-root #'gc/touch-resources
(constantly (fn [conn ids]
(when (= 3 (swap! calls inc))
(throw (ex-info "boom" {})))
(orig conn ids))))
(try
(t/is (thrown? Exception (th/run-task! :jobs-gc {})))
(t/is (= 500 (count (th/db-query :job {:queue "default"}))))
(finally
(alter-var-root #'gc/touch-resources (constantly orig))))
;; the next tick completes the sweep
(let [{:keys [deleted-expired]} (th/run-task! :jobs-gc {})]
(t/is (= 500 deleted-expired))
(t/is (zero? (count (th/db-query :job {:queue "default"})))))))
(t/deftest gc-expiration-skips-active-rows
(let [running-id (uuid/next)
retry-id (uuid/next)]
(doseq [[id status] [[running-id "running"] [retry-id "retry"]]]
(th/db-insert! :job {:id id
:name "test-job"
:tenant (cf/get :tenant)
:queue "default"
:params (db/json {})
:priority 100
:max-retries 3
:retry-num 0
:status status
:expires-at (ct/in-past {:minutes 5})
:scheduled-at (ct/now)
:created-at (ct/now)
:modified-at (ct/now)}))
(th/run-task! :jobs-gc {})
(t/testing "active rows survive expiration"
(t/is (some? (th/db-get :job {:id running-id} :id :status)))
(t/is (some? (th/db-get :job {:id retry-id} :id :status))))))

307
backend/test/backend_tests/jobs_metrics_test.clj Normal file
View File

@ -0,0 +1,307 @@
;; 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.jobs-metrics-test
(:require
[app.common.time :as ct]
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
[app.jobs :as jobs]
[app.jobs.metrics :as jobs-metrics]
[app.main :as main]
[app.metrics :as mtx]
[app.metrics.definition :as-alias mdef]
[backend-tests.helpers :as th]
[clojure.test :as t]
[cuerdas.core :as str]
[integrant.core :as ig])
(:import
io.prometheus.client.Collector$MetricFamilySamples
io.prometheus.client.Collector$MetricFamilySamples$Sample
io.prometheus.client.CollectorRegistry
io.prometheus.client.Counter
io.prometheus.client.Counter$Child
io.prometheus.client.Gauge
io.prometheus.client.Gauge$Child))
(t/use-fixtures :once th/state-init)
(t/use-fixtures :each th/database-reset)
(def ^:private metric-ids
[:jobs-submitted
:jobs-dispatched
:jobs-completed
:jobs-retries
:jobs-orphaned
:jobs-rescheduled
:jobs-queue-wait-timing
:jobs-execution-timing
:jobs-total-timing
:jobs-dispatcher-timing
:jobs-dispatcher-batch-size
:jobs-backlog
:jobs-oldest-pending-age
:jobs-gc-rows
:jobs-gc-timing
:jobs-cron-total
:jobs-requests-total
:jobs-request-timing
:jobs-events-total])
;; The legacy histogram is registered too, so it can be asserted, but it is
;; not part of the `penpot_jobs_` contract the test above checks.
(def ^:private registry-ids (conj metric-ids :tasks-timing))
(defn- make-metrics []
(ig/init-key :app.metrics/metrics
{:default (select-keys main/default-metrics registry-ids)}))
(defn- metrics-cfg
"The cfg the `record-*` functions resolve the instance from. They take
a cfg, not an instance, so this is what a caller hands them."
[metrics]
{::mtx/metrics metrics})
(defn- counter-value [metrics id labels]
(let [collector (mtx/get-collector metrics id)
instance (::mdef/instance collector)
child (.labels ^Counter instance (into-array String labels))]
(.get ^Counter$Child child)))
(defn- histogram-count
"How many observations a histogram has recorded for an exact set of
labels, read off the registry so the label set itself is checked."
[metrics id labels]
(let [definition (get main/default-metrics id)]
(->> (enumeration-seq
(.metricFamilySamples ^CollectorRegistry (mtx/get-registry metrics)))
(filter (fn [^Collector$MetricFamilySamples family]
(= (.-name family) (::mdef/name definition))))
(mapcat (fn [^Collector$MetricFamilySamples family]
(.samples family)))
(filter (fn [^Collector$MetricFamilySamples$Sample sample]
(and (str/ends-with? (.-name sample) "_count")
(= labels (vec (.-labelValues sample))))))
(map (fn [^Collector$MetricFamilySamples$Sample sample] (.-value sample)))
;; 0.0 and not 0: an empty sum must compare equal to the 0.0 the
;; assertions use, and (= 0 0.0) is false in Clojure
(reduce + 0.0))))
(defn- gauge-value [metrics id labels]
(let [collector (mtx/get-collector metrics id)
instance (::mdef/instance collector)
child (.labels ^Gauge instance (into-array String labels))]
(.get ^Gauge$Child child)))
(t/deftest default-metrics-cover-the-jobs-observability-contract
(doseq [id metric-ids]
(let [definition (get main/default-metrics id)]
(t/is (some? definition) id)
(t/is (re-find #"^penpot_jobs_" (::mdef/name definition)) id)))
(t/is (= ["name" "queue" "outcome"]
(::mdef/labels (:jobs-completed main/default-metrics))))
(t/is (= ["status"]
(::mdef/labels (:jobs-backlog main/default-metrics)))))
(t/deftest submit-metric-is-not-recorded-when-the-outer-transaction-rolls-back
(let [metrics (make-metrics)
defs {:echo {::jobs/name :echo
::jobs/schema [:map]
::jobs/handler (fn [_context params] params)
::jobs/decoder identity
::jobs/validator (constantly true)}}
cfg {::jobs/defs defs
::db/pool th/*pool*
::mtx/metrics metrics}]
(t/is (thrown? Exception
(db/tx-run! cfg
(fn [tx-cfg]
(jobs/submit tx-cfg
{::jobs/name :echo
::jobs/params {}})
(throw (ex-info "rollback" {}))))))
(t/is (= 0.0 (counter-value metrics :jobs-submitted ["echo" "default"])))))
(t/deftest submit-and-terminal-writers-record-production-events
(let [metrics (make-metrics)
defs {:echo {::jobs/name :echo
::jobs/schema [:map]
::jobs/handler (fn [_context params] params)
::jobs/decoder identity
::jobs/validator (constantly true)}}
cfg {::jobs/defs defs
::db/pool th/*pool*
::mtx/metrics metrics}
job-id (jobs/submit cfg {::jobs/name :echo ::jobs/params {}})]
(jobs/claim cfg job-id (:scheduled-at (jobs/get-job cfg job-id)))
(jobs/complete cfg :job-id job-id :result {:ok true})
(t/is (= 1.0 (counter-value metrics :jobs-submitted ["echo" "default"])))
(t/is (= 1.0 (counter-value metrics :jobs-completed ["echo" "default" "completed"])))))
(t/deftest lifecycle-helpers-use-labels-as-is
(let [metrics (make-metrics)
cfg (metrics-cfg metrics)]
(jobs-metrics/record-submitted cfg "delete-object" "default")
(jobs-metrics/record-dispatched cfg "delete-object" "default" 2)
(jobs-metrics/record-outcome cfg "delete-object" "default" :completed)
(jobs-metrics/record-retry cfg "delete-object" "default" :backoff)
(jobs-metrics/record-orphan cfg "webhooks")
(jobs-metrics/record-rescheduled cfg "custom")
(jobs-metrics/record-gc-rows cfg :expired :deleted 3)
(jobs-metrics/record-cron cfg :submitted :none)
(jobs-metrics/record-request cfg :replied 12)
(jobs-metrics/record-legacy-execution cfg "delete-object" 42)
(t/is (= 1.0 (counter-value metrics :jobs-submitted ["delete-object" "default"])))
(t/is (= 2.0 (counter-value metrics :jobs-dispatched ["delete-object" "default"])))
(t/is (= 1.0 (counter-value metrics :jobs-completed ["delete-object" "default" "completed"])))
(t/is (= 1.0 (counter-value metrics :jobs-retries ["delete-object" "default" "backoff"])))
(t/is (= 1.0 (counter-value metrics :jobs-orphaned ["webhooks"])))
(t/is (= 1.0 (counter-value metrics :jobs-rescheduled ["custom"])))
(t/is (= 3.0 (counter-value metrics :jobs-gc-rows ["expired" "deleted"])))
(t/is (= 1.0 (counter-value metrics :jobs-cron-total ["submitted" "none"])))
(t/is (= 1.0 (counter-value metrics :jobs-requests-total ["replied"])))
(t/testing "the legacy histogram keeps the raw job name, with no queue"
(t/is (= 1.0 (histogram-count metrics :tasks-timing ["delete-object"]))))
(t/testing "like every other jobs metric now, it does not fold an unknown name into \"other\""
(jobs-metrics/record-legacy-execution cfg :brand-new-job 7)
(t/is (= 1.0 (histogram-count metrics :tasks-timing ["brand-new-job"])))
(t/is (= 0.0 (histogram-count metrics :tasks-timing ["other"]))))))
(t/deftest labels-go-to-metrics-as-is
(t/testing "queues are lowercased, with other only when missing"
(t/is (= "unexpected" (jobs-metrics/queue-label "unexpected")))
(t/is (= "default" (jobs-metrics/queue-label "default")))
(t/is (= "default" (jobs-metrics/queue-label :default)))
(t/is (= "other" (jobs-metrics/queue-label nil))))
(let [metrics (make-metrics)
cfg (metrics-cfg metrics)]
(jobs-metrics/record-outcome cfg "echo" "unexpected" :unexpected)
(t/is (= 1.0 (counter-value metrics :jobs-completed ["echo" "unexpected" "unexpected"])))
(t/testing "a new value is recorded, never folded or dropped"
(jobs-metrics/record-gc-rows cfg :unknown :deleted 1)
(jobs-metrics/record-cron cfg :brand-new :whatever)
(jobs-metrics/record-request cfg :brand-new 5)
(t/is (= 1.0 (counter-value metrics :jobs-gc-rows ["unknown" "deleted"])))
(t/is (= 1.0 (counter-value metrics :jobs-cron-total ["brand-new" "whatever"])))
(t/is (= 1.0 (counter-value metrics :jobs-requests-total ["brand-new"]))))))
(t/deftest sampler-is-wired-and-does-not-start-on-read-only
(t/is (contains? main/worker-config :app.jobs.metrics/sampler))
(let [metrics (make-metrics)
cfg {::db/pool th/*pool*
::mtx/metrics metrics}]
(with-redefs [db/read-only? (constantly true)]
(t/is (nil? (ig/init-key :app.jobs.metrics/sampler cfg))))
(let [sampler (ig/init-key :app.jobs.metrics/sampler cfg)]
(try
(t/is (some? sampler))
(finally
(ig/halt-key! :app.jobs.metrics/sampler sampler))))))
(t/deftest unknown-names-go-to-metrics-as-is
(let [metrics (make-metrics)
cfg (metrics-cfg metrics)]
(jobs-metrics/record-submitted cfg "unknown-job" "default")
(t/is (= 1.0 (counter-value metrics :jobs-submitted ["unknown-job" "default"])))))
(t/deftest backlog-sampler-updates-status-and-age-gauges
(let [metrics (make-metrics)
cfg {::db/pool th/*pool*
::mtx/metrics metrics}
now (ct/now)]
(th/db-insert! :job {:id (uuid/next)
:name "echo"
:tenant (cf/get :tenant)
:queue "default"
:params (db/json {})
:priority 100
:max-retries 3
:retry-num 0
:status "new"
:scheduled-at now
:created-at (ct/in-past {:minutes 2})
:modified-at now})
(jobs-metrics/sample-backlog cfg)
(t/is (= 1.0 (gauge-value metrics :jobs-backlog ["new"])))
(t/is (= 0.0 (gauge-value metrics :jobs-backlog ["completed"])))
(t/is (= 0.0 (gauge-value metrics :jobs-backlog ["aborted"])))
(t/is (>= (gauge-value metrics :jobs-oldest-pending-age []) 120.0))))
(t/deftest event-counter-has-no-labels-and-follows-the-events
(let [metrics (make-metrics)
cfg {::db/pool th/*pool*
::mtx/metrics metrics}
defs {:echo {::jobs/name :echo
::jobs/schema [:map]
::jobs/handler (fn [_context params] params)
::jobs/decoder identity
::jobs/validator (constantly true)}}
cfg2 (assoc cfg ::jobs/defs defs)
job-id (jobs/submit cfg2 {::jobs/name :echo ::jobs/params {}})]
(jobs/claim cfg2 job-id (:scheduled-at (jobs/get-job cfg2 job-id)))
(jobs/complete cfg2 :job-id job-id :result {:ok true})
(t/testing "one start and one end, counted together with no labels"
(t/is (= 2.0 (counter-value metrics :jobs-events-total []))))
(t/testing "a transition that affects no row adds no event and no count"
(t/is (= 0 (jobs/complete cfg2 :job-id job-id :result {:ok true})))
(t/is (= 2.0 (counter-value metrics :jobs-events-total []))))))
(t/deftest event-counter-follows-a-lifecycle-write-that-outlives-the-caller
(let [metrics (make-metrics)
defs {:echo {::jobs/name :echo
::jobs/schema [:map]
::jobs/handler (fn [_context params] params)
::jobs/decoder identity
::jobs/validator (constantly true)}}
cfg {::jobs/defs defs
::db/pool th/*pool*
::mtx/metrics metrics}
job-id (jobs/submit cfg {::jobs/name :echo ::jobs/params {}})]
(jobs/claim cfg job-id (:scheduled-at (jobs/get-job cfg job-id)))
(t/is (= 1.0 (counter-value metrics :jobs-events-total [])))
;; the completion runs inside a transaction that rolls back. It owns
;; its own, so the event and both counters survive the caller.
(db/tx-run! (assoc cfg ::db/rollback true)
(fn [{:keys [::db/conn]}]
(jobs/complete (assoc cfg ::db/conn conn)
:job-id job-id :result {:ok true})))
(t/testing "the end event is stored and counted"
(t/is (= 2.0 (counter-value metrics :jobs-events-total [])))
(t/is (= 2 (:cnt (th/db-exec-one! ["SELECT count(*) AS cnt FROM job_event"])))))
(t/testing "the terminal counter followed its own commit, not the caller one"
(t/is (= 1.0 (counter-value metrics :jobs-completed ["echo" "default" "completed"]))))))
(t/deftest progress-counter-follows-the-report-that-outlives-the-caller
(let [metrics (make-metrics)
defs {:echo {::jobs/name :echo
::jobs/schema [:map]
::jobs/handler (fn [_context params] params)
::jobs/decoder identity
::jobs/validator (constantly true)}}
cfg {::jobs/defs defs
::db/pool th/*pool*
::mtx/metrics metrics}
job-id (jobs/submit cfg {::jobs/name :echo ::jobs/params {}})]
(jobs/claim cfg job-id (:scheduled-at (jobs/get-job cfg job-id)))
(let [before (counter-value metrics :jobs-events-total [])]
(db/tx-run! (assoc cfg ::db/rollback true)
(fn [{:keys [::db/conn]}]
(jobs/heartbeat (assoc cfg ::db/conn conn)
:job-id job-id
:progress {:current 1}
::jobs/force? true)))
(t/testing "the report is stored and counted, the caller rollback drops neither"
(t/is (= 1 (:cnt (th/db-exec-one! ["SELECT count(*) AS cnt FROM job_event
WHERE job_id = ? AND kind = 'progress'"
job-id]))))
(t/is (= (inc before) (counter-value metrics :jobs-events-total [])))))))

308
backend/test/backend_tests/jobs_request_test.clj Normal file
View File

@ -0,0 +1,308 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS INC
(ns backend-tests.jobs-request-test
(:require
[app.common.generic-pool :as gpool]
[app.common.json :as json]
[app.common.time :as ct]
[app.config :as cf]
[app.db :as db]
[app.jobs :as jobs]
[app.main :as main]
[app.metrics :as mtx]
[app.metrics.definition :as-alias mdef]
[app.redis :as rds]
[app.worker :as wrk]
[backend-tests.helpers :as th]
[clojure.test :as t]
[cuerdas.core :as str]
[integrant.core :as ig])
(:import
io.lettuce.core.api.sync.RedisCommands
io.prometheus.client.Counter
io.prometheus.client.Counter$Child
java.lang.AutoCloseable))
(t/use-fixtures :once th/state-init)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HELPERS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- make-metrics []
(ig/init-key :app.metrics/metrics
{:default (select-keys main/default-metrics
[:jobs-requests-total
:jobs-request-timing])}))
(defn- make-pool
([] (make-pool (get th/*system* :app.metrics/metrics)))
([metrics]
(-> {::jobs/request-pool {::rds/client (get th/*system* :app.redis/client)
::mtx/metrics metrics}}
(ig/expand)
(ig/init)
(get ::jobs/request-pool))))
(defn- queue-key
[queue]
(wrk/queue-key (cf/get :tenant) queue))
(defn- make-cfg
[pool]
{::jobs/request-pool pool})
(defn- clear-queues
[]
(let [conn (rds/connect {::rds/client (get th/*system* :app.redis/client)
::mtx/metrics (get th/*system* :app.metrics/metrics)})]
(try
(let [cmd (.-cmd conn)
keys (vec (.keys ^RedisCommands cmd
(str jobs/reply-key-prefix ":" (cf/get :tenant) ":*")))]
(when (seq keys)
(rds/del conn keys))
(rds/del conn (queue-key :media)))
(finally
(rds/close conn)))))
(defn- test-fixture [next]
(th/database-reset
(fn []
(clear-queues)
(next))))
(t/use-fixtures :each test-fixture)
(defn- with-responder
"Start a responder on :media that answers the next request with the
provided response map (usually {:ok ...} or {:error ...}). Returns a
future that resolves to the decoded request payload [request-id,
reply-key, cmd, params]."
[pool response-fn & {:keys [delay-ms timeout-ms]}]
(let [timeout-ms (or timeout-ms 10000)
out (promise)]
(let [fut (future
(let [conn (rds/connect {::rds/client (get th/*system* :app.redis/client)
::mtx/metrics (get th/*system* :app.metrics/metrics)})]
(try
(when delay-ms
(Thread/sleep (long delay-ms)))
(let [key (queue-key :media)
[_ payload] (rds/blpop conn [key] (ct/duration {:millis timeout-ms}))]
(if (nil? payload)
(deliver out ::no-request)
(let [[request-id reply-key cmd params :as decoded] (json/decode payload)]
(deliver out decoded)
(jobs/reply {::rds/pool (::jobs/pool pool)
::mtx/metrics (::mtx/metrics pool)}
reply-key
(response-fn params)))))
(finally
(rds/close conn)))))]
{:future fut
:payload out})))
(defn- get-ttl
[key]
(let [conn (rds/connect {::rds/client (get th/*system* :app.redis/client)
::mtx/metrics (get th/*system* :app.metrics/metrics)})]
(try
(let [cmd (.-cmd conn)]
(.ttl ^RedisCommands cmd key))
(finally
(rds/close conn)))))
(defn- key-exists?
[key]
(let [conn (rds/connect {::rds/client (get th/*system* :app.redis/client)
::mtx/metrics (get th/*system* :app.metrics/metrics)})]
(try
(let [cmd (.-cmd conn)]
(pos? (.exists ^RedisCommands cmd (make-array String 1 key))))
(finally
(rds/close conn)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TESTS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- counter-value [metrics id labels]
(let [collector (mtx/get-collector metrics id)
instance (::mdef/instance collector)
child (.labels ^Counter instance (into-array String labels))]
(.get ^Counter$Child child)))
(t/deftest request-pool-keeps-its-own-metrics
(let [metrics-a (make-metrics)
metrics-b (make-metrics)
pool-a (make-pool metrics-a)
pool-b (make-pool metrics-b)]
(t/is (identical? metrics-a (::mtx/metrics pool-a)))
(t/is (identical? metrics-b (::mtx/metrics pool-b)))))
(t/deftest request-metrics-use-the-final-outcome
(let [metrics (make-metrics)
pool (make-pool metrics)
cfg (make-cfg pool)]
(with-responder pool (fn [_params] {:ok {:value 1}}))
(t/is (= {:value 1}
(jobs/request cfg {::jobs/queue :media
::jobs/cmd :process
::jobs/params {}})))
(t/is (= 1.0 (counter-value metrics :jobs-requests-total ["replied"])))
(t/is (thrown-with-msg? Exception #"timeout waiting for the job reply"
(jobs/request cfg {::jobs/queue :media
::jobs/cmd :process
::jobs/params {}
::jobs/timeout (ct/duration {:millis 100})})))
(t/is (= 1.0 (counter-value metrics :jobs-requests-total ["timeout"])))
(t/is (= 0.0 (counter-value metrics :jobs-requests-total ["sent"])))))
(t/deftest request-returns-the-ok-reply
(let [pool (make-pool)
cfg (make-cfg pool)
payload (with-responder pool (fn [_params] {:ok {:value 42}}))]
(let [result (jobs/request cfg {::jobs/queue :media
::jobs/cmd :process
::jobs/params {:x 1}})]
(t/is (= {:value 42} result)))
(t/testing "the worker receives the expected payload shape"
(let [[request-id reply-key cmd params :as decoded] (deref (:payload payload) 10000 ::timeout)]
(t/is (string? request-id))
(t/is (string? reply-key))
(t/is (str/starts-with? reply-key (str jobs/reply-key-prefix ":" (cf/get :tenant) ":")))
(t/is (= "process" cmd))
(t/is (= {"x" 1} params)
(str "params should be plain JSON: " (pr-str decoded)))))))
(t/deftest request-propagates-the-error-reply
(let [pool (make-pool)
cfg (make-cfg pool)
_ (with-responder pool
(fn [_params]
{:error {:code :processing-failed
:hint "something went wrong"}}))]
(t/is (thrown-with-msg? Exception #"something went wrong"
(jobs/request cfg {::jobs/queue :media
::jobs/cmd :process
::jobs/params {:x 1}})))))
(t/deftest request-times-out-and-cleans-the-reply-key
(let [pool (make-pool)
cfg (make-cfg pool)]
(t/is (thrown-with-msg? Exception #"timeout waiting for the job reply"
(jobs/request cfg {::jobs/queue :media
::jobs/cmd :process
::jobs/params {:x 1}
::jobs/timeout (ct/duration {:millis 500})})))
(t/testing "no orphan reply key is left behind"
;; there is no way to know the exact reply key (random request-id);
;; check no reply keys exist at all after the timeout
(let [conn (rds/connect {::rds/client (get th/*system* :app.redis/client)
::mtx/metrics (get th/*system* :app.metrics/metrics)})]
(try
(let [cmd (.-cmd conn)
keys (.keys ^RedisCommands cmd
(str jobs/reply-key-prefix ":" (cf/get :tenant) ":*"))]
(t/is (empty? (vec keys))))
(finally
(rds/close conn)))))))
(t/deftest request-pool-returns-connections-on-success-and-failure
(let [pool (make-pool)
cfg (make-cfg pool)
default-timeout (-> (cf/get-jobs-request-timeout)
(ct/plus (ct/duration {:seconds 30})))]
(t/testing "successful request does not consume the connection"
(with-responder pool (fn [_params] {:ok {:a 1}}))
(jobs/request cfg {::jobs/queue :media
::jobs/cmd :process
::jobs/params {:x 1}})
(t/testing "and the next request works with a pooled connection"
(with-responder pool (fn [_params] {:ok {:b 2}}))
(t/is (= {:b 2} (jobs/request cfg {::jobs/queue :media
::jobs/cmd :process
::jobs/params {:x 2}})))
(t/testing "connection command timeout is restored after use"
(with-open [^AutoCloseable pooled (gpool/get (::jobs/pool pool))]
(let [conn @pooled]
(t/is (= (.toMillis ^java.time.Duration default-timeout)
(.toMillis ^java.time.Duration (rds/get-timeout conn)))))))))))
(t/deftest request-supports-larger-per-call-timeout
(let [pool (make-pool)
cfg (make-cfg pool)
_ (with-responder pool (fn [_params] {:ok {:slow 1}}))]
(t/testing "an override bigger than the default works (command timeout raised per call)"
(t/is (= {:slow 1}
(jobs/request cfg {::jobs/queue :media
::jobs/cmd :process
::jobs/params {:x 1}
::jobs/timeout (ct/duration {:seconds 130})}))))))
(t/deftest request-raises-connection-timeout-to-per-call-override
(let [pool (make-pool)
cfg (make-cfg pool)
seen (atom nil)
orig rds/set-timeout
override (ct/duration {:seconds 999})
_ (with-responder pool (fn [_params] {:ok {:fast 1}}))]
;; an override above the pool default is honored, not capped
(with-redefs [rds/set-timeout (fn [conn timeout]
(reset! seen timeout)
(orig conn timeout))]
(t/is (= {:fast 1}
(jobs/request cfg {::jobs/queue :media
::jobs/cmd :process
::jobs/params {:x 1}
::jobs/timeout override}))))
(t/is (= (.toMillis ^java.time.Duration (ct/plus override (ct/duration {:seconds 30})))
(.toMillis ^java.time.Duration @seen)))))
(t/deftest late-reply-is-cleaned-by-the-worker-expire
(let [pool (make-pool)
cfg (make-cfg pool)
;; the responder replies 2s after the caller timeout (500ms)
responder (with-responder pool
(fn [_params] {:ok {:late 1}})
:delay-ms 2000)]
(t/is (thrown-with-msg? Exception #"timeout waiting for the job reply"
(jobs/request cfg {::jobs/queue :media
::jobs/cmd :process
::jobs/params {:x 1}
::jobs/timeout (ct/duration {:millis 500})})))
(t/testing "the late reply key exists (recreated by the worker) with a short TTL"
(deref (:future responder) 10000 ::timeout)
(let [conn (rds/connect {::rds/client (get th/*system* :app.redis/client)
::mtx/metrics (get th/*system* :app.metrics/metrics)})]
(try
(let [cmd (.-cmd conn)
keys (vec (.keys ^RedisCommands cmd
(str jobs/reply-key-prefix ":" (cf/get :tenant) ":*")))]
(t/is (= 1 (count keys)))
(let [ttl (.ttl ^RedisCommands cmd (first keys))]
(t/is (pos? ttl))
(t/is (<= ttl 60))))
(finally
(rds/close conn)))))))
(t/deftest request-creates-no-job-row
(let [pool (make-pool)
cfg (make-cfg pool)
_ (with-responder pool (fn [_params] {:ok {}}))]
(jobs/request cfg {::jobs/queue :media ::jobs/cmd :process ::jobs/params {}})
(t/is (zero? (:cnt (th/db-exec-one! ["SELECT count(*) AS cnt FROM job"]))))))

1434
backend/test/backend_tests/jobs_test.clj Normal file
View File

File diff suppressed because it is too large Load Diff

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

@ -12,6 +12,7 @@
[app.config :as cf]
[app.db :as db]
[app.http.client :as-alias http]
[app.jobs :as jobs]
[app.setup :as-alias setup]
[backend-tests.helpers :as th]
[clojure.test :as t]
@ -180,7 +181,10 @@
client (ig/init-key :app.nitrate/client
{::http/client (Object.)
::setup/shared-keys shared-keys})
handler (ig/init-key :app.loggers.audit.archive-task/handler
;; The archive job is a job-def: the handler closes over the
;; cfg it was given at init and takes a nil context, because
;; an in-process invocation has no job row to describe.
job-def (ig/init-key :app.loggers.audit.archive-task/job-def
{::db/pool (:app.db/pool th/*system*)
::setup/shared-keys shared-keys
::http/client (:app.http.client/client th/*system*)
@ -203,7 +207,7 @@
:context (db/tjson {})
:tracked-at (ct/now)
:created-at (ct/now)})]
(handler {:props {:uri archive-uri}})
((::jobs/handler job-def) nil {:uri archive-uri})
(t/is (= 1 (count @nitrate-bodies)))
(let [body (json/decode (first @nitrate-bodies) :key-fn json/read-kebab-key)
event (first (:events body))]

110
backend/test/backend_tests/loggers_webhooks_test.clj
View File

@ -6,9 +6,12 @@
(ns backend-tests.loggers-webhooks-test
(:require
[app.common.time :as ct]
[app.common.transit :as transit]
[app.common.uuid :as uuid]
[app.db :as db]
[app.http :as http]
[app.jobs :as jobs]
[app.storage :as sto]
[backend-tests.helpers :as th]
[clojure.test :as t]
@ -18,28 +21,50 @@
(t/use-fixtures :each th/database-reset)
(t/deftest process-event-handler-with-no-webhooks
(with-mocks [submit-mock {:target 'app.worker/submit! :return nil}]
(with-mocks [submit-mock {:target 'app.jobs/submit :return nil}]
(let [prof (th/create-profile* 1 {:is-active true})
res (th/run-task! :process-webhook-event
{:type "command"
:name "create-project"
:props {:team-id (:default-team-id prof)}})]
{:event-blob
(transit/encode-str
{:type "command"
:name "create-project"
:props {:team-id (:default-team-id prof)}})})]
(t/is (= 0 (:call-count @submit-mock)))
(t/is (nil? res)))))
(t/deftest process-event-handler
(with-mocks [submit-mock {:target 'app.worker/submit! :return nil}]
(with-mocks [submit-mock {:target 'app.jobs/submit :return nil}]
(let [prof (th/create-profile* 1 {:is-active true})
whk (th/create-webhook* {:team-id (:default-team-id prof)})
res (th/run-task! :process-webhook-event
{:type "command"
:name "create-project"
:props {:team-id (:default-team-id prof)}})]
{:event-blob
(transit/encode-str
{:type "command"
:name "create-project"
:props {:team-id (:default-team-id prof)}})})]
(t/is (= 1 (:call-count @submit-mock)))
(t/is (nil? res)))))
(t/deftest process-event-submits-consumed-config-subset
(with-mocks [submit-mock {:target 'app.jobs/submit :return nil}]
(let [prof (th/create-profile* 1 {:is-active true})
whk (th/create-webhook* {:team-id (:default-team-id prof)})]
(th/run-task! :process-webhook-event
{:event-blob
(transit/encode-str
{:type "command"
:name "create-project"
:props {:team-id (:default-team-id prof)}})})
(t/is (= 1 (:call-count @submit-mock)))
(let [options (second (:call-args @submit-mock))
config (get-in options [::jobs/params :config])]
(t/is (= #{:id :uri :mtype} (set (keys config))))
(t/is (= (:id whk) (:id config)))
(t/is (= (:uri whk) (:uri config)))
(t/is (= (:mtype whk) (:mtype config)))))))
(t/deftest run-webhook-handler-1
(with-mocks [http-mock {:target 'app.http.client/req :return {:status 200}}]
(let [prof (th/create-profile* 1 {:is-active true})
@ -48,7 +73,7 @@
:name "create-project"
:props {:team-id (:default-team-id prof)}}
res (th/run-task! :run-webhook
{:event evt
{:event (transit/encode-str evt)
:config whk})]
(t/is (= 1 (:call-count @http-mock)))
@ -70,7 +95,7 @@
:name "create-project"
:props {:team-id (:default-team-id prof)}}
res (th/run-task! :run-webhook
{:event evt
{:event (transit/encode-str evt)
:config whk})]
(t/is (= 1 (:call-count @http-mock)))
@ -88,11 +113,11 @@
;; RUN 2 times more
(th/run-task! :run-webhook
{:event evt
{:event (transit/encode-str evt)
:config whk})
(th/run-task! :run-webhook
{:event evt
{:event (transit/encode-str evt)
:config whk})
@ -105,3 +130,64 @@
(t/is (= "unexpected-status:400" (:error-code whk')))
(t/is (= 3 (:error-count whk')))
(t/is (false? (:is-active whk')))))))
(t/deftest webhook-json-round-trip-preserves-uuid-types
"Integration test: drives process-webhook-event through the real pipeline
(submit → decode → handler) to verify uuid types survive: the JSON hop
carries only the opaque transit blob, and the handler decodes the typed
event from it."
(with-mocks [http-mock {:target 'app.http.client/req :return {:status 200}}]
(let [prof (th/create-profile* 1 {:is-active true})
whk (th/create-webhook* {:team-id (:default-team-id prof)})
evt {:type "command"
:name "create-project"
:props {:team-id (:default-team-id prof)}}]
;; Submit the job through the real pipeline (this creates a job row)
(th/run-task! :process-webhook-event
{:event-blob (transit/encode-str evt)})
;; Now run the pending jobs (simulates dispatcher + runner)
;; This will decode the params from JSON and invoke the handler
(th/run-pending-jobs)
;; The handler should have been invoked and created a webhook_delivery row
;; If uuid types were lost, the lookup would fail with a type error
(let [rows (th/db-query :webhook-delivery {:webhook-id (:id whk)})]
(t/is (= 1 (count rows)))
(t/is (nil? (-> rows first :error-code))))
;; Refresh webhook
(let [whk' (th/db-get :webhook {:id (:id whk)})]
(t/is (nil? (:error-code whk')))))))
(t/deftest webhook-transit-round-trip-preserves-uuid-types
"The run-webhook event travels as the original transit blob inside the
JSON job props, so transit deliveries keep instant/UUID types (no wire
change vs the legacy worker), whatever shape the event has."
(with-mocks [http-mock {:target 'app.http.client/req :return {:status 200}}]
(let [prof (th/create-profile* 1 {:is-active true})
whk (th/create-webhook* {:team-id (:default-team-id prof)
:mtype "application/transit+json"})
evt {:type "command"
:name "create-project"
:created-at (ct/now)
:tracked-at (ct/now)
:props {:team-id (:default-team-id prof)
:comment-id (uuid/next)}}]
;; through the real pipeline: process submits run-webhook, the
;; runner decodes it from JSON and delivers it
(th/run-task! :process-webhook-event
{:event-blob (transit/encode-str evt)})
(th/run-pending-jobs)
(t/is (= 1 (:call-count @http-mock)))
(let [req (second (:call-args @http-mock))
event (transit/decode-str (:body req))]
(t/is (= "application/transit+json" (get-in req [:headers "content-type"])))
(t/is (uuid? (get-in event [:props :team-id])))
(t/is (uuid? (get-in event [:props :comment-id])))
(t/is (inst? (:created-at event)))
(t/is (inst? (:tracked-at event)))))))

18
backend/test/backend_tests/metrics_test.clj
View File

@ -6,6 +6,7 @@
(ns backend-tests.metrics-test
(:require
[app.common.exceptions :as ex]
[app.metrics :as mtx]
[app.metrics.definition :as-alias mdef]
[clojure.test :as t]
@ -93,6 +94,23 @@
(get-collector [_ _] collector))]
(t/is (true? (mtx/run! instance :id :x :inc 1 :labels ["ok"])))))
(t/deftest instance-resolves-the-metrics-from-a-cfg
;; the resolver is a map read and nothing more: it hands back the very
;; instance, not a copy and not a wrapper
(let [metrics (ig/init-key :app.metrics/metrics {:default {}})]
(t/is (identical? metrics (mtx/instance {::mtx/metrics metrics})))))
(t/deftest instance-raises-on-a-cfg-without-metrics
;; A missing instance is a wiring bug, and the resolver is the one place
;; that says so: a module that resolves it at the top of a write sees the
;; failure before anything is persisted.
(let [cause (try
(mtx/instance {})
(catch Throwable e e))]
(t/is (some? cause))
(t/is (= :missing-metrics (:code (ex-data cause))))
(t/is (re-find #"::mtx/metrics" (:hint (ex-data cause))))))
(t/deftest definitions-schema-accepts-all-consumed-keys
(t/is (true? (valid-definitions?
{:test-timing

218
backend/test/backend_tests/migrations_test.clj Normal file
View File

@ -0,0 +1,218 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS INC
(ns backend-tests.migrations-test
(:require
[app.db :as db]
[app.migrations :as migrations]
[app.util.migrations :as mg]
[backend-tests.helpers :as th]
[clojure.spec.alpha :as s]
[clojure.string :as str]
[clojure.test :as t]))
(t/use-fixtures :once th/state-init)
(t/deftest migrations-registry-satisfies-steps-spec
(t/testing "every entry is a {:name :fn} step (guards against stray forms)"
(t/is (s/valid? ::mg/steps migrations/migrations)
(s/explain-str ::mg/steps migrations/migrations))))
(defn- table-columns
[table]
(->> (th/db-exec! ["SELECT column_name FROM information_schema.columns
WHERE table_schema='public' AND table_name=?" table])
(map :column-name)
set))
(defn- table-indexes
[table]
(->> (th/db-exec! ["SELECT indexname FROM pg_indexes
WHERE schemaname='public' AND tablename=?" table])
(map :indexname)
set))
(defn- table-foreign-keys
[table]
(->> (th/db-exec! ["SELECT conname, confdeltype FROM pg_constraint
WHERE contype='f' AND conrelid = ?::regclass" table])
(map (fn [{:keys [conname confdeltype]}]
[conname confdeltype]))
set))
(defn- deferrable-foreign-keys
"Names of the deferrable foreign keys of a table."
[table]
(->> (th/db-exec! ["SELECT conname FROM pg_constraint
WHERE contype='f' AND condeferrable AND conrelid = ?::regclass" table])
(map :conname)
set))
(t/deftest job-table-exists-with-expected-columns
(t/is (= #{; dispatch/lifecycle columns
"id" "name" "tenant" "queue" "label" "priority" "scheduled_at"
"retry_num" "max_retries" "status" "created_at" "modified_at"
"started_at" "completed_at" "params"
; optional ledger columns
"profile_id" "error" "result"
"resource_id" "expires_at"}
(table-columns "job"))))
(t/deftest job-tenant-column-is-not-nullable
(t/testing "every job belongs to an instance, so the column is required"
(t/is (= "NO"
(:is-nullable (th/db-exec-one! ["SELECT is_nullable
FROM information_schema.columns
WHERE table_name = ?
AND column_name = ?"
"job" "tenant"]))))))
(t/deftest job-queue-stores-the-bare-queue-name
(let [job-id (th/mk-uuid "job-bare-queue")]
(th/db-insert! :job {:id job-id
:name "test"
:tenant "acme"
:queue "webhooks"})
(try
(t/is (= "acme" (:tenant (th/db-get :job {:id job-id}))))
(t/is (= "webhooks" (:queue (th/db-get :job {:id job-id}))))
(t/testing "the tenant is not smuggled inside the queue"
(t/is (not (str/includes? (:queue (th/db-get :job {:id job-id})) "acme"))))
(finally
(th/db-force-delete :job {:id job-id})))))
(t/deftest job-table-has-no-target-nor-progress-columns
(t/testing "target and job.progress are gone: progress lives in job_event"
(t/is (empty? (filter #{"target" "progress"} (table-columns "job"))))))
(t/deftest job-event-table-exists-with-expected-columns
(t/is (= #{"id" "job_id" "kind" "payload" "created_at"}
(table-columns "job_event"))))
(t/deftest job-event-kind-check-rejects-unknown-kinds
(let [job-id (th/mk-uuid "job-event-check")]
(th/db-insert! :job {:id job-id
:name "test"
:tenant "acme"
:queue "default"})
(try
(t/testing "the four lifecycle kinds are accepted"
(doseq [kind ["start" "progress" "retry" "end"]]
(t/is (some? (th/db-insert! :job-event {:job-id job-id
:kind kind})))))
(t/testing "any other kind is rejected"
(t/is (thrown? Exception
(th/db-insert! :job-event {:job-id job-id
:kind "unknown"}))))
(finally
(th/db-force-delete :job {:id job-id})))))
(t/deftest job-event-index-serves-the-history-read
(let [indexdef (:indexdef (th/db-exec-one! ["SELECT indexdef FROM pg_indexes
WHERE schemaname = 'public'
AND tablename = 'job_event'
AND indexname = 'job_event__job_kind_created_idx'"]))]
(t/is (str/includes? indexdef "(job_id, kind, created_at DESC, id DESC)"))))
(t/deftest job-event-cascades-on-job-deletion
(let [job-id (th/mk-uuid "job-event-cascade")]
(th/db-insert! :job {:id job-id :name "test" :tenant "acme" :queue "default"})
(th/db-insert! :job-event {:job-id job-id :kind "progress"})
(t/is (= 1 (:cnt (th/db-exec-one! ["SELECT count(*) AS cnt FROM job_event WHERE job_id = ?" job-id]))))
(th/db-force-delete :job {:id job-id})
(t/is (= 0 (:cnt (th/db-exec-one! ["SELECT count(*) AS cnt FROM job_event WHERE job_id = ?" job-id]))))))
(t/deftest job-event-foreign-key-is-deferrable
(t/testing "every new job reference is DEFERRABLE"
(t/is (contains? (deferrable-foreign-keys "job_event") "job_event_job_id_fkey"))))
(t/deftest job-table-has-expected-indexes
(t/is (contains? (table-indexes "job") "job__dispatcher__idx"))
(t/is (contains? (table-indexes "job") "job__orphan__idx"))
(t/is (contains? (table-indexes "job") "job__profile__idx")))
(defn- indexdef
[index-name]
(:indexdef (th/db-exec-one! ["SELECT indexdef FROM pg_indexes
WHERE schemaname = 'public'
AND tablename = 'job'
AND indexname = ?" index-name])))
(t/deftest job-dispatcher-index-serves-ordering
(let [def (indexdef "job__dispatcher__idx")]
(t/testing "tenant leads because the filter is an equality it can answer"
(t/is (str/includes? def "(tenant, priority DESC, scheduled_at)")))
(t/testing "status only in the predicate, it is not a key column"
(t/is (str/includes? def "WHERE"))
(t/is (not (str/includes? def "(status, scheduled_at)"))))
(t/testing "queue does not lead: the dispatcher claims every queue of the tenant"
(t/is (not (str/includes? def "(tenant, queue"))))))
(t/deftest job-sweep-indexes-are-tenant-scoped
(t/testing "orphan sweep"
(t/is (str/includes? (indexdef "job__orphan__idx") "(tenant, modified_at)")))
(t/testing "reschedule of lost scheduled rows"
(t/is (str/includes? (indexdef "job__scheduled__idx") "(tenant, scheduled_at)")))
(t/testing "cron no-overlap check and submit dedupe"
(t/is (str/includes? (indexdef "job__name_label__idx") "(tenant, name, queue, label)"))))
(t/deftest job-table-has-sweep-path-indexes
(t/testing "jobs-GC expiration scan"
(t/is (contains? (table-indexes "job") "job__expires__idx")))
(t/testing "jobs-GC retention scan"
(t/is (contains? (table-indexes "job") "job__retention__idx"))))
(t/deftest job-table-has-expected-foreign-keys
(t/testing "profile_id keeps profile deletion explicit (no action)"
(t/is (contains? (table-foreign-keys "job")
["job_profile_id_fkey" "a"])))
(t/testing "resource_id is set to null when the storage object is deleted"
(t/is (contains? (table-foreign-keys "job")
["job_resource_id_fkey" "n"]))))
(t/deftest job-status-check-constraint-rejects-unknown-statuses
(t/is (thrown? Exception
(th/db-insert! :job {:id (th/mk-uuid "job-check")
:name "test"
:tenant "acme"
:queue "default"
:status "unknown"}))))
(t/deftest job-status-check-constraint-accepts-known-statuses
(doseq [status ["new" "scheduled" "running" "retry"
"completed" "failed" "cancelled" "aborted"]]
(th/db-insert! :job {:id (th/mk-uuid "job-status" status)
:name "test"
:tenant "acme"
:queue "default"
:status status})
(let [{:keys [status priority retry-num max-retries params scheduled-at
created-at modified-at]}
(-> (th/db-get :job {:id (th/mk-uuid "job-status" status)} :status
:priority :retry-num :max-retries :params :scheduled-at
:created-at :modified-at)
(update :params db/decode-json-pgobject))]
(t/is (= status status))
(t/is (= 100 priority))
(t/is (= 0 retry-num))
(t/is (= 3 max-retries))
(t/is (= {} params))
(t/is (some? scheduled-at))
(t/is (some? created-at))
(t/is (some? modified-at))
(th/db-force-delete :job {:id (th/mk-uuid "job-status" status)}))))
(t/deftest job-has-only-the-deletion-protection-trigger
(let [triggers (->> (th/db-exec! ["SELECT tgname FROM pg_trigger
WHERE tgrelid = ?::regclass
AND NOT tgisinternal" "job"])
(map :tgname)
set)]
(t/testing "no modified-at trigger: the application updates it"
(t/is (not (contains? triggers "job__modified_at__tgr"))))
(t/testing "deletion protection is the only trigger on job"
(t/is (= #{"deletion_protection__tgr"} triggers)))))

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

@ -9,8 +9,8 @@
[app.auth :as auth]
[app.common.time :as ct]
[app.config :as cf]
[app.jobs :as jobs]
[app.rpc.commands.profile :as profile]
[app.worker :as wrk]
[backend-tests.helpers :as th]
[clojure.test :as t]))
@ -80,8 +80,8 @@
(t/deftest create-demo-profile-uses-global-delay-by-default
(with-redefs [cf/flags (conj cf/flags :demo-users)]
(let [captured (atom nil)]
(with-redefs [wrk/submit! (fn [& {:keys [::wrk/task ::wrk/delay]}]
(reset! captured {:task task :delay delay}))]
(with-redefs [jobs/submit (fn [_cfg {:keys [::jobs/name ::jobs/delay]}]
(reset! captured {:task name :delay delay}))]
(let [{:keys [error result]} (th/command! {::th/type :create-demo-profile})]
(t/is (nil? error))
(t/is (some? (:email result)))
@ -91,8 +91,8 @@
(t/deftest create-demo-profile-accepts-short-expires-in
(with-redefs [cf/flags (conj cf/flags :demo-users)]
(let [captured (atom nil)]
(with-redefs [wrk/submit! (fn [& {:keys [::wrk/task ::wrk/delay]}]
(reset! captured {:task task :delay delay}))]
(with-redefs [jobs/submit (fn [_cfg {:keys [::jobs/name ::jobs/delay]}]
(reset! captured {:task name :delay delay}))]
(let [{:keys [error result]} (th/command! {::th/type :create-demo-profile
:expires-in "10m"})]
(t/is (nil? error))

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

@ -7,9 +7,17 @@
(ns backend-tests.rpc-feedback-test
(:require
[app.common.schema :as sm]
[app.config :as cf]
[app.db :as db]
[app.email :as eml]
[app.rpc :as-alias rpc]
[app.rpc.commands.feedback :as feedback]
[backend-tests.helpers :as th]
[clojure.test :as t]))
(t/use-fixtures :once th/state-init)
(t/use-fixtures :each th/database-reset)
(t/deftest send-user-feedback-schema-validation
(let [schema feedback/schema:send-user-feedback]
@ -37,3 +45,20 @@
:content "Test content"
:error-report (apply str (repeat 1048577 "x"))}]
(t/is (not (sm/valid? schema params)))))))
(t/deftest send-user-feedback-reaches-send-with-connection
(with-redefs [cf/flags (conj cf/flags :user-feedback)
cf/config (assoc cf/config :user-feedback-destination "fb@example.com")]
(let [profile (th/create-profile* 1 {})
captured (atom nil)]
(with-redefs [eml/send (fn [cfg params]
(reset! captured {:cfg cfg :params params})
nil)]
(let [{:keys [error]} (th/command! {::th/type :send-user-feedback
::rpc/profile-id (:id profile)
:subject "s"
:content "c"})]
(t/is (nil? error))))
(t/testing "send! is reached with a caller connection"
(t/is (some? (:cfg @captured)))
(t/is (some? (::db/conn (:cfg @captured))))))))

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

@ -131,7 +131,7 @@
(t/is (= (:code data) :system-snapshots-cant-be-deleted)))))
;; this will run pending task triggered by deleting user snapshot
(th/run-pending-tasks!)
(th/run-pending-jobs)
(binding [ct/*clock* (ct/fixed-clock (ct/in-future {:days 8}))]
(let [res (th/run-task! :objects-gc {})]

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

@ -717,7 +717,7 @@
;; Now that objects-gc have deleted the object thumbnail lets
;; execute the touched-gc task
(let [res (binding [ct/*clock* (ct/fixed-clock (ct/in-future {:hours 3}))]
(th/run-task! "storage-gc-touched" {}))]
(th/run-task! :storage-gc-touched {}))]
(t/is (= 1 (:freeze res))))
;; check file media objects
@ -1083,7 +1083,7 @@
out (th/command! params)]
(t/is (nil? (:error out))))
(th/run-pending-tasks!)
(th/run-pending-jobs)
;; query the list of files after soft deletion
(let [data {::th/type :get-project-files
@ -1528,7 +1528,7 @@
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)}))))
;; The FileGC task will schedule an inner taskq
(th/run-pending-tasks!)
(th/run-pending-jobs)
(let [res (binding [ct/*clock* (ct/fixed-clock (ct/in-future {:hours 3}))]
(th/run-task! :storage-gc-touched {}))]
@ -2218,6 +2218,9 @@
:id (:id library)})
;; The task swallows absorption errors, so verify the persisted result.
;; Absorption runs inside the job, and the job only gets the
;; components of its own cfg, so this also needs
;; `:app.tasks.delete-object/job-def` to carry `::sto/storage`.
(let [deleted (db/get* th/*pool* :file {:id (:id library)}
{::db/remove-deleted false})
out (th/command! {::th/type :get-file
@ -2377,7 +2380,7 @@
(t/is (nil? (:error out)))
(t/is (nil? (:result out)))
(th/run-pending-tasks!)
(th/run-pending-jobs)
;; get deleted files
(let [data {::th/type :get-team-deleted-files

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

@ -86,7 +86,7 @@
;; run the task again
(let [res (binding [ct/*clock* (ct/fixed-clock (ct/in-future {:hours 3}))]
(th/run-task! "storage-gc-touched" {}))]
(th/run-task! :storage-gc-touched {}))]
(t/is (= 2 (:freeze res))))
(let [[row1 row2 :as rows] (th/db-query :file-tagged-object-thumbnail

418
backend/test/backend_tests/rpc_management_jobs_test.clj Normal file
View File

@ -0,0 +1,418 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS INC
(ns backend-tests.rpc-management-jobs-test
(:require
[app.common.logging :as l]
[app.common.time :as ct]
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
[app.jobs :as jobs]
[app.metrics :as-alias mtx]
[backend-tests.helpers :as th]
[clojure.test :as t]))
(t/use-fixtures :once th/state-init)
(defn- make-cfg []
{::db/pool th/*pool*
::mtx/metrics (get th/*system* :app.metrics/metrics)})
(defn- test-fixture [next]
(th/database-reset next))
(t/use-fixtures :each test-fixture)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HELPERS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- mk-job
[{:keys [name status params scheduled-at]
:or {name "media-process"
status "new"
params {:x 1}
scheduled-at (ct/now)}}]
(let [id (uuid/next)]
(th/db-insert! :job {:id id
:name name
:tenant (cf/get :tenant)
:queue "media"
:params (db/json params)
:priority 100
:max-retries 3
:retry-num 0
:status status
:scheduled-at scheduled-at
:created-at (ct/now)
:modified-at (ct/now)})
id))
(defn- get-row
[id]
(let [row (th/db-get :job {:id id}
:status :result :error
:started-at :completed-at :modified-at)]
(reduce (fn [row key]
(update row key #(cond-> % (db/pgobject? %) db/decode-json-pgobject)))
row
[:result :error])))
(def ^:private test-error
{:type :internal
:code :boom
:hint "boom"})
(defn- get-progresss
"Progress events of a job, oldest first, with decoded payloads."
[id]
(->> (th/db-exec! ["SELECT payload FROM job_event
WHERE job_id = ? AND kind = 'progress'
ORDER BY created_at ASC, id ASC"
id])
(mapv #(db/decode-json-pgobject (:payload %)))))
(defn- mgmt
[type params]
(th/management-command! (assoc params ::th/type type)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TESTS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(t/deftest claim-job-returns-run-with-name-and-params
(let [scheduled-at (ct/now)
job-id (mk-job {:scheduled-at scheduled-at
:params {:command :process :file-id (str (uuid/next))}})
out (mgmt :claim-job {:job-id job-id
:scheduled-at scheduled-at})]
(t/is (nil? (:error out)))
(t/is (= {:action :run
:name "media-process"
:params {:command "process"
:file-id (get-in out [:result :params :file-id])}}
(:result out)))
(let [row (get-row job-id)]
(t/is (= "running" (:status row)))
(t/is (some? (:started-at row))))))
(t/deftest claim-job-skips-on-stale-scheduled-at
(let [job-id (mk-job {})
out (mgmt :claim-job {:job-id job-id
:scheduled-at (ct/in-future {:minutes 5})})]
(t/is (nil? (:error out)))
(t/is (= {:action :skip} (:result out)))
(t/is (= "new" (:status (get-row job-id))))))
(t/deftest claim-job-skips-terminal-and-cancelled-rows
(let [completed-id (mk-job {:status "completed"})
cancelled-id (mk-job {:status "cancelled"})
aborted-id (mk-job {:status "aborted"})]
(t/is (= {:action :skip}
(:result (mgmt :claim-job {:job-id completed-id
:scheduled-at (ct/now)}))))
(t/is (= {:action :skip}
(:result (mgmt :claim-job {:job-id cancelled-id
:scheduled-at (ct/now)}))))
(t/is (= {:action :skip}
(:result (mgmt :claim-job {:job-id aborted-id
:scheduled-at (ct/now)}))))
(t/is (= "completed" (:status (get-row completed-id))))
(t/is (= "cancelled" (:status (get-row cancelled-id))))
(t/is (= "aborted" (:status (get-row aborted-id))))))
(t/deftest claim-job-skips-missing-row
(t/is (= {:action :skip}
(:result (mgmt :claim-job {:job-id (uuid/next)
:scheduled-at (ct/now)})))))
(t/deftest claim-job-validates-params
(let [out (mgmt :claim-job {:job-id (uuid/next)})]
(t/is (= :validation (th/ex-type (:error out))))))
(t/deftest report-job-progress-appends-a-progress-event
(let [job-id (mk-job {})
_ (jobs/claim (make-cfg) job-id (:scheduled-at (th/db-get :job {:id job-id} :id :scheduled-at)))
out (mgmt :report-job-progress {:job-id job-id
:progress {:total 100 :current 50}})]
(t/is (nil? (:error out)))
(t/is (= {:action :run} (:result out)))
(t/is (= [{:total 100 :current 50}] (get-progresss job-id)))
(t/testing "the job row has no progress column anymore"
(t/is (not (contains? (get-row job-id) :progress))))))
(t/deftest report-job-progress-noop-on-terminal-row
(let [job-id (mk-job {:status "completed"})
out (mgmt :report-job-progress {:job-id job-id
:progress {:total 100 :current 100}})]
(t/is (nil? (:error out)))
(t/is (= {:action :skip} (:result out)))
(t/is (= [] (get-progresss job-id)))))
(t/deftest report-job-progress-persists-rapid-reports
(let [job-id (mk-job {})
_ (jobs/claim (make-cfg) job-id (:scheduled-at (th/db-get :job {:id job-id} :id :scheduled-at)))
_ (mgmt :report-job-progress {:job-id job-id
:progress {:total 10 :current 3}})
_ (mgmt :report-job-progress {:job-id job-id
:progress {:total 10 :current 4}})]
(t/testing "the second immediate report is not throttled away"
(t/is (= [{:total 10 :current 3}
{:total 10 :current 4}]
(get-progresss job-id))))))
(t/deftest report-job-progress-validates-the-payload
(let [job-id (mk-job {})
_ (jobs/claim (make-cfg) job-id (:scheduled-at (th/db-get :job {:id job-id} :id :scheduled-at)))]
(t/testing "current is mandatory"
(t/is (= :validation (th/ex-type (:error (mgmt :report-job-progress
{:job-id job-id
:progress {:total 10}}))))))
(t/testing "no extra key is accepted"
(t/is (= :validation (th/ex-type (:error (mgmt :report-job-progress
{:job-id job-id
:progress {:current 1
:message "boom"}}))))))
(t/is (= [] (get-progresss job-id)))))
(t/deftest complete-job-marks-completed-with-result
(let [cfg (make-cfg)
job-id (mk-job {})
_ (jobs/claim cfg job-id (:scheduled-at (th/db-get :job {:id job-id} :id :scheduled-at)))
out (mgmt :complete-job {:job-id job-id
:result {:value 42}})]
(t/is (nil? (:error out)))
(t/is (= {:action :run} (:result out)))
(let [row (get-row job-id)]
(t/is (= "completed" (:status row)))
(t/is (= {:value 42} (:result row)))
(t/is (some? (:completed-at row))))))
(t/deftest complete-job-accepts-nested-result
(let [cfg (make-cfg)
job-id (mk-job {})
_ (jobs/claim cfg job-id (:scheduled-at (th/db-get :job {:id job-id} :id :scheduled-at)))
result {:value 42 :nested {:items [1 2 {:three 3}] :ok true}}
out (mgmt :complete-job {:job-id job-id :result result})]
(t/is (nil? (:error out)))
(let [row (get-row job-id)]
(t/is (= "completed" (:status row)))
(t/is (= result (:result row))))))
(t/deftest complete-job-without-result-stores-null
(let [cfg (make-cfg)
job-id (mk-job {})
_ (jobs/claim cfg job-id (:scheduled-at (th/db-get :job {:id job-id} :id :scheduled-at)))
out (mgmt :complete-job {:job-id job-id :result nil})]
(t/is (nil? (:error out)))
(let [row (get-row job-id)]
(t/is (= "completed" (:status row)))
(t/is (nil? (:result row))))))
(t/deftest complete-job-with-unserializable-result-stores-null
(let [cfg (make-cfg)
job-id (mk-job {})
_ (jobs/claim cfg job-id (:scheduled-at (th/db-get :job {:id job-id} :id :scheduled-at)))]
(jobs/complete cfg :job-id job-id :result (Object.))
(let [row (get-row job-id)]
(t/is (= "completed" (:status row)))
(t/is (nil? (:result row))))))
(t/deftest complete-job-with-unserializable-result-logs-job-name
(let [cfg (make-cfg)
job-id (mk-job {:name "media-process"})
_ (jobs/claim cfg job-id (:scheduled-at (th/db-get :job {:id job-id} :id :scheduled-at)))
captured (atom nil)]
(with-redefs [l/emit-log (fn [props _cause _ctx _logger _level _sync?]
(reset! captured (into {} @props)))]
(jobs/complete cfg :job-id job-id :result (Object.)))
(let [row (get-row job-id)]
(t/is (= "completed" (:status row)))
(t/is (nil? (:result row)))
(t/testing "the serialization warning carries the job name"
(t/is (= "media-process" (:job-name @captured)))))))
(t/deftest complete-and-fail-clean-throttle-state
(let [cfg (make-cfg)
job-id1 (mk-job {})
job-id2 (mk-job {})]
(jobs/claim cfg job-id1 (:scheduled-at (th/db-get :job {:id job-id1} :id :scheduled-at)))
(jobs/claim cfg job-id2 (:scheduled-at (th/db-get :job {:id job-id2} :id :scheduled-at)))
(jobs/heartbeat cfg :job-id job-id1)
(jobs/heartbeat cfg :job-id job-id2 :progress {:current 1})
(jobs/complete cfg :job-id job-id1)
(jobs/fail cfg job-id2 test-error)
(t/is (not (contains? @@#'jobs/heartbeats job-id1)))
(t/is (not (contains? @@#'jobs/progresses job-id2)))))
(t/deftest complete-and-fail-respect-first-terminal-wins
(let [cfg (make-cfg)
running-id (mk-job {})
orphan-id (mk-job {:status "aborted"})
_ (jobs/claim cfg running-id
(:scheduled-at (th/db-get :job {:id running-id} :id :scheduled-at)))]
;; a running job completes; a later complete/fail on the same row is a no-op
(t/is (= 1 (jobs/complete cfg :job-id running-id :result {:value 1})))
(t/is (= 0 (jobs/complete cfg :job-id running-id :result {:value 2})))
(t/is (= 0 (jobs/fail cfg running-id test-error)))
(t/is (= {:value 1} (:result (get-row running-id))))
;; an orphan (aborted by the dispatcher) is never overwritten
(t/is (= 0 (jobs/complete cfg :job-id orphan-id :result {:value 3})))
(t/is (= 0 (jobs/fail cfg orphan-id test-error)))))
(t/deftest fail-job-marks-failed-with-error
(let [cfg (make-cfg)
job-id (mk-job {})
_ (jobs/claim cfg job-id (:scheduled-at (th/db-get :job {:id job-id} :id :scheduled-at)))
out (mgmt :fail-job {:job-id job-id
:error {:type :internal
:code "processing-error"
:hint "bad image"}})]
(t/is (nil? (:error out)))
(let [row (get-row job-id)]
(t/is (= "failed" (:status row)))
(t/is (= {:type "internal"
:code "processing-error"
:hint "bad image"}
(:error row))))))
(t/deftest fail-job-validates-params
(let [job-id (mk-job {})]
(t/is (= :validation (th/ex-type (:error (mgmt :fail-job {:job-id job-id})))))))
(t/deftest terminal-writers-report-skip-on-terminal-rows
(let [done-id (mk-job {:status "completed"})]
(t/testing "complete on a terminal row reports skip"
(let [out (mgmt :complete-job {:job-id done-id :result {:x 1}})]
(t/is (nil? (:error out)))
(t/is (= {:action :skip} (:result out)))))
(t/testing "fail on a terminal row reports skip"
(let [out (mgmt :fail-job {:job-id done-id
:error {:type :internal
:code "processing-error"
:hint "bad image"}})]
(t/is (nil? (:error out)))
(t/is (= {:action :skip} (:result out)))))
(t/testing "progress on a terminal row reports skip"
(let [out (mgmt :report-job-progress {:job-id done-id
:progress {:total 10 :current 4}})]
(t/is (nil? (:error out)))
(t/is (= {:action :skip} (:result out))))))
(let [cfg (make-cfg)
job-id (mk-job {})
_ (jobs/claim cfg job-id (:scheduled-at (th/db-get :job {:id job-id} :id :scheduled-at)))]
(t/testing "live paths report run"
(t/is (= {:action :run}
(:result (mgmt :report-job-progress {:job-id job-id
:progress {:total 10 :current 4}}))))
(t/is (= {:action :run}
(:result (mgmt :complete-job {:job-id job-id
:result {:x 1}})))))))
(t/deftest complete-job-associates-a-resource-id
(let [cfg (make-cfg)
resource-id (uuid/next)]
(th/db-insert! :storage-object {:id resource-id :backend "test"})
(let [job-id (mk-job {})]
(jobs/claim cfg job-id (:scheduled-at (th/db-get :job {:id job-id} :id :scheduled-at)))
(t/is (nil? (:error (mgmt :complete-job {:job-id job-id
:result {:v 1}
:resource-id resource-id}))))
(t/is (= resource-id (:resource-id (get-row job-id)))))))
(t/deftest complete-job-refuses-a-second-resource-id
(let [cfg (make-cfg)
first (uuid/next)
second (uuid/next)]
(doseq [id [first second]]
(th/db-insert! :storage-object {:id id :backend "test"}))
(let [job-id (mk-job {})]
(th/db-update! :job {:resource-id first} {:id job-id})
(jobs/claim cfg job-id (:scheduled-at (th/db-get :job {:id job-id} :id :scheduled-at)))
(let [out (mgmt :complete-job {:job-id job-id
:result {:v 1}
:resource-id second})]
(t/is (= :validation (th/ex-type (:error out)))))
(t/testing "the job keeps the resource it had and is still running"
(let [row (get-row job-id)]
(t/is (= first (:resource-id row)))
(t/is (= "running" (:status row))))))))
(t/deftest complete-job-on-a-finished-job-skips-instead-of-refusing-the-resource
(let [cfg (make-cfg)
first (uuid/next)
second (uuid/next)]
(doseq [id [first second]]
(th/db-insert! :storage-object {:id id :backend "test"}))
(let [job-id (mk-job {})]
(jobs/claim cfg job-id (:scheduled-at (th/db-get :job {:id job-id} :id :scheduled-at)))
(t/is (= {:action :run}
(:result (mgmt :complete-job {:job-id job-id
:result {:v 1}
:resource-id first}))))
(t/testing "the job is already finished, so there is no resource left to refuse"
(let [out (mgmt :complete-job {:job-id job-id
:result {:v 2}
:resource-id second})]
(t/is (nil? (:error out)))
(t/is (= {:action :skip} (:result out)))))
(t/testing "the row keeps the resource it was given and no event is added"
(let [row (get-row job-id)]
(t/is (= first (:resource-id row)))
(t/is (= "completed" (:status row)))
(t/is (= 1 (:cnt (th/db-exec-one! ["SELECT count(*) AS cnt FROM job_event
WHERE job_id = ? AND kind = 'end'"
job-id])))))))))
(t/deftest complete-job-validates-the-resource-id
(let [cfg (make-cfg)
job-id (mk-job {})]
(jobs/claim cfg job-id (:scheduled-at (th/db-get :job {:id job-id} :id :scheduled-at)))
(t/is (= :validation
(th/ex-type (:error (mgmt :complete-job {:job-id job-id
:result {:v 1}
:resource-id "not-a-uuid"})))))))
(t/deftest fail-job-validates-the-error-shape
(let [cfg (make-cfg)
run (fn [error]
(let [job-id (mk-job {})]
(jobs/claim cfg job-id
(:scheduled-at (th/db-get :job {:id job-id} :id :scheduled-at)))
[(mgmt :fail-job {:job-id job-id :error error}) job-id]))]
(t/testing "hint is required"
(t/is (= :validation
(th/ex-type (:error (first (run {:type :internal
:code :processing-error})))))))
(t/testing "a string code over the wire decodes into the keyword"
(let [[out job-id] (run {:type :internal
:code "processing-error"
:hint "bad image"})]
(t/is (nil? (:error out)))
(t/is (= {:type :internal :code :processing-error :hint "bad image"}
(jobs/decode-job-error (:error (get-row job-id)))))))
(t/testing "a keyword error is stored and decodes back untouched"
(let [[out job-id] (run {:type :internal
:code :processing-error
:hint "bad image"})]
(t/is (nil? (:error out)))
(t/is (= {:type :internal :code :processing-error :hint "bad image"}
(jobs/decode-job-error (:error (get-row job-id)))))))
(t/testing "worker-defined extra details are kept"
(let [[out job-id] (run {:type :internal
:code :processing-error
:hint "bad image"
:attempt 3})]
(t/is (nil? (:error out)))
(t/is (= 3 (:attempt (jobs/decode-job-error (:error (get-row job-id))))))))))

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

@ -14,12 +14,12 @@
[app.db :as db]
[app.email :as eml]
[app.http :as-alias http]
[app.jobs :as jobs]
[app.msgbus :as mbus]
[app.nitrate :as nitrate]
[app.rpc :as-alias rpc]
[app.rpc.commands.profile :as profile]
[app.util.ssrf :as ssrf]
[app.worker :as wrk]
[backend-tests.helpers :as th]
[clojure.set :as set]
[clojure.test :as t]
@ -53,7 +53,7 @@
(t/deftest create-and-update-organization-invitations-audit-props
(let [owner-id-ref (atom nil)]
(with-mocks [email-mock {:target 'app.email/send! :return nil}
(with-mocks [email-mock {:target 'app.email/send :return nil}
audit-mock {:target 'app.loggers.audit/submit :return nil}
nitrate-mock {:target 'app.nitrate/call
:return (fn [_cfg method params]
@ -102,7 +102,7 @@
(t/deftest invite-to-organization-rejects-non-owner
(let [organization-summary-ref (atom nil)]
(with-mocks [email-mock {:target 'app.email/send! :return nil}
(with-mocks [email-mock {:target 'app.email/send :return nil}
nitrate-mock {:target 'app.nitrate/call
:return (fn [_cfg method _params]
(when (= method :get-organization-summary)
@ -130,7 +130,7 @@
(t/is (not (:called? @email-mock)))))))
(t/deftest invite-to-organization-rejects-unknown-organization
(with-mocks [email-mock {:target 'app.email/send! :return nil}
(with-mocks [email-mock {:target 'app.email/send :return nil}
nitrate-mock {:target 'app.nitrate/call :return nil}]
(let [profile (th/create-profile* 105 {:is-active true})
organization-id (uuid/random)
@ -149,7 +149,7 @@
(t/deftest invite-to-organization-uses-authoritative-branding
(let [organization-summary-ref (atom nil)]
(with-mocks [email-mock {:target 'app.email/send! :return nil}
(with-mocks [email-mock {:target 'app.email/send :return nil}
nitrate-mock {:target 'app.nitrate/call
:return (fn [_cfg method _params]
(when (= method :get-organization-summary)
@ -175,7 +175,7 @@
:logo "https://evil.example/logo.png"
:avatar-bg-url "https://evil.example/avatar.svg"
:sso-active false}})
email-params (first (:call-args @email-mock))
email-params (second (:call-args @email-mock))
organization (:organization email-params)]
(t/is (th/success? out))
(t/is (= "Trusted Organization" (:name organization)))
@ -488,7 +488,7 @@
@organization-summary-ref
nil))}
;; --- Worker mock: capture delete-task submission ---
wrk-mock {:target 'app.worker/submit! :return nil}
wrk-mock {:target 'app.jobs/submit :return nil}
;; --- Message bus mock: capture published events ---
mbus-mock {:target 'app.msgbus/pub! :return nil}]
@ -587,7 +587,7 @@
:get-owned-organizations @owned-organizations-ref
nil))}
;; --- Worker mock: capture delete-task submissions ---
wrk-mock {:target 'app.worker/submit! :return nil}
wrk-mock {:target 'app.jobs/submit :return nil}
;; --- Message bus mock: capture published events ---
mbus-mock {:target 'app.msgbus/pub! :return nil}]
@ -1834,8 +1834,8 @@
nil))
nil))}
;; --- Email mock: capture sent emails ---
email-mock {:target 'app.email/send!
:return (fn [params] (swap! sent conj params) nil)}]
email-mock {:target 'app.email/send
:return (fn [_cfg params] (swap! sent conj params) nil)}]
;; --- Setup: create profiles, team, organization-summary ---
(let [owner (th/create-profile* 1 {:is-active true :fullname "Owner"})
@ -1912,7 +1912,7 @@
:organization-id (uuid/random)
:updated-props false
:announce-activation false}]
(with-redefs [eml/send! (fn [params] (swap! sent conj params))]
(with-redefs [eml/send (fn [_cfg params] (swap! sent conj params))]
(th/management-command! params))
(t/is (empty? @sent))))
@ -2099,32 +2099,32 @@
(t/deftest send-renewal-email-falls-back-to-profile-fullname-when-name-is-nil
;; `nil` user-name means "no override": the RPC must look up the
;; account owner's real name instead of sending a blank greeting.
(with-mocks [email-mock {:target 'app.email/send! :return nil}
(with-mocks [email-mock {:target 'app.email/send :return nil}
nitrate-mock {:target 'app.nitrate/call :return nil}]
(let [profile (th/create-profile* 1 {:is-active true :fullname "Nitrate User"})
out (th/management-command! (send-renewal-email-params profile nil))]
(t/is (th/success? out))
(let [[params] (:call-args @email-mock)]
(let [[_cfg params] (:call-args @email-mock)]
(t/is (= "Nitrate User" (:user-name params)))))))
(t/deftest send-renewal-email-keeps-explicit-empty-name
;; An explicit "" means the caller deliberately wants no name shown
;; and must not be replaced by the profile's fullname.
(with-mocks [email-mock {:target 'app.email/send! :return nil}
(with-mocks [email-mock {:target 'app.email/send :return nil}
nitrate-mock {:target 'app.nitrate/call :return nil}]
(let [profile (th/create-profile* 1 {:is-active true :fullname "Nitrate User"})
out (th/management-command! (send-renewal-email-params profile ""))]
(t/is (th/success? out))
(let [[params] (:call-args @email-mock)]
(let [[_cfg params] (:call-args @email-mock)]
(t/is (= "" (:user-name params)))))))
(t/deftest send-renewal-email-treats-blank-name-as-empty
;; A blank name is trimmed and follows the same path as "": no name
;; is shown and the profile's fullname is not used.
(with-mocks [email-mock {:target 'app.email/send! :return nil}
(with-mocks [email-mock {:target 'app.email/send :return nil}
nitrate-mock {:target 'app.nitrate/call :return nil}]
(let [profile (th/create-profile* 1 {:is-active true :fullname "Nitrate User"})
out (th/management-command! (send-renewal-email-params profile " "))]
(t/is (th/success? out))
(let [[params] (:call-args @email-mock)]
(let [[_cfg params] (:call-args @email-mock)]
(t/is (= "" (:user-name params)))))))

4
backend/test/backend_tests/rpc_nitrate_test.clj
View File

@ -1197,7 +1197,7 @@
:sso-active? true
:set-team-params set-team-params})
teams/initialize-user-in-organization (fn [& _] nil)
eml/send! (fn [params] (swap! sent conj params))]
eml/send (fn [_cfg params] (swap! sent conj params))]
(let [out (th/command! {::th/type :add-team-to-organization
::rpc/profile-id (:id owner)
:team-id (:id team)
@ -1328,7 +1328,7 @@
:team-id (:id team)
:sso-active? false})
teams/initialize-user-in-organization (fn [& _] nil)
eml/send! (fn [params] (swap! sent conj params))]
eml/send (fn [_cfg params] (swap! sent conj params))]
(let [out (th/command! {::th/type :add-team-to-organization
::rpc/profile-id (:id owner)
:team-id (:id team)

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

@ -190,7 +190,7 @@
(t/is (nil? (:error out)))
(t/is (= 1 (count (:result out)))))
(th/run-pending-tasks!)
(th/run-pending-jobs)
(let [row (th/db-get :team
{:id (:default-team-id prof)}
@ -357,7 +357,7 @@
(t/is (nil? (:error out)))
(t/is (= 1 (count (:result out)))))
(th/run-pending-tasks!)
(th/run-pending-jobs)
;; execute permanent deletion task
(let [result (th/run-task! :objects-gc {:min-age 0})]
@ -393,7 +393,7 @@
(t/is (nil? (:result out)))
(t/is (nil? (:error out))))
(th/run-pending-tasks!)
(th/run-pending-jobs)
(let [rows (th/db-exec! ["select id,name,deleted_at from team where deleted_at is not null"])]
(t/is (= 3 (count rows))))
@ -509,7 +509,7 @@
(t/is (= "mtma" (:penpot/mtm-campaign props)))))))
(t/deftest prepare-register-and-register-profile-2
(with-mocks [mock {:target 'app.email/send! :return nil}]
(with-mocks [mock {:target 'app.email/send :return nil}]
(let [current-token (atom nil)]
;; PREPARE REGISTER
(let [data {::th/type :prepare-register-profile
@ -563,7 +563,7 @@
(t/is (= 1 (:call-count @mock))))))))
(t/deftest prepare-register-and-register-profile-3
(with-mocks [mock {:target 'app.email/send! :return nil}]
(with-mocks [mock {:target 'app.email/send :return nil}]
(let [current-token (atom nil)]
;; PREPARE REGISTER
(let [data {::th/type :prepare-register-profile
@ -611,7 +611,7 @@
;; When disable-email-verification is set and the profile is inactive
;; (e.g. created before the flag was set), re-registering should be
;; rejected with :email-already-exists.
(with-mocks [mock {:target 'app.email/send! :return nil}]
(with-mocks [mock {:target 'app.email/send :return nil}]
(with-redefs [app.config/flags #{:registration :login-with-password}]
(let [current-token (atom nil)]
;; PREPARE REGISTER: first attempt (no profile exists yet)
@ -699,7 +699,7 @@
(t/deftest prepare-register-with-invitation-and-disabled-registration
(with-redefs [app.config/flags #{:login-with-password :email-verification}]
(with-mocks [mock {:target 'app.email/send! :return nil}]
(with-mocks [mock {:target 'app.email/send :return nil}]
(let [email "invited@example.com"
fixture (create-invitation-fixture email (ct/in-future "48h"))
itoken (create-test-invitation-token fixture email)
@ -840,7 +840,7 @@
;; verify-email mail with the invitation token EMBEDDED into the
;; verify-email JWE (so the team-invitation flow can resume after
;; the user clicks the email link).
(with-mocks [mock {:target 'app.email/send! :return nil}]
(with-mocks [mock {:target 'app.email/send :return nil}]
(let [itoken (tokens/generate th/*system*
{:iss :team-invitation
:exp (ct/in-future "48h")
@ -1181,7 +1181,7 @@
"prepare-register must not embed existing profile id of an anonymous caller"))))
(t/deftest register-profile-with-invitation-must-not-take-over-existing-account
(with-mocks [_mock {:target 'app.email/send! :return nil}]
(with-mocks [_mock {:target 'app.email/send :return nil}]
(let [;; Victim profile exists but is not yet active (e.g. registered
;; but has not clicked the verification link). This is the
;; remaining attack surface after fix 1b: `prepare-register`
@ -1287,7 +1287,7 @@
(t/is (true? (:is-active reloaded))))))
(t/deftest email-change-request
(with-mocks [mock {:target 'app.email/send! :return nil}]
(with-mocks [mock {:target 'app.email/send :return nil}]
(let [profile (th/create-profile* 1)
pool (:app.db/pool th/*system*)
data {::th/type :request-email-change
@ -1327,7 +1327,7 @@
(t/deftest email-change-request-without-smtp
(with-mocks [mock {:target 'app.email/send! :return nil}]
(with-mocks [mock {:target 'app.email/send :return nil}]
(with-redefs [app.config/flags #{}]
(let [profile (th/create-profile* 1)
pool (:app.db/pool th/*system*)
@ -1343,7 +1343,7 @@
(t/deftest request-profile-recovery
(with-mocks [mock {:target 'app.email/send! :return nil}]
(with-mocks [mock {:target 'app.email/send :return nil}]
(let [profile1 (th/create-profile* 1 {:is-active false})
profile2 (th/create-profile* 2 {:is-active true})
pool (:app.db/pool th/*system*)
@ -1401,7 +1401,7 @@
(t/deftest update-profile-password
(with-mocks [_ {:target 'app.email/send! :return nil}]
(with-mocks [_ {:target 'app.email/send :return nil}]
(let [profile (th/create-profile* 1)
data {::th/type :update-profile-password
::rpc/profile-id (:id profile)
@ -1413,7 +1413,7 @@
(t/deftest update-profile-password-bad-old-password
(with-mocks [mock {:target 'app.email/send! :return nil}]
(with-mocks [mock {:target 'app.email/send :return nil}]
(let [profile (th/create-profile* 1)
data {::th/type :update-profile-password
::rpc/profile-id (:id profile)
@ -1700,7 +1700,7 @@
(t/is (th/ex-of-code? (:error out) :weak-password))))
(t/deftest update-profile-password-sends-notification
(with-mocks [mock {:target 'app.email/send! :return nil}]
(with-mocks [mock {:target 'app.email/send :return nil}]
(let [profile (th/create-profile* 1)
data {::th/type :update-profile-password
::rpc/profile-id (:id profile)
@ -1710,14 +1710,14 @@
(t/is (nil? (:error out)))
(t/is (nil? (:result out)))
(t/is (= 1 (:call-count @mock)))
(let [{:keys [::eml/factory :to :name]} (first (:call-args-list @mock))]
(let [[_cfg {:keys [::eml/factory :to :name]}] (first (:call-args-list @mock))]
(t/is (= eml/password-changed factory))
(t/is (= (:email profile) to))
(t/is (= (:fullname profile) name))))))
(t/deftest update-profile-password-sends-notification-for-first-password
(with-mocks [mock {:target 'app.email/send! :return nil}]
(with-mocks [mock {:target 'app.email/send :return nil}]
(let [profile (th/create-profile* 1 {:password "!"})
data {::th/type :update-profile-password
::rpc/profile-id (:id profile)
@ -1726,14 +1726,14 @@
(t/is (nil? (:error out)))
(t/is (nil? (:result out)))
(t/is (= 1 (:call-count @mock)))
(let [{:keys [::eml/factory :to :name]} (first (:call-args-list @mock))]
(let [[_cfg {:keys [::eml/factory :to :name]}] (first (:call-args-list @mock))]
(t/is (= eml/password-changed factory))
(t/is (= (:email profile) to))
(t/is (= (:fullname profile) name))))))
(t/deftest recover-profile-sends-notification
(with-mocks [mock {:target 'app.email/send! :return nil}]
(with-mocks [mock {:target 'app.email/send :return nil}]
(let [profile (th/create-profile* 1)
token (tokens/generate th/*system*
{:iss :password-recovery
@ -1745,7 +1745,7 @@
out (th/command! data)]
(t/is (nil? (:error out)))
(t/is (= 1 (:call-count @mock)))
(let [{:keys [::eml/factory :to :name]} (first (:call-args-list @mock))]
(let [[_cfg {:keys [::eml/factory :to :name]}] (first (:call-args-list @mock))]
(t/is (= eml/password-changed factory))
(t/is (= (:email profile) to))
(t/is (= (:fullname profile) name))))))

38
backend/test/backend_tests/rpc_team_test.clj
View File

@ -27,7 +27,7 @@
(t/use-fixtures :each th/database-reset)
(t/deftest create-team-invitations
(with-mocks [mock {:target 'app.email/send! :return nil}]
(with-mocks [mock {:target 'app.email/send :return nil}]
(let [profile1 (th/create-profile* 1 {:is-active true})
profile2 (th/create-profile* 2 {:is-active true})
profile3 (th/create-profile* 3 {:is-active true :is-muted true})
@ -106,7 +106,7 @@
(t/is (= :member-is-muted (:code edata))))))))
(t/deftest create-and-update-team-invitations-include-organization-props
(with-mocks [email-mock {:target 'app.email/send! :return nil}
(with-mocks [email-mock {:target 'app.email/send :return nil}
audit-mock {:target 'app.loggers.audit/submit :return nil}]
(let [owner (th/create-profile* 101 {:is-active true})
invitee (th/create-profile* 102 {:is-active true})
@ -167,7 +167,7 @@
(t/is (false? (get-in create-plain [:props :invitee-already-organization-member])))))))
(t/deftest create-team-invitations-blacklisted-domain
(with-mocks [mock {:target 'app.email/send! :return nil}]
(with-mocks [mock {:target 'app.email/send :return nil}]
(let [profile1 (th/create-profile* 1 {:is-active true})
team (th/create-team* 1 {:profile-id (:id profile1)})
data {::th/type :create-team-invitations
@ -207,7 +207,7 @@
(t/is (= 1 (:call-count @mock))))))))
(t/deftest create-team-invitations-with-request-access
(with-mocks [mock {:target 'app.email/send! :return nil}]
(with-mocks [mock {:target 'app.email/send :return nil}]
(let [profile1 (th/create-profile* 1 {:is-active true})
requester (th/create-profile* 2 {:is-active true :email "requester@example.com"})
@ -244,7 +244,7 @@
(t/deftest create-team-invitations-with-request-access-2
(with-mocks [mock {:target 'app.email/send! :return nil}]
(with-mocks [mock {:target 'app.email/send :return nil}]
(let [profile1 (th/create-profile* 1 {:is-active true})
requester (th/create-profile* 2 {:is-active true
:email "requester@example.com"})
@ -307,7 +307,7 @@
(t/deftest invitation-tokens
(with-mocks [mock {:target 'app.email/send! :return nil}]
(with-mocks [mock {:target 'app.email/send :return nil}]
(let [profile1 (th/create-profile* 1 {:is-active true})
profile2 (th/create-profile* 2 {:is-active true})
@ -619,7 +619,7 @@
(t/is (not-any? #(= "accept-organization-invitation" (:name %)) events))))))
(t/deftest create-team-invitations-with-email-verification-disabled
(with-mocks [mock {:target 'app.email/send! :return nil}]
(with-mocks [mock {:target 'app.email/send :return nil}]
(let [profile1 (th/create-profile* 1 {:is-active true})
profile2 (th/create-profile* 2 {:is-active true})
profile3 (th/create-profile* 3 {:is-active true :is-muted true})
@ -850,7 +850,7 @@
(t/is (= 1 (count result)))
(t/is (= (:default-team-id profile1) (get-in result [0 :id])))))
(th/run-pending-tasks!)
(th/run-pending-jobs)
;; run permanent deletion (should be noop)
(let [result (th/run-task! :objects-gc {})]
@ -918,7 +918,7 @@
#_(th/print-result! out)
(t/is (nil? (:error out))))
(th/run-pending-tasks!)
(th/run-pending-jobs)
(let [rows (th/db-exec! ["select * from team where id = ?" (:id team)])]
(t/is (= 1 (count rows)))
@ -929,7 +929,7 @@
(t/is (= 7 (:processed result)))))))
(t/deftest create-team-access-request
(with-mocks [mock {:target 'app.email/send! :return nil}]
(with-mocks [mock {:target 'app.email/send :return nil}]
(let [owner (th/create-profile* 1 {:is-active true :email "owner@bar.com"})
requester (th/create-profile* 3 {:is-active true :email "requester@bar.com"})
team (th/create-team* 1 {:profile-id (:id owner)})
@ -976,7 +976,7 @@
(t/deftest create-team-access-request-owner-muted
(with-mocks [mock {:target 'app.email/send! :return nil}]
(with-mocks [mock {:target 'app.email/send :return nil}]
(let [owner (th/create-profile* 1 {:is-active true :is-muted true :email "owner@bar.com"})
requester (th/create-profile* 2 {:is-active true :email "requester@bar.com"})
team (th/create-team* 1 {:profile-id (:id owner)})
@ -995,7 +995,7 @@
(t/deftest create-team-access-request-requester-muted
(with-mocks [mock {:target 'app.email/send! :return nil}]
(with-mocks [mock {:target 'app.email/send :return nil}]
(let [owner (th/create-profile* 1 {:is-active true :email "owner@bar.com"})
requester (th/create-profile* 2 {:is-active true :is-muted true :email "requester@bar.com"})
team (th/create-team* 1 {:profile-id (:id owner)})
@ -1021,7 +1021,7 @@
(t/deftest create-team-access-request-owner-bounce
(with-mocks [mock {:target 'app.email/send! :return nil}]
(with-mocks [mock {:target 'app.email/send :return nil}]
(let [owner (th/create-profile* 1 {:is-active true :email "owner@bar.com"})
requester (th/create-profile* 2 {:is-active true :email "requester@bar.com"})
team (th/create-team* 1 {:profile-id (:id owner)})
@ -1049,7 +1049,7 @@
(t/is (= "private" (:email edata)))))))
(t/deftest create-team-access-request-requester-bounce
(with-mocks [mock {:target 'app.email/send! :return nil}]
(with-mocks [mock {:target 'app.email/send :return nil}]
(let [owner (th/create-profile* 1 {:is-active true :email "owner@bar.com"})
requester (th/create-profile* 2 {:is-active true :email "requester@bar.com"})
team (th/create-team* 1 {:profile-id (:id owner)})
@ -1106,7 +1106,7 @@
(t/is (th/success? out)))))
(t/deftest create-team-invitations-email-cooldown
(with-mocks [mock {:target 'app.email/send! :return nil}]
(with-mocks [mock {:target 'app.email/send :return nil}]
(let [profile1 (th/create-profile* 1 {:is-active true})
team (th/create-team* 1 {:profile-id (:id profile1)})
@ -1240,7 +1240,7 @@
;; --- T7-F-01: Role ceiling in team invitations ---
(t/deftest admin-cannot-create-invitation-with-owner-role
(with-mocks [mock {:target 'app.email/send! :return nil}]
(with-mocks [mock {:target 'app.email/send :return nil}]
(let [owner (th/create-profile* 1 {:is-active true})
admin (th/create-profile* 2 {:is-active true})
team (th/create-team* 1 {:profile-id (:id owner)})]
@ -1264,7 +1264,7 @@
(t/is (= 0 (:call-count @mock)))))))
(t/deftest admin-cannot-create-invitation-with-owner-role-invitations-format
(with-mocks [mock {:target 'app.email/send! :return nil}]
(with-mocks [mock {:target 'app.email/send :return nil}]
(let [owner (th/create-profile* 1 {:is-active true})
admin (th/create-profile* 2 {:is-active true})
team (th/create-team* 1 {:profile-id (:id owner)})]
@ -1287,7 +1287,7 @@
(t/is (= 0 (:call-count @mock)))))))
(t/deftest admin-cannot-update-invitation-role-to-owner
(with-mocks [mock {:target 'app.email/send! :return nil}]
(with-mocks [mock {:target 'app.email/send :return nil}]
(let [owner (th/create-profile* 1 {:is-active true})
admin (th/create-profile* 2 {:is-active true})
team (th/create-team* 1 {:profile-id (:id owner)})]
@ -1321,7 +1321,7 @@
(t/is (th/ex-of-code? (:error out) :cant-promote-to-owner))))))
(t/deftest owner-can-create-invitation-with-owner-role
(with-mocks [mock {:target 'app.email/send! :return nil}]
(with-mocks [mock {:target 'app.email/send :return nil}]
(let [owner (th/create-profile* 1 {:is-active true})
team (th/create-team* 1 {:profile-id (:id owner)})]

3
backend/test/backend_tests/storage_metadata_test.clj
View File

@ -259,7 +259,8 @@
(t/deftest metadata-buckets-is-the-canonical-set
(t/is (= #{"file-media-object" "team-font-variant" "file-object-thumbnail"
"file-thumbnail" "profile" "organization" "tempfile"
"upload-session" "file-data" "file-data-fragment" "file-change"}
"upload-session" "job-resource" "file-data" "file-data-fragment"
"file-change"}
stsch/metadata-buckets)))
(t/deftest decode-metadata-returns-nil-for-nil

98
backend/test/backend_tests/storage_test.clj
View File

@ -16,6 +16,7 @@
[app.rpc :as-alias rpc]
[app.storage :as sto]
[app.storage.fs :as-alias sto.fs]
[app.storage.gc-deleted :as gcd]
[app.storage.impl :as impl]
[app.storage.s3 :as-alias sto.s3]
[app.storage.schema :as stsch]
@ -475,7 +476,7 @@
(t/is (= 0 (:freeze res)))
(t/is (= 0 (:delete res)))))
;; processed immediately with skip-delay
;; processed immediately with skip-delay, bypassing min-age
(binding [ct/*clock* (ct/fixed-clock now)]
(let [res (th/run-task! :storage-gc-touched {:skip-delay true})]
(t/is (= 0 (:freeze res)))
@ -639,6 +640,32 @@
(let [res (th/run-task! :storage-gc-deleted {})]
(t/is (= 1 (:deleted res))))))
(t/deftest storage-gc-deleted-commits-each-chunk-separately
(let [storage (-> (:app.storage/storage th/*system*)
(configure-storage-backend))
;; more than one chunk (chunk-size is 25); distinct contents so
;; the storage layer does not deduplicate them into one row
ids (doall (for [i (range 26)]
(:id (sto/put-object! storage
{::sto/content (sto/content (str "content" i))
:content-type "text/plain"}))))]
(t/is (= 26 (count ids)))
(th/db-exec! ["update storage_object set deleted_at = ?" (ct/now)])
(let [orig @#'gcd/process-chunk
calls (atom 0)]
(alter-var-root #'gcd/process-chunk
(constantly (fn [& args]
(when (= 2 (swap! calls inc))
(throw (ex-info "boom" {})))
(apply orig args))))
(try
(t/is (thrown? Exception (th/run-task! :storage-gc-deleted {})))
(t/testing "first chunk committed before the fault"
(t/is (= 1 (:cnt (th/db-exec-one! ["SELECT count(*) AS cnt FROM storage_object WHERE deleted_at IS NOT NULL"])))))
(finally
(alter-var-root #'gcd/process-chunk (constantly orig)))))))
(t/deftest objects-gc-task-skip-delay
(let [storage (-> (:app.storage/storage th/*system*)
(configure-storage-backend))
@ -676,9 +703,10 @@
(let [res (th/run-task! :objects-gc {})]
(t/is (= 0 (:processed res))))
;; with skip-delay it is processed immediately
;; with skip-delay the future deleted row IS processed immediately
(let [res (th/run-task! :objects-gc {:skip-delay true})]
(t/is (= 1 (:processed res)))))))
(t/is (= 1 (:processed res)))
(t/is (nil? (th/db-get :file-media-object {:id (:id result-1)})))))))
(t/deftest put-object-write-failure-leaves-pending-row
(let [storage (-> (:app.storage/storage th/*system*)
@ -1236,3 +1264,67 @@
(t/is (= "boom" (ex-message (ex-cause ex)))))
;; one initial attempt plus max-retries
(t/is (= 4 (:call-count @mock)))))
(t/deftest touched-gc-job-resource-bucket
(let [storage (-> (:app.storage/storage th/*system*)
(configure-storage-backend))
job-id (uuid/next)
object (sto/put-object! storage {::sto/content (sto/content "content")
:content-type "text/plain"
:bucket sto/job-resource-bucket})]
;; the object is created with the job-resource bucket in metadata
(t/is (= sto/job-resource-bucket (:bucket (meta object))))
;; a live job row referencing the object keeps it frozen
(th/db-update! :storage-object {:touched-at (ct/now)} {:id (:id object)})
(th/db-insert! :job {:id job-id
:name "test-job"
:tenant (cf/get :tenant)
:queue "default"
:params (db/json {})
:priority 100
:max-retries 3
:retry-num 0
:status "running"
:resource-id (:id object)
:scheduled-at (ct/now)
:created-at (ct/now)
:modified-at (ct/now)})
(let [res (binding [ct/*clock* (ct/fixed-clock (ct/in-future {:hours 3}))]
(th/run-task! :storage-gc-touched {}))]
(t/is (= 1 (:freeze res)))
(t/is (= 0 (:delete res)))
(t/is (nil? (:touched-at (th/db-get :storage-object {:id (:id object)}
:id :touched-at))))
(t/is (nil? (:deleted-at (th/db-get :storage-object {:id (:id object)}
:id :deleted-at)))))
;; once the referencing row is gone, the touched object becomes
;; eligible for deletion (the job table is deletion-protected)
(th/db-force-delete :job {:id job-id})
(th/db-update! :storage-object {:touched-at (ct/now)} {:id (:id object)})
(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 (= 1 (:delete res)))
(t/is (nil? (:touched-at (th/db-get :storage-object {:id (:id object)}
:id :touched-at))))
(t/is (some? (:deleted-at (th/db-get :storage-object
{:id (:id object)}
{::db/remove-deleted false})))))
;; a touched object with no referencing job row at all is deleted too
(let [object (sto/put-object! storage {::sto/content (sto/content "content")
:content-type "text/plain"
:bucket sto/job-resource-bucket})]
(th/db-update! :storage-object {:touched-at (ct/now)} {:id (:id object)})
(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 (>= (:delete res) 1))
(t/is (some? (:deleted-at (th/db-get :storage-object
{:id (:id object)}
{::db/remove-deleted false}))))))))

201
backend/test/backend_tests/worker_cron_test.clj Normal file
View File

@ -0,0 +1,201 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS INC
(ns backend-tests.worker-cron-test
(:require
[app.common.time :as ct]
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
[app.jobs :as jobs]
[app.util.cron :as ucron]
[app.worker.cron :as cron]
[backend-tests.helpers :as th]
[clojure.string :as str]
[clojure.test :as t]
[integrant.core :as ig]))
(t/use-fixtures :once th/state-init)
(t/use-fixtures :each th/database-reset)
(defn- get-job
[cfg job-id]
(db/get* cfg :job {:id job-id}))
(defn- count-jobs
[cfg & {:keys [name tenant queue label]}]
(let [conditions (concat
(when name ["name = ?"])
(when tenant ["tenant = ?"])
(when queue ["queue = ?"])
(when label ["label = ?"]))
sql (str "SELECT count(*) AS n FROM job"
(when (seq conditions)
(str " WHERE " (str/join " AND " conditions))))
params (concat
(when name [name])
(when tenant [tenant])
(when queue [queue])
(when label [label]))]
(-> (db/exec-one! cfg (into [sql] params))
:n)))
(defn- make-cfg
[]
(-> th/*system*
(assoc ::jobs/defs (get th/*system* :app.jobs/defs))
(assoc ::db/pool (get th/*system* ::db/pool))))
(defn- get-cron-entries
[]
[{:id :session-gc-no-props
:job :session-gc
:cron "0 0 * * *"}
{:id :jobs-gc-with-props
:job :jobs-gc
:cron "0 0 * * *"
:props {:min-age 3600000}}])
(t/deftest cron-component-init-registers-and-schedules-entries
(let [defs (get th/*system* :app.jobs/defs)
entries [{:id :test-cron-init
:job :session-gc
:cron (ucron/cron "0 0 0 * * ?")}]
inst (ig/init-key :app.worker/cron
{:app.worker/entries entries
::jobs/defs defs
::db/pool th/*pool*})]
(try
(t/testing "init schedules futures"
(t/is (pos? (count @inst))))
(t/testing "scheduled_task row was upserted"
(t/is (some? (th/db-get :scheduled-task {:id "test-cron-init"}))))
(finally
(ig/halt-key! :app.worker/cron inst)))))
(t/deftest cron-submits-job-with-empty-params-when-entry-has-no-props
(let [cfg (make-cfg)
entries (get-cron-entries)
entry (first entries)]
;; Submit a cron job for an entry without :props
(let [job-id (cron/submit-cron-job cfg entry)]
;; Job should be created
(t/is (some? job-id))
;; Job should exist in DB
(let [row (get-job cfg job-id)]
(t/is (some? row))
(t/is (= "session-gc" (:name row)))
(t/is (= "cron" (:queue row)))
(t/is (= (cf/get :tenant) (:tenant row)))
(t/is (= "session-gc-no-props" (:label row)))
(t/is (nil? (:profile-id row)))
;; Props should be empty map after decoding
(let [props (db/decode-json-pgobject (:params row))]
(t/is (= {} props)))))))
(t/deftest cron-submits-job-with-props-when-entry-declares-them
(let [cfg (make-cfg)
entries (get-cron-entries)
entry (second entries)]
;; Submit a cron job for an entry with :props
(let [job-id (cron/submit-cron-job cfg entry)]
;; Job should be created
(t/is (some? job-id))
;; Job should exist in DB with the props
(let [row (get-job cfg job-id)]
(t/is (some? row))
(t/is (= "jobs-gc" (:name row)))
(t/is (= "jobs-gc-with-props" (:label row)))
;; Props should be decoded to the original map
(let [props (db/decode-json-pgobject (:params row))]
(t/is (= {:min-age 3600000} props)))))))
(t/deftest cron-tick-submits-only-when-no-active-instance
(let [cfg (make-cfg)
;; the entry keeps the canonical keyword task; only the id is a
;; string, as normalized by the cron component init. The cron
;; expression must be parsed: the tick reschedules itself in
;; `finally`
entry {:id "session-gc-no-overlap"
:job :session-gc
:cron (ucron/cron "0 0 0 * * ?")}]
;; the tick claims this row; without it the tick silently skips
(th/db-insert! :scheduled-task {:id "session-gc-no-overlap"
:cron-expr "0 0 * * *"})
;; execute-cron-task runs on a plain thread; join waits for the tick
(let [tick! (fn [] (.join ^Thread (#'cron/execute-cron-task cfg entry)))]
;; first tick submits exactly one job
(tick!)
(t/is (= 1 (count-jobs cfg :name "session-gc"
:label "session-gc-no-overlap")))
;; second tick with the first still active submits nothing
(tick!)
(t/is (= 1 (count-jobs cfg :name "session-gc"
:label "session-gc-no-overlap")))
;; once the first reaches terminal, the next tick submits again
(th/db-update! :job {:status "completed"} {:label "session-gc-no-overlap"})
(tick!)
(t/is (= 2 (count-jobs cfg :name "session-gc"
:label "session-gc-no-overlap"))))))
(t/deftest cron-job-created-on-cron-queue-with-null-profile-id
(let [cfg (make-cfg)
entries (get-cron-entries)
entry (first entries)]
(let [job-id (cron/submit-cron-job cfg entry)
row (get-job cfg job-id)]
;; the queue column is bare; the tenant lives in its own column
(t/is (= "cron" (:queue row)))
(t/is (= (cf/get :tenant) (:tenant row)))
;; Verify profile_id is NULL (system job)
(t/is (nil? (:profile-id row)))
;; Verify label is the entry id as string (without colon)
(t/is (= "session-gc-no-props" (:label row))))))
(t/deftest cron-tick-is-not-blocked-by-another-tenants-active-job
(let [cfg (make-cfg)
entry {:id "session-gc-shared-db"
:job :session-gc
:cron (ucron/cron "0 0 0 * * ?")}]
(th/db-insert! :scheduled-task {:id "session-gc-shared-db"
:cron-expr "0 0 * * *"})
;; An active job with the same name and label, owned by another
;; instance that shares this database. It runs in another tenant's
;; queue, so it is none of this instance's business.
(th/db-insert! :job {:id (uuid/next)
:name "session-gc"
:tenant "other-tenant"
:queue "cron"
:label "session-gc-shared-db"
:status "running"
:params (db/json {})
:scheduled-at (ct/now)
:created-at (ct/now)
:modified-at (ct/now)})
(.join ^Thread (#'cron/execute-cron-task cfg entry))
(t/testing "this tenant still submits its own job"
(t/is (= 1 (count-jobs cfg :name "session-gc"
:tenant (cf/get :tenant)
:label "session-gc-shared-db"))))
(t/testing "and the other tenant's row is untouched"
(t/is (= "running" (:status (th/db-get :job {:name "session-gc"
:tenant "other-tenant"})))))))

329
backend/test/backend_tests/worker_dispatcher_test.clj Normal file
View File

@ -0,0 +1,329 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS INC
(ns backend-tests.worker-dispatcher-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.jobs :as jobs]
[app.main :as main]
[app.metrics :as-alias mtx]
[app.metrics.definition :as-alias mdef]
[app.redis :as rds]
[app.worker :as wrk]
[app.worker.dispatcher :as wdisp]
[backend-tests.helpers :as th]
[clojure.string :as str]
[clojure.test :as t]
[integrant.core :as ig])
(:import
io.prometheus.client.Collector$MetricFamilySamples
io.prometheus.client.Collector$MetricFamilySamples$Sample
io.prometheus.client.Counter
io.prometheus.client.Counter$Child))
(t/use-fixtures :once th/state-init)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HELPERS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- mk-cfg
[]
{::db/pool th/*pool*
::rds/client (get th/*system* :app.redis/client)
::mtx/metrics (get th/*system* :app.metrics/metrics)
::wrk/tenant (cf/get :tenant)
::batch-size 100
::lease (cf/get-jobs-lease)
::timeout (ct/duration "10s")})
(defn- make-metrics []
(ig/init-key :app.metrics/metrics
{:default (select-keys main/default-metrics
[:jobs-dispatcher-timing])}))
(defn- make-orphan-metrics []
(ig/init-key :app.metrics/metrics
{:default (select-keys main/default-metrics
[:jobs-orphaned :jobs-completed
:jobs-total-timing])}))
(defn- counter-value [metrics id labels]
(let [collector (mtx/get-collector metrics id)
instance (::mdef/instance collector)
child (.labels ^Counter instance (into-array String labels))]
(.get ^Counter$Child child)))
(defn- histogram-sample-count [metrics labels]
(->> (enumeration-seq
(.metricFamilySamples ^io.prometheus.client.CollectorRegistry
(mtx/get-registry metrics)))
(mapcat (fn [^Collector$MetricFamilySamples family]
(.samples family)))
(filter (fn [^Collector$MetricFamilySamples$Sample sample]
(and (str/ends-with? (.-name sample) "_count")
(= labels (vec (.-labelValues sample))))))
(map (fn [^Collector$MetricFamilySamples$Sample sample]
(long (.-value sample))))
(reduce + 0)))
(defn- mk-job
[{:keys [name queue status scheduled-at modified-at tenant]
:or {name "test-job"
queue "test"
tenant (cf/get :tenant)
status "new"
scheduled-at (ct/now)
modified-at (ct/now)}}]
(let [id (uuid/next)]
(th/db-insert! :job {:id id
:name name
:tenant tenant
:queue queue
:params (db/json {})
:priority 100
:max-retries 3
:retry-num 0
:status status
:scheduled-at scheduled-at
:created-at (ct/now)
:modified-at modified-at})
id))
(defn- get-row
[id]
(-> (th/db-get :job {:id id} :status :modified-at :scheduled-at :error)
(update :error jobs/decode-job-error)
(assoc :events (->> (th/db-exec! ["SELECT kind, payload FROM job_event
WHERE job_id = ? ORDER BY id" id])
(mapv (fn [{:keys [kind payload]}]
{:kind kind
:payload (db/decode-json-pgobject payload)}))))))
(defn- queue-key
[queue-name]
(wrk/queue-key (cf/get :tenant) queue-name))
(defn- test-fixture [next]
(th/database-reset
(fn []
;; clear the redis hand-off list so tests don't see stale payloads
(let [conn (rds/connect (mk-cfg))]
(try
(rds/del conn (queue-key "test"))
(finally
(rds/close conn)))
(next)))))
(t/use-fixtures :each test-fixture)
(defn- drain-queue
[queue-name]
(let [conn (rds/connect (mk-cfg))]
(try
(let [cmd (.-cmd conn)
res (.lrange ^io.lettuce.core.api.sync.RedisCommands
cmd (queue-key queue-name) 0 -1)]
(vec res))
(finally
(rds/del conn (queue-key queue-name))
(rds/close conn)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TESTS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(t/deftest dispatcher-claims-due-jobs-and-pushes-json-payload
(let [cfg (mk-cfg)
id (mk-job {})
_ (wdisp/run-batch cfg)
row (get-row id)
key (queue-key "test")]
(t/testing "claimed job is marked scheduled"
(t/is (= "scheduled" (:status row))))
(t/testing "payload is plain JSON [uuid, iso-8601]"
(let [payloads (drain-queue "test")]
(t/is (= 1 (count payloads)))
(let [[job-id scheduled-at :as payload] (json/decode (first payloads))]
(t/is (string? job-id))
(t/is (= (str id) job-id))
(t/is (string? scheduled-at))
(t/testing "round-trip: inst-ms are equal after ct/inst"
(let [expected (:scheduled-at row)
actual (ct/inst scheduled-at)]
(t/is (= (inst-ms expected) (inst-ms actual))))))))))
(t/deftest dispatcher-claims-retry-jobs-too
(let [cfg (mk-cfg)
id (mk-job {:status "retry"})]
(wdisp/run-batch cfg)
(t/is (= "scheduled" (:status (get-row id))))))
(t/deftest dispatcher-does-not-claim-future-or-terminal-jobs
(let [cfg (mk-cfg)
future (mk-job {:scheduled-at (ct/plus (ct/now)
(ct/duration {:minutes 10}))})
running (mk-job {:status "running"})]
(wdisp/run-batch cfg)
(t/is (= "new" (:status (get-row future))))
(t/is (= "running" (:status (get-row running))))))
(t/deftest dispatcher-reschedules-lost-scheduled-jobs
(let [cfg (mk-cfg)
lost-id (mk-job {:status "scheduled"
:scheduled-at (ct/minus (ct/now)
(ct/duration {:minutes 6}))})
fresh-id (mk-job {:status "scheduled"})]
(wdisp/run-batch cfg)
(let [lost (get-row lost-id)
fresh (get-row fresh-id)]
;; the lost job is rescheduled to 'new' and claimed again in the
;; same batch, so it ends as 'scheduled' with a recent scheduled_at
(t/is (= "scheduled" (:status lost)))
(t/is (> (inst-ms (:scheduled-at lost))
(inst-ms (ct/minus (ct/now)
(ct/duration {:minutes 5})))))
(t/testing "the rescheduled job was pushed again to the queue"
(t/is (= 1 (count (drain-queue "test"))))
(t/is (= "scheduled" (:status fresh)))))))
(t/deftest dispatcher-marks-stale-running-jobs-as-aborted-by-lease
(let [cfg (mk-cfg)
stale (mk-job {:status "running"
:modified-at (ct/minus (ct/now)
(ct/plus (cf/get-jobs-lease)
(ct/duration {:minutes 1})))})
fresh (mk-job {:status "running"})]
(wdisp/run-batch cfg)
(let [stale-row (get-row stale)]
(t/is (= "aborted" (:status stale-row)))
(t/testing "the error is the structured one, decoded back to keywords"
(t/is (= jobs/orphan-error (:error stale-row))))
(t/testing "the sweep stores the end event with the aborted outcome"
(t/is (= [{:kind "end" :payload {:outcome "aborted"}}]
(:events stale-row))))
(t/testing "an aborted job is terminal: it is never retried nor reclaimed"
(t/is (zero? (jobs/retry-job cfg
(:id stale-row)
1 (ct/now) jobs/orphan-error :backoff)))))
(t/testing "recent running job is not touched"
(t/is (= "running" (:status (get-row fresh)))))))
(t/deftest dispatcher-orphan-sweep-records-orphan-and-terminal-metrics
(let [metrics (make-orphan-metrics)
cfg (assoc (mk-cfg) ::mtx/metrics metrics)
_ (mk-job {:status "running"
:modified-at (ct/minus (ct/now)
(ct/plus (cf/get-jobs-lease)
(ct/duration {:minutes 1})))})]
(wdisp/run-batch cfg)
(t/is (= 1.0 (counter-value metrics :jobs-orphaned ["test"])))
(t/is (= 1.0 (counter-value metrics :jobs-completed
["test-job" "test" "aborted"])))))
(t/deftest dispatcher-batch-without-pending-jobs-signals-wait
(let [cfg (mk-cfg)]
(t/is (= ::wdisp/wait (wdisp/run-batch cfg)))))
(t/deftest dispatcher-failed-mark-leaves-no-orphan-payload
;; Mark runs before push: when the mark fails, the push never runs, so
;; a rolled-back batch must leave neither a marked row nor a payload.
(let [cfg (assoc (mk-cfg) ::wdisp/timeout (ct/duration {:millis 10}))
id (mk-job {})
orig @#'wdisp/mark-as-scheduled
calls (atom 0)]
(alter-var-root #'wdisp/mark-as-scheduled
(constantly (fn [& args]
(when (= 1 (swap! calls inc))
(throw (ex-info "boom" {})))
(apply orig args))))
(try
(wdisp/run-batch cfg)
(t/testing "failed mark rolls back with no payload pushed"
(t/is (= "new" (:status (get-row id))))
(t/is (empty? (drain-queue "test"))))
(finally
(alter-var-root #'wdisp/mark-as-scheduled (constantly orig))))
(t/testing "next batch delivers exactly once"
(wdisp/run-batch cfg)
(t/is (= "scheduled" (:status (get-row id))))
(t/is (= 1 (count (drain-queue "test")))))))
(t/deftest dispatcher-records-one-redis-failure
(let [metrics (make-metrics)
cfg (assoc (mk-cfg) ::mtx/metrics metrics
::wdisp/timeout (ct/duration {:millis 10}))
_ (mk-job {})]
(with-redefs [rds/rpush (fn [& _] (throw (ex-info "redis down" {})))]
(wdisp/run-batch cfg))
(t/is (= 1 (histogram-sample-count metrics ["execution" "failed"])))
(t/is (= 0 (histogram-sample-count metrics ["dispatch" "failed"])))))
(t/deftest dispatcher-push-failure-rolls-back-without-throwing
(let [cfg (assoc (mk-cfg) ::wdisp/timeout (ct/duration {:millis 10}))
id (mk-job {})
orig @#'rds/rpush]
(alter-var-root #'rds/rpush
(constantly (fn [& _] (throw (ex-info "redis down" {})))))
(try
;; run-batch catches the failure (sleep path) instead of throwing;
;; a throw would error this test by itself
(wdisp/run-batch cfg)
(t/testing "failed push rolls back the batch"
(t/is (= "new" (:status (get-row id))))
(t/is (empty? (drain-queue "test"))))
(finally
(alter-var-root #'rds/rpush (constantly orig))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TENANT ISOLATION
;; A batch is this tenant's: it must not read, claim or kill the rows of
;; another instance sharing the same database.
(t/deftest dispatcher-does-not-claim-another-tenants-jobs
(let [cfg (mk-cfg)
foreign (mk-job {:tenant "other-tenant"})]
(wdisp/run-batch cfg)
(t/testing "the other tenant's job is not claimed"
(t/is (= "new" (:status (get-row foreign)))))
(t/testing "and nothing was pushed to this tenant's Redis list"
(t/is (empty? (drain-queue "test"))))))
(t/deftest dispatcher-does-not-reschedule-another-tenants-lost-jobs
(let [cfg (mk-cfg)
foreign (mk-job {:status "scheduled"
:tenant "other-tenant"
:scheduled-at (ct/minus (ct/now)
(ct/duration {:minutes 6}))})]
(wdisp/run-batch cfg)
(t/testing "the other tenant's scheduled job keeps its status and its date"
(let [row (get-row foreign)]
(t/is (= "scheduled" (:status row)))
(t/is (< (inst-ms (:scheduled-at row))
(inst-ms (ct/minus (ct/now)
(ct/duration {:minutes 5})))))))))
(t/deftest dispatcher-does-not-orphan-another-tenants-running-jobs
(let [cfg (mk-cfg)
;; older than any lease: this tenant's sweep would kill it
foreign (mk-job {:status "running"
:tenant "other-tenant"
:modified-at (ct/minus (ct/now)
(ct/plus (cf/get-jobs-lease)
(ct/duration {:minutes 1})))})]
(wdisp/run-batch cfg)
(t/testing "the other tenant's running job is still running"
(let [row (get-row foreign)]
(t/is (= "running" (:status row)))
(t/is (nil? (:error row)))
(t/is (= [] (:events row)))))))

566
backend/test/backend_tests/worker_runner_test.clj Normal file
View File

@ -0,0 +1,566 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS INC
(ns backend-tests.worker-runner-test
(:require
[app.common.json :as json]
[app.common.schema :as sm]
[app.common.time :as ct]
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
[app.jobs :as jobs]
[app.main :as main]
[app.metrics :as-alias mtx]
[app.metrics.definition :as-alias mdef]
[app.redis :as rds]
[app.worker :as wrk]
[app.worker.runner :as wrkr]
[backend-tests.helpers :as th]
[clojure.string :as str]
[clojure.test :as t]
[integrant.core :as ig])
(:import
io.prometheus.client.Collector$MetricFamilySamples
io.prometheus.client.Collector$MetricFamilySamples$Sample))
(t/use-fixtures :once th/state-init)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HELPERS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def received (atom []))
(def received-contexts (atom []))
(defn echo-handler
"Handler implementation: the context comes from the job-def wrapper and
the params are what the runner decoded from the row."
[cfg context params]
(swap! received conj params)
(swap! received-contexts conj context)
params)
(def schema:echo-params
[:map
[:object :keyword]
[:deleted-at ::ct/inst]
[:id ::sm/uuid]])
(defn- echo-job-def
"Job-def with the standard wrapper: [context params], with the component
deps closed over at init time."
[]
{::jobs/name :echo-runner
::jobs/schema schema:echo-params
::jobs/handler (fn [context params]
(echo-handler nil context params))
::jobs/decoder (sm/decoder schema:echo-params sm/json-transformer)
::jobs/validator (sm/validator schema:echo-params)})
(defn- get-defs
[]
{:echo-runner (echo-job-def)})
(defn- mk-cfg
[{:keys [defs]
:or {defs (get-defs)}}]
{::db/pool th/*pool*
::rds/conn (rds/connect {::rds/client (get th/*system* :app.redis/client)
::mtx/metrics (get th/*system* :app.metrics/metrics)})
::jobs/defs defs
::mtx/metrics (get th/*system* :app.metrics/metrics)
::wrkr/id "test-runner"
::wrkr/queue "test"
::wrk/tenant (cf/get :tenant)
::wrkr/timeout (ct/duration "5s")})
(defn- make-metrics []
(ig/init-key :app.metrics/metrics
{:default (select-keys main/default-metrics
[:jobs-queue-wait-timing
:jobs-execution-timing
:jobs-total-timing
:tasks-timing])}))
(defn- histogram-sample-count [metrics id labels]
(->> (enumeration-seq
(.metricFamilySamples ^io.prometheus.client.CollectorRegistry
(mtx/get-registry metrics)))
(filter (fn [^Collector$MetricFamilySamples family]
(= (.-name family) (::mdef/name (main/default-metrics id)))))
(mapcat (fn [^Collector$MetricFamilySamples family]
(.samples family)))
(filter (fn [^Collector$MetricFamilySamples$Sample sample]
(and (str/ends-with? (.-name sample) "_count")
(= labels (vec (.-labelValues sample))))))
(map (fn [^Collector$MetricFamilySamples$Sample sample]
(long (.-value sample))))
(reduce + 0)))
(defn- queue-key
[]
(wrk/queue-key (cf/get :tenant) "test"))
(defn- clear-queue
[]
(let [conn (rds/connect {::rds/client (get th/*system* :app.redis/client)
::mtx/metrics (get th/*system* :app.metrics/metrics)})]
(try
(rds/del conn (queue-key))
(finally
(rds/close conn)))))
(defn- test-fixture [next]
(th/database-reset
(fn []
(reset! received [])
(reset! received-contexts [])
(clear-queue)
(next))))
(t/use-fixtures :each test-fixture)
(defn- mk-job
[{:keys [name status scheduled-at params max-retries label]
:or {name "echo-runner"
status "new"
;; Valid echo params by default: direct inserts bypass the
;; submit! contract, and the runner validates decoded params.
params {:object :snapshot
:deleted-at (ct/now)
:id (uuid/next)}
max-retries 3}}]
(let [id (uuid/next)]
(th/db-insert! :job {:id id
:name name
:tenant (cf/get :tenant)
:label label
:queue "test"
:params (db/json params)
:priority 100
:max-retries max-retries
:retry-num 0
:status status
:scheduled-at scheduled-at
:created-at (ct/now)
:modified-at (ct/now)})
id))
(defn- push-payload
[job-id scheduled-at]
(let [conn (rds/connect {::rds/client (get th/*system* :app.redis/client)
::mtx/metrics (get th/*system* :app.metrics/metrics)})]
(try
(rds/rpush conn (queue-key) [(json/encode [(str job-id)
(ct/format-inst scheduled-at)])])
(finally
(rds/close conn)))))
(defn- get-row
[id]
(-> (th/db-get :job {:id id})
(as-> row
(-> row
(update :error jobs/decode-job-error)
(update :result #(cond-> % (db/pgobject? %) db/decode-json-pgobject))))))
(defn- get-events
[id]
(->> (th/db-exec! ["SELECT kind, payload FROM job_event
WHERE job_id = ? ORDER BY id ASC" id])
(mapv (fn [{:keys [kind payload]}]
{:kind kind :payload (db/decode-json-pgobject payload)}))))
(defn- run-one
[cfg]
(@#'wrkr/run-worker-loop cfg))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TESTS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(t/deftest runner-executes-handler-with-decoded-typed-params
(let [params {:object :snapshot
:deleted-at (ct/now)
:id (uuid/next)}
scheduled-at (ct/truncate (ct/now) :millisecond)
job-id (mk-job {:scheduled-at scheduled-at :params params})]
(push-payload job-id scheduled-at)
(run-one (mk-cfg {}))
(t/testing "handler received the decoded params"
(t/is (= 1 (count @received)))
(let [params' (first @received)]
(t/is (keyword? (:object params')))
(t/is (= :snapshot (:object params')))
(t/is (uuid? (:id params')))
(t/is (ct/inst? (:deleted-at params')))))
(t/testing "job row is completed with the handler result"
(let [row (get-row job-id)]
(t/is (= "completed" (:status row)))
(t/is (some? (:started-at row)))
(t/is (some? (:completed-at row)))
(t/is (nil? (:error row)))))))
(t/deftest runner-builds-the-handler-context-from-the-row
(let [params {:object :snapshot
:deleted-at (ct/now)
:id (uuid/next)}
scheduled-at (ct/truncate (ct/now) :millisecond)
job-id (mk-job {:scheduled-at scheduled-at
:params params
:label "runner-label"})]
(push-payload job-id scheduled-at)
(run-one (mk-cfg {}))
(t/testing "the handler receives exactly the four context keys"
(t/is (= 1 (count @received-contexts)))
(let [context (first @received-contexts)]
(t/is (= #{:id :name :label :resource-id} (set (keys context))))
(t/is (= job-id (:id context)))
(t/is (= "echo-runner" (:name context)))
(t/is (= "runner-label" (:label context)))
(t/is (nil? (:resource-id context)))
(t/testing "and nothing of the row leaks into it"
(t/is (not (contains? context :params)))
(t/is (not (contains? context :status)))
(t/is (not (contains? context :result)))
(t/is (not (contains? context :retry-num)))
(t/is (not (contains? context :max-retries)))
(t/is (not (contains? context :attempt)))
(t/is (not (contains? context :queue))
"the tenant-prefixed queue is a routing detail, not context"))))))
(t/deftest runner-records-queue-wait-execution-and-total
(let [metrics (make-metrics)
cfg (assoc (mk-cfg {}) ::mtx/metrics metrics)
at (ct/truncate (ct/now) :millisecond)
job-id (mk-job {:scheduled-at at})]
(push-payload job-id at)
(run-one cfg)
(t/is (= 1 (histogram-sample-count metrics
:jobs-queue-wait-timing
["echo-runner" "test"])))
(t/is (= 1 (histogram-sample-count metrics
:jobs-execution-timing
["echo-runner" "test"])))
(t/is (= 1 (histogram-sample-count metrics
:jobs-total-timing
["echo-runner" "test" "completed"])))
(t/testing "the legacy histogram is still emitted, with its raw name label"
(t/is (= 1 (histogram-sample-count metrics
:tasks-timing
["echo-runner"]))))))
(t/deftest runner-skips-cancelled-jobs
(let [scheduled-at (ct/truncate (ct/now) :millisecond)
job-id (mk-job {:scheduled-at scheduled-at})
_ (th/db-update! :job {:status "cancelled"} {:id job-id})]
(push-payload job-id scheduled-at)
(run-one (mk-cfg {}))
(t/testing "conditional claim found 0 rows: state untouched"
(let [row (get-row job-id)]
(t/is (= "cancelled" (:status row)))
(t/is (nil? (:started-at row)))
(t/is (nil? (:completed-at row)))))
(t/testing "handler never invoked"
(t/is (empty? @received)))))
(t/deftest runner-retry-with-backoff-respects-max-retries
(let [scheduled-at (ct/truncate (ct/now) :millisecond)
job-id (mk-job {:scheduled-at scheduled-at :max-retries 1})
defs {:echo-runner
(assoc (echo-job-def)
::jobs/handler
(fn [_context _params]
(throw (ex-info "transient failure"
{:type ::wrk/retry
:delay (ct/duration {:millis 1000})}))))}]
(push-payload job-id scheduled-at)
(t/testing "first retry attempt"
(run-one (mk-cfg {:defs defs}))
(let [row (get-row job-id)]
(t/is (= "retry" (:status row)))
(t/is (= 1 (:retry-num row)))
(t/is (= {:type :retry
:code :failed
:hint "transient failure"
:ex-type "retry"} (:error row)))
(t/testing "scheduled_at respects the backoff delay"
(t/is (> (inst-ms (:scheduled-at row)) (inst-ms (ct/now)))))))
(t/testing "second attempt exhausts max-retries and fails"
(push-payload job-id (:scheduled-at (get-row job-id)))
(run-one (mk-cfg {:defs defs}))
(let [row (get-row job-id)]
(t/is (= "failed" (:status row)))
(t/is (= 1 (:retry-num row)))
(t/is (= {:type :retry
:code :failed
:hint "transient failure"
:ex-type "retry"} (:error row)))))))
(t/deftest runner-retry-with-millis-delay-schedules-backoff
(let [scheduled-at (ct/truncate (ct/now) :millisecond)
job-id (mk-job {:scheduled-at scheduled-at})
defs {:echo-runner
(assoc (echo-job-def)
::jobs/handler
(fn [_context _params]
(throw (ex-info "transient failure"
{:type ::wrk/retry
;; plain Long literal, not a Duration
:delay 5000}))))}]
(push-payload job-id scheduled-at)
(run-one (mk-cfg {:defs defs}))
(let [row (get-row job-id)]
(t/testing "Long millis delay is honored (int? covers Long)"
(t/is (= "retry" (:status row)))
(t/is (= 1 (:retry-num row)))
(t/testing "scheduled_at is ~5s in the future"
(let [delta (- (inst-ms (:scheduled-at row)) (inst-ms (ct/now)))]
(t/is (> delta 4000))
(t/is (< delta 6000))))))))
(t/deftest runner-noop-retry-at-zero-schedules-base-delay
(let [scheduled-at (ct/truncate (ct/now) :millisecond)
job-id (mk-job {:scheduled-at scheduled-at})
defs {:echo-runner
(assoc (echo-job-def)
::jobs/handler
(fn [_context _params]
(throw (ex-info "noop"
{:type ::wrk/retry
:strategy ::wrk/noop
:delay 5000}))))}]
(push-payload job-id scheduled-at)
(run-one (mk-cfg {:defs defs}))
(let [row (get-row job-id)]
(t/testing "noop retry schedules instead of NPEing on take 0"
(t/is (= "retry" (:status row)))
(t/is (= 0 (:retry-num row)))
(t/testing "scheduled_at is ~5s in the future"
(let [delta (- (inst-ms (:scheduled-at row)) (inst-ms (ct/now)))]
(t/is (> delta 4000))
(t/is (< delta 6000))))))))
(t/deftest runner-unhandled-exception-fails-when-no-retries-left
(let [scheduled-at (ct/truncate (ct/now) :millisecond)
job-id (mk-job {:scheduled-at scheduled-at :max-retries 0})
defs {:echo-runner
(assoc (echo-job-def)
::jobs/handler
(fn [_context _params] (throw (ex-info "fatal" {}))))}]
(push-payload job-id scheduled-at)
(run-one (mk-cfg {:defs defs}))
(let [row (get-row job-id)]
(t/is (= "failed" (:status row)))
(t/is (= {:type :internal
:code :failed
:hint "fatal"
:ex-type "ex-info"} (:error row))))))
(t/deftest runner-terminal-write-does-not-overwrite-orphan-failure
(let [scheduled-at (ct/truncate (ct/now) :millisecond)
job-id (mk-job {:scheduled-at scheduled-at})
defs {:echo-runner
(assoc (echo-job-def)
::jobs/handler
(fn [_context _params]
;; simulate the dispatcher marking the
;; running job as aborted while the handler
;; is executing
(th/db-update! :job
{:status "aborted"
:error (db/json jobs/orphan-error)}
{:id jobs/*job-id*})
:ok))}]
(push-payload job-id scheduled-at)
(run-one (mk-cfg {:defs defs}))
(let [row (get-row job-id)]
(t/testing "the orphan abort is preserved (first-terminal-wins)"
(t/is (= "aborted" (:status row)))
(t/is (= jobs/orphan-error (:error row)))
(t/is (nil? (:completed-at row)))))))
(t/deftest runner-claim-requires-current-scheduled-at
(let [at (ct/truncate (ct/now) :millisecond)
job-id (mk-job {:status "scheduled" :scheduled-at at})
stale (ct/minus at (ct/duration {:minutes 6}))]
(t/testing "stale scheduled_at claims nothing"
(t/is (zero? (#'wrkr/claim-job (mk-cfg {}) job-id stale)))
(t/is (= "scheduled" (:status (get-row job-id)))))
(t/testing "current scheduled_at claims the row"
(t/is (= 1 (#'wrkr/claim-job (mk-cfg {}) job-id at)))
(t/is (= "running" (:status (get-row job-id)))))))
(t/deftest runner-skips-stale-payload-after-reschedule
(let [stale-at (ct/truncate (ct/now) :millisecond)
job-id (mk-job {:scheduled-at stale-at})
fresh-at (ct/plus stale-at (ct/duration {:minutes 6}))]
;; dispatcher reschedules: new scheduled_at + fresh payload
(th/db-update! :job {:status "scheduled" :scheduled-at fresh-at} {:id job-id})
(t/testing "stale payload is skipped, handler never invoked"
(push-payload job-id stale-at)
(run-one (mk-cfg {}))
(t/is (empty? @received))
(let [row (get-row job-id)]
(t/is (= "scheduled" (:status row)))
(t/is (nil? (:started-at row)))))
(t/testing "fresh payload still executes"
(push-payload job-id fresh-at)
(run-one (mk-cfg {}))
(t/is (= 1 (count @received)))
(t/is (= "completed" (:status (get-row job-id)))))))
(t/deftest runner-unknown-job-name-fails-fast
(let [scheduled-at (ct/truncate (ct/now) :millisecond)
job-id (mk-job {:name "no-such-job"
:scheduled-at scheduled-at
:max-retries 3})]
(push-payload job-id scheduled-at)
(run-one (mk-cfg {}))
(let [row (get-row job-id)]
(t/testing "no retries burned on a permanently-unknown name"
(t/is (= "failed" (:status row)))
(t/is (= 0 (:retry-num row)))
(t/is (nil? (:completed-at row)))
(t/is (= "not-found" (:ex-type (:error row))))))))
(t/deftest runner-schema-violation-fails-fast-without-retry
(let [scheduled-at (ct/truncate (ct/now) :millisecond)
job-id (mk-job {:scheduled-at scheduled-at
:max-retries 3
:params {:object :snapshot
:deleted-at (ct/now)
:id "not-a-uuid"}})]
(push-payload job-id scheduled-at)
(run-one (mk-cfg {}))
(let [row (get-row job-id)]
(t/testing "permanent schema violation fails fast"
(t/is (= "failed" (:status row)))
(t/is (= 0 (:retry-num row)))
(t/is (nil? (:completed-at row)))
(t/is (= "assertion" (:ex-type (:error row))))))))
(t/deftest invoke-executes-handlers-in-process-with-decoded-params
(let [raw-params {:object "snapshot"
:deleted-at "2026-01-01T00:00:00Z"
:id (str (uuid/next))}]
(reset! received [])
(let [result (jobs/invoke (merge (mk-cfg {})
{::jobs/name :echo-runner
::jobs/params raw-params}))]
(t/is (= 1 (count @received)))
(let [params' (first @received)]
(t/is (keyword? (:object params')))
(t/is (= :snapshot (:object params')))
(t/is (uuid? (:id params')))
(t/is (ct/inst? (:deleted-at params'))))
(t/testing "invoke! returns the handler result"
(t/is (= (first @received) result))))))
(t/deftest runner-skips-malformed-payloads
(let [conn (rds/connect {::rds/client (get th/*system* :app.redis/client)
::mtx/metrics (get th/*system* :app.metrics/metrics)})]
(try
(rds/rpush conn (queue-key) ["not-json"
(json/encode ["not-a-uuid" "not-an-inst"])])
(finally
(rds/close conn))))
(t/testing "non-JSON payload is skipped, handler never invoked"
(run-one (mk-cfg {}))
(t/is (empty? @received)))
(t/testing "JSON payload with wrong shape is skipped too"
(run-one (mk-cfg {}))
(t/is (empty? @received))))
(t/deftest runner-reads-the-reserved-completion-envelope
(let [scheduled-at (ct/truncate (ct/now) :millisecond)
resource-id (uuid/next)
defs {:echo-runner
(assoc (echo-job-def)
::jobs/handler
(fn [_context _params]
{:result {:business 1}
:resource-id resource-id}))}]
(th/db-insert! :storage-object {:id resource-id :backend "test"})
(let [job-id (mk-job {:scheduled-at scheduled-at})]
(push-payload job-id scheduled-at)
(run-one (mk-cfg {:defs defs}))
(let [row (get-row job-id)]
(t/testing "the envelope splits: business result in result, resource on the row"
(t/is (= "completed" (:status row)))
(t/is (= {:business 1} (:result row)))
(t/is (= resource-id (:resource-id row))))
(t/testing "and the end event is still a plain outcome"
(t/is (= [{:kind "end" :payload {:outcome "completed"}}]
(drop 1 (get-events job-id)))))))))
(t/deftest runner-records-the-lifecycle-events-of-a-successful-job
(let [scheduled-at (ct/truncate (ct/now) :millisecond)
job-id (mk-job {:scheduled-at scheduled-at})]
(push-payload job-id scheduled-at)
(run-one (mk-cfg {}))
(t/is (= [{:kind "start" :payload {:attempt 1}}
{:kind "end" :payload {:outcome "completed"}}]
(get-events job-id)))))
(t/deftest runner-records-a-retry-event-before-the-next-attempt
(let [scheduled-at (ct/truncate (ct/now) :millisecond)
job-id (mk-job {:scheduled-at scheduled-at :max-retries 3})
defs {:echo-runner
(assoc (echo-job-def)
::jobs/handler
(fn [_context _params]
(throw (ex-info "transient" {:type ::wrk/retry
:delay (ct/duration {:millis 1})}))))}]
(push-payload job-id scheduled-at)
(run-one (mk-cfg {:defs defs}))
(t/is (= [{:kind "start" :payload {:attempt 1}}
{:kind "retry" :payload {:attempt 2 :reason "backoff"}}]
(get-events job-id)))))
(t/deftest runner-records-a-noop-retry-as-the-same-attempt
(let [scheduled-at (ct/truncate (ct/now) :millisecond)
job-id (mk-job {:scheduled-at scheduled-at :max-retries 3})
defs {:echo-runner
(assoc (echo-job-def)
::jobs/handler
(fn [_context _params]
(throw (ex-info "transient" {:type ::wrk/retry
:delay (ct/duration {:millis 1})
:strategy ::wrk/noop}))))}]
(push-payload job-id scheduled-at)
(run-one (mk-cfg {:defs defs}))
(t/testing "a noop consumed no budget, so the attempt does not move"
(t/is (= [{:kind "start" :payload {:attempt 1}}
{:kind "retry" :payload {:attempt 1 :reason "noop"}}]
(get-events job-id)))
(t/is (= 0 (:retry-num (get-row job-id)))))))
(t/deftest deleting-a-job-deletes-its-events
(let [scheduled-at (ct/truncate (ct/now) :millisecond)
job-id (mk-job {:scheduled-at scheduled-at})]
(push-payload job-id scheduled-at)
(run-one (mk-cfg {}))
(t/is (= 2 (count (get-events job-id))))
(th/db-force-delete :job {:id job-id})
(t/is (= [] (get-events job-id)))))

46
backend/test/backend_tests/worker_test.clj Normal file
View File

@ -0,0 +1,46 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS INC
(ns backend-tests.worker-test
(:require
[app.common.schema :as sm]
[app.msgbus :as mbus]
[app.worker :as wrk]
[app.worker.cron :as wcron]
[app.worker.dispatcher :as wdisp]
[app.worker.runner :as wrkr]
[clojure.test :as t]))
;; The dispatcher's push and the runner's pop agree on the Redis list
;; only through this helper, so the test helpers use it too. That
;; keeps producer and consumer in sync by construction, but it also
;; means no other test would catch a malformed shape. This test pins
;; the physical format instead.
(t/deftest queue-key-pins-the-physical-redis-shape
(t/testing "tenant and queue compose the documented key"
(t/is (= "penpot.worker.queue:acme:default"
(wrk/queue-key "acme" :default))))
(t/testing "a string queue gives the same key as a keyword one"
(t/is (= "penpot.worker.queue:acme:default"
(wrk/queue-key "acme" "default"))))
(t/testing "hyphens travel through untouched"
(t/is (= "penpot.worker.queue:my-tenant:daily-cleanup"
(wrk/queue-key "my-tenant" :daily-cleanup)))))
;; Booting the backend asserts these integrant keys, and assert-key
;; compiles the schema first: a ref with no registered schema crashes
;; the boot with :malli.core/invalid-schema instead of asserting. The
;; component schemas lean on the shared registry (db pool, metrics,
;; redis client, msgbus, job defs), so the registry dependencies must
;; be loaded for them to compile, like the full system does.
(t/deftest worker-component-schemas-resolve-every-ref
(t/testing "cron, dispatcher and runner schemas compile"
(t/is (sm/schema? (sm/schema ::mbus/msgbus)))
(doseq [s [@#'wcron/schema:params
@#'wdisp/schema:dispatcher
@#'wrkr/schema:params]]
(t/is (sm/schema? (sm/schema s))))))

6
scripts/ci
View File

@ -8,6 +8,12 @@ SCRIPT_DIR="$(cd "$(dirname "${BASH_SOURCE[0]}")" && pwd)"
PROJECT_ROOT="$(dirname "$SCRIPT_DIR")"
LOG_DIR="$PROJECT_ROOT/.ci-logs"
# `clojure.core/assert` is elided at compile time when `*assert*` is false,
# and `app.config` only sets that var from these flags. Without this the
# backend suite runs with every assertion compiled out, silently. Appending
# keeps whatever flags the caller already exported.
export PENPOT_FLAGS="${PENPOT_FLAGS:+$PENPOT_FLAGS } enable-backend-asserts"
# Color codes
RED='\033[0;31m'
GREEN='\033[0;32m'