diff --git a/.github/workflows/all-tests.yaml b/.github/workflows/all-tests.yaml index 41a1f666..9f1772e6 100644 --- a/.github/workflows/all-tests.yaml +++ b/.github/workflows/all-tests.yaml @@ -28,13 +28,16 @@ jobs: steps: - uses: actions/checkout@v5 + # Third-party actions are pinned to commit SHAs: a moving tag/branch + # can be force-pushed to run arbitrary code in CI. - name: Install Nix - uses: DeterminateSystems/nix-installer-action@main + uses: DeterminateSystems/nix-installer-action@ef8a148080ab6020fd15196c2084a2eea5ff2d25 # v22 - name: Setup Nix Cache - uses: DeterminateSystems/magic-nix-cache-action@main + uses: nix-community/cache-nix-action@7df957e333c1e5da7721f60227dbba6d06080569 # v7.0.2 with: - use-flakehub: false + primary-key: nix-${{ runner.os }}-${{ hashFiles('**/*.nix', 'flake.lock') }} + restore-prefixes-first-match: nix-${{ runner.os }}- - name: Install dependencies run: nix develop --command make deps diff --git a/.github/workflows/lint-review.yaml b/.github/workflows/lint-review.yaml index 0c5680aa..17756f75 100644 --- a/.github/workflows/lint-review.yaml +++ b/.github/workflows/lint-review.yaml @@ -15,20 +15,26 @@ jobs: - run: echo "🐧 Job running on ${{ runner.os }} server" - run: echo "🐙 Using ${{ github.ref }} branch from ${{ github.repository }} repository" - # Git Checkout + # Git Checkout. persist-credentials: false keeps the token out of the + # workspace git config — no later step pushes, and third-party action + # code (SHA-pinned below) must not be able to read it. - name: Checkout Code uses: actions/checkout@v5 with: token: "${{ secrets.PAT || secrets.GITHUB_TOKEN }}" + persist-credentials: false - run: echo "🐙 ${{ github.repository }} repository was cloned to the runner." + # Third-party actions are pinned to commit SHAs: a moving tag/branch + # can be force-pushed to run arbitrary code in CI. - name: Install Nix - uses: DeterminateSystems/nix-installer-action@main + uses: DeterminateSystems/nix-installer-action@ef8a148080ab6020fd15196c2084a2eea5ff2d25 # v22 - name: Setup Nix Cache - uses: DeterminateSystems/magic-nix-cache-action@main + uses: nix-community/cache-nix-action@7df957e333c1e5da7721f60227dbba6d06080569 # v7.0.2 with: - use-flakehub: false + primary-key: nix-${{ runner.os }}-${{ hashFiles('**/*.nix', 'flake.lock') }} + restore-prefixes-first-match: nix-${{ runner.os }}- - name: Run clj-kondo run: | diff --git a/Makefile b/Makefile index 5acb4c74..27c23874 100644 --- a/Makefile +++ b/Makefile @@ -133,16 +133,16 @@ deploy-dev: upload ## Deploy to the staging instance sudo ln -nfs releases/$(JAR_BASENAME) current-dev; \ sudo systemctl restart parts-dev' -rollback: - ssh $(HOST) 'set -e; \ +rollback: ## Point current back at the previous release + ssh -t $(HOST) 'set -e; \ cd $(REMOTE); \ prev=$$(readlink previous || true); \ if [ -z "$$prev" ]; then \ echo "No previous release to roll back to!" >&2; \ exit 1; \ fi; \ - ln -nfs "$$prev" current; \ - systemctl restart parts' + sudo ln -nfs "$$prev" current; \ + sudo systemctl restart parts' clean: ## Clean build files rm -rf ./.cpcache \ diff --git a/deps.edn b/deps.edn index 4e20242c..7cff42a8 100644 --- a/deps.edn +++ b/deps.edn @@ -63,14 +63,11 @@ ;; Backend async operations (used for token cleanup scheduling) org.clojure/core.async {:mvn/version "1.7.701"} ;; - ;; Production REPL tooling - nrepl/nrepl {:mvn/version "1.3.0"} - cider/cider-nrepl {:mvn/version "0.58.0" - :exclusions [org.clojure/clojuredocs]} - ;; - ;; Kaocha - for running tests from production REPL - ;; https://github.com/lambdaisland/kaocha - lambdaisland/kaocha {:mvn/version "1.91.1392"}} + ;; Production REPL: plain nREPL over a unix socket (server/start-nrepl). + ;; Editor middleware (cider) and test tooling stay in the :dev/:test + ;; aliases — deliberately absent from the production artifact to keep the + ;; in-process RCE surface minimal. + nrepl/nrepl {:mvn/version "1.3.0"}} :aliases {:run/app @@ -81,6 +78,14 @@ {;; Dev-only visualization tool djblue/portal {:mvn/version "0.62.0"} ;; + ;; Editor nREPL middleware (dev-only; prod runs plain nREPL) + cider/cider-nrepl {:mvn/version "0.58.0" + :exclusions [org.clojure/clojuredocs]} + ;; + ;; Test runner for the dev REPL's `repl` ns helpers (kaocha.repl/watch); + ;; the :test aliases carry their own copy + lambdaisland/kaocha {:mvn/version "1.91.1392"} + ;; ;; Editor refactoring tools refactor-nrepl/refactor-nrepl {:mvn/version "3.11.0"} ;; @@ -134,6 +139,7 @@ {:deps {com.github.liquidz/antq {:mvn/version "2.11.1276"}} :main-opts ["-m" "antq.core"]} - ;; Run database migrations + ;; Run database migrations — production deps only (CI depends on this; + ;; the dev `repl` ns requires kaocha, which is a dev/test dependency) :migrate - {:exec-fn repl/db-migrate}}} + {:exec-fn aps.parts.db/migrate!}}} diff --git a/docs/runbook.md b/docs/runbook.md index f0d50994..180b57d3 100644 --- a/docs/runbook.md +++ b/docs/runbook.md @@ -56,14 +56,12 @@ journalctl -u parts --since today -o cat | grep -c unhandled-exception ## Raise a test error — verify the pipeline -To confirm errors actually reach you, emit one through the live pipeline. The -production nREPL binds to loopback only (`127.0.0.1:7888`, see -`resources/parts/prod.edn`), so reach it over an SSH tunnel rather than exposing -the port: +To confirm errors actually reach you, emit one through the live pipeline via +the production REPL (see "Production REPL access" below): ```sh -# from your laptop — forward local 7888 to the server's loopback nREPL -ssh -L 7888:localhost:7888 parts +# from your laptop — forward a local TCP port to the server's REPL socket +ssh -L 7888:/run/parts/nrepl.sock parts # then, in another terminal, connect your nREPL client to localhost:7888 ``` @@ -213,6 +211,13 @@ to Scaleway object storage (`scaleway:parts-prod-backup`): pg_dump --format=custom | age --recipients-file … | rclone rcat …/parts_prod-.dump.age ``` +The job runs as the dedicated **`parts-backup`** system user, not the app +user: the Scaleway credentials live in `/home/parts-backup/.config/rclone/` +(home `0700`), unreadable by `parts` — an app compromise can't reach the +bucket at all. Its DB access is a read-only postgres role (`pg_read_all_data`, +peer-authenticated). Run any manual rclone command against the bucket as that +user: `sudo -u parts-backup rclone lsf scaleway:parts-prod-backup/`. + The age **private** key never lives on the server — only the public recipient (`/etc/parts/backup-recipient.age`) does. The private identity stays on your laptop (`~/.config/parts-backup/identity.txt`), so a server compromise cannot @@ -223,9 +228,51 @@ scripts/restore-from-backup.sh ~/Downloads/parts_prod-.dump.age parts_restor ``` **Append-only by design.** The backup credential on the box has `s3:ListBucket` -+ `s3:PutObject` only — **no Delete**. A compromised server can add backups but -cannot wipe, overwrite, or encrypt them (ransomware / tamper resistance). Keep -it that way: never grant the box's key delete rights. ++ `s3:PutObject` only — **no Delete** (and no `GetObject`). A compromised server +can add backups but cannot wipe, overwrite, read, or encrypt them (ransomware / +tamper resistance). Keep it that way: never grant the box's key delete rights. + +**The key cannot read, so the upload must never read.** Because a `HEAD` is +authorized as `GetObject`, any rclone operation that stats an object 403s. +The backup therefore spools the encrypted dump to a temp file and uploads it +with `rclone copyto --s3-no-check-bucket --s3-no-head --no-check-dest` — one +known-size `PutObject`, no reads. Do **not** use `rclone rcat`: streaming with +unknown length becomes a multipart upload whose metadata read-back fails, which +is what made backups report failure nightly from 2026-07-22 (the objects landed +and restored fine; only the exit code lied). Same reason `rclone touch` and a +bare `copyto` fail: both stat first. + +**Failure alerting.** `parts-backup.service` (and `parts.service`) carry +`OnFailure=parts-alert@%n.service`, a templated unit that mails the failing +unit's last 40 journal lines via `/usr/local/bin/parts-alert` — which reuses +the app's SMTP settings from `/etc/parts.env`, so alerting is configured in +one place. Test it end to end with a unit that is guaranteed to fail: + +```sh +systemd-run --unit=alert-selftest --property=OnFailure=parts-alert@%n.service /bin/false +# an email titled "[parts] unit FAILED on : alert-selftest.service" should arrive +``` + +If nothing arrives, check `journalctl -u parts-alert@*` — with SMTP unset the +mailer exits 0 with "SMTP not configured", by the same rule as the app. + +**Standing check — verify the key really can't delete.** That property lives +in the Scaleway console, not this repo, so re-verify at setup, after any key +rotation, and alongside the retention check. Read the bucket policy: +**Object Storage → parts-prod-backup → Bucket settings → Bucket policy**. The +app principal's statement must list exactly: + +```json +"Action": [ "s3:ListBucket", "s3:PutObject" ] +``` + +No `s3:DeleteObject` (can't destroy), no `s3:GetObject` (can't read back — +this is also why the upload must not stat, see above). The separate +`user_id:` statement with `"Action": "*"` is the owner's own access and is +expected; that principal is you in the console, not the box. + +Prefer reading the policy over probing with a write: `rclone deletefile` +needs a stat first, so a denial there proves nothing about delete rights. **30-day retention (a published promise).** The Privacy Policy and DPA state that erasure propagates through backups within 30 days. Because the box can't @@ -481,6 +528,62 @@ sudo systemctl restart parts && journalctl -u parts -f Confirm the data is all present (`\dt`, key row counts against the old box), log in to smoke-test — then, only once verified, retire the old box. +## Erasure least-privilege (`deletion_role`) + +Normal operation never hard-DELETEs from the temporal tables (`users`, +`maps`, `map_metadata`, `parts`, `relationships`) — only the erasure purge +does. That invariant is enforced in three layers: + +1. **Provisioning** (`bootstrap-prod.sh` / `add-instance.sh`, as the + postgres superuser): creates `deletion_role` (NOLOGIN) and grants the app + role membership **`WITH INHERIT FALSE`** — an inheriting membership hands + the app role every deletion_role privilege passively, silently undoing + the revoke (found live on staging; a re-grant updates the option in + place). Must pre-exist before first boot — the app role holds + `NOCREATEROLE`. +2. **Migration `20260726000000`** (as the app role): grants `deletion_role` + everything the purge touches and `REVOKE DELETE ... FROM CURRENT_USER` on + the temporal tables. +3. **The purge** (`db/erasure.clj`): `SET LOCAL ROLE deletion_role` for the + purge transaction only. + +The revoke is a **speed bump, not a wall**: the app role owns the tables and +an owner can re-grant itself DELETE. It still stops every accidental or +injected DELETE in normal query paths (the threat it targets); ownership +separation was considered and deliberately not taken (migration comment has +the full rationale). + +**Verify on a running box** (expect *permission denied*, then *DELETE 0*): + +```sh +sudo -u postgres psql -d parts_prod -c "SET ROLE parts; DELETE FROM parts WHERE false;" +sudo -u postgres psql -d parts_prod -c "SET ROLE parts; SET ROLE deletion_role; DELETE FROM parts WHERE false;" +``` + +## Production REPL access + +The prod app runs an nREPL on a **unix domain socket**, +`/run/parts/nrepl.sock` (`prod.edn :repl/socket`), permissioned `0600` and +owned by the `parts` user. nREPL has **no authentication** — a connected +client has arbitrary code execution as the app user, including its DB +credentials and environment. The socket gate means "may connect" requires +filesystem access as `parts` (or root), not merely "runs on the box": a +loopback **TCP** REPL would be connectable by *any* local process (the +oauth2-proxy sidecar, a compromised dependency, an SSRF-to-localhost gadget). + +Connect from a laptop by forwarding a local port to the socket: + +```sh +ssh -L 7888:/run/parts/nrepl.sock parts +# connect your nREPL client to localhost:7888 +``` + +Residual risk, deliberately accepted: code already running *as* `parts` (an +app RCE) can use the socket, but it can already do everything the REPL +offers. `PARTS__REPL__PORT` re-enables a loopback TCP REPL as an explicit +escape hatch — leave it unset. The production artifact ships plain nREPL +only (no cider middleware, no test runner; those are dev aliases). + ## Rate limiting & the trusted client IP (`X-Real-IP`) The per-IP rate limiter (`aps.parts.ratelimit`, on login / register / invite) diff --git a/package.json b/package.json index 060ac8c3..8b859bd6 100644 --- a/package.json +++ b/package.json @@ -16,6 +16,6 @@ "postcss-nesting": "^13.0.2", "shadow-cljs": "^2.28.23", "tailwindcss": "^4.2.4", - "ws": "^7.5.10" + "ws": "^8.18.0" } } diff --git a/pnpm-lock.yaml b/pnpm-lock.yaml index 1e2c9b0e..bb2c6d10 100644 --- a/pnpm-lock.yaml +++ b/pnpm-lock.yaml @@ -52,8 +52,8 @@ importers: specifier: ^4.2.4 version: 4.2.4 ws: - specifier: ^7.5.10 - version: 7.5.10 + specifier: ^8.18.0 + version: 8.21.1 packages: @@ -1319,6 +1319,18 @@ packages: utf-8-validate: optional: true + ws@8.21.1: + resolution: {integrity: sha512-+0NTnW77fFN/DjQi6k/Sq/Yvk4Sgajw7urW8V+asjXnRgDs9gyGkdb7EzgfhA4goXsRIZKE28fzIXBHEzhuiWw==} + engines: {node: '>=10.0.0'} + peerDependencies: + bufferutil: ^4.0.1 + utf-8-validate: '>=5.0.2' + peerDependenciesMeta: + bufferutil: + optional: true + utf-8-validate: + optional: true + xtend@4.0.2: resolution: {integrity: sha512-LKYU1iAXJXUgAXn9URjiu+MWhyUXHsvfp7mcuYm9dSUKK0/CjtrUwFAxD82/mCWbtLsGjFIad0wIsod4zrTAEQ==} engines: {node: '>=0.4'} @@ -2701,6 +2713,8 @@ snapshots: ws@7.5.10: {} + ws@8.21.1: {} + xtend@4.0.2: {} y18n@5.0.8: {} diff --git a/resources/migrations/20260726000000-deletion-role-wiring.down.sql b/resources/migrations/20260726000000-deletion-role-wiring.down.sql new file mode 100644 index 00000000..4c5d76bc --- /dev/null +++ b/resources/migrations/20260726000000-deletion-role-wiring.down.sql @@ -0,0 +1,12 @@ +GRANT DELETE ON parts, relationships, maps, map_metadata, users + TO CURRENT_USER; +--;; +REVOKE SELECT, DELETE ON sessions, session_activations, invitations, + waitlist_signups, policy_acceptances, map_metadata + FROM deletion_role; +--;; +REVOKE SELECT ON parts, relationships FROM deletion_role; +--;; +REVOKE INSERT ON audit_log FROM deletion_role; +--;; +REVOKE USAGE ON SEQUENCE audit_log_id_seq FROM deletion_role; diff --git a/resources/migrations/20260726000000-deletion-role-wiring.up.sql b/resources/migrations/20260726000000-deletion-role-wiring.up.sql new file mode 100644 index 00000000..0bc072eb --- /dev/null +++ b/resources/migrations/20260726000000-deletion-role-wiring.up.sql @@ -0,0 +1,38 @@ +-- Finish the deletion_role least-privilege wiring (TASK-053). +-- +-- The everyday app role loses DELETE on the temporal tables; the erasure +-- purge gains that capability only by SET LOCAL ROLE deletion_role inside +-- its transaction (db/erasure.clj). deletion_role gets every privilege the +-- purge path uses, so assuming the role can't make the purge fail. +-- +-- DECISION (owner-vs-connection-role caveat): the app role OWNS these +-- tables, and an owner can re-GRANT itself DELETE — so this REVOKE is a +-- SPEED BUMP, not an airtight wall. It still stops every accidental or +-- injected DELETE running through normal query paths, which is the threat +-- this defends against. Separating table ownership from the connection +-- role would close the gap but is a much larger change (ownership +-- migration, migratus needs DDL as non-owner); deliberately not taken. +-- +-- Role management split: CREATE ROLE / role membership need superuser and +-- happen in the provisioning scripts (bootstrap-prod.sh, add-instance.sh — +-- the app role holds NOCREATEROLE). This migration only GRANTs/REVOKEs on +-- tables the connecting role owns, which any owner may do. REVOKE ... FROM +-- CURRENT_USER targets whichever app role runs the migrations on this box +-- (parts on prod, parts_dev on staging, the dev's user locally — where a +-- superuser runs it, the revoke is recorded but superuser bypasses ACLs). + +GRANT SELECT, DELETE ON parts, relationships, maps, map_metadata, + sessions, session_activations, invitations, + waitlist_signups, policy_acceptances TO deletion_role; +--;; +-- The audit trigger fires on the purge's own DELETEs and INSERTs rows as +-- the assumed role (which also draws from the id sequence); the scrub and +-- pseudonymization UPDATE it. +GRANT SELECT, INSERT, UPDATE ON audit_log TO deletion_role; +--;; +GRANT USAGE ON SEQUENCE audit_log_id_seq TO deletion_role; +--;; +GRANT SELECT, UPDATE, DELETE ON users TO deletion_role; +--;; +REVOKE DELETE ON parts, relationships, maps, map_metadata, users + FROM CURRENT_USER; diff --git a/resources/migrations/20260726000001-auth-sessions.down.sql b/resources/migrations/20260726000001-auth-sessions.down.sql new file mode 100644 index 00000000..25b7a7f8 --- /dev/null +++ b/resources/migrations/20260726000001-auth-sessions.down.sql @@ -0,0 +1 @@ +DROP TABLE auth_sessions; diff --git a/resources/migrations/20260726000001-auth-sessions.up.sql b/resources/migrations/20260726000001-auth-sessions.up.sql new file mode 100644 index 00000000..260bd723 --- /dev/null +++ b/resources/migrations/20260726000001-auth-sessions.up.sql @@ -0,0 +1,21 @@ +-- Server-side auth sessions (TASK-023). The browser cookie carries only an +-- opaque random UUID; the session data lives here — so any session can be +-- revoked server-side ("log out everywhere", lost device), and deleting a +-- user cascades their sessions away. Distinct from `sessions`, the clinical +-- timeline entity (ADR-0014). +-- +-- `data` is EDN text (exact round-trip of ring's session map, including +-- namespaced keyword keys that JSONB would mangle). `expires_at` is the +-- ABSOLUTE 14-day bound (ADR-0007): writes refresh data, never the deadline. +-- `user_id` is NULL for anonymous sessions (the CSRF token pre-login). +CREATE TABLE auth_sessions ( + id UUID PRIMARY KEY, + user_id UUID REFERENCES users(id) ON DELETE CASCADE, + data TEXT NOT NULL, + created_at TIMESTAMPTZ NOT NULL DEFAULT now(), + expires_at TIMESTAMPTZ NOT NULL +); +--;; +CREATE INDEX auth_sessions_user ON auth_sessions (user_id); +--;; +CREATE INDEX auth_sessions_expires ON auth_sessions (expires_at); diff --git a/resources/migrations/20260726000002-invitation-expiry.down.sql b/resources/migrations/20260726000002-invitation-expiry.down.sql new file mode 100644 index 00000000..1d78de32 --- /dev/null +++ b/resources/migrations/20260726000002-invitation-expiry.down.sql @@ -0,0 +1 @@ +ALTER TABLE invitations DROP COLUMN expires_at; diff --git a/resources/migrations/20260726000002-invitation-expiry.up.sql b/resources/migrations/20260726000002-invitation-expiry.up.sql new file mode 100644 index 00000000..eae13f95 --- /dev/null +++ b/resources/migrations/20260726000002-invitation-expiry.up.sql @@ -0,0 +1,7 @@ +-- Invitation tokens get a TTL: single-use was the only bound, so an old +-- unredeemed magic link stayed a live bearer credential forever. Existing +-- pending invitations get a fresh 180 days from this migration rather than +-- being killed retroactively. +ALTER TABLE invitations + ADD COLUMN expires_at TIMESTAMPTZ NOT NULL + DEFAULT (now() + interval '180 days'); diff --git a/resources/parts/prod.edn b/resources/parts/prod.edn index 641df285..d5d554af 100644 --- a/resources/parts/prod.edn +++ b/resources/parts/prod.edn @@ -1,6 +1,8 @@ {:db/host "localhost" :db/name "parts_prod" :db/user "parts" + ;; Loopback-only topology; config.clj fails fast if the host goes remote + ;; while TLS stays off (assert-db-topology!). :db/ssl false :http/protocol "https" @@ -11,7 +13,8 @@ ;; then — the loader falls back to the bundled resources/legal/*.example.md. :legal/content-dir "/var/lib/parts/legal" - :repl/port 7888 - :repl/host "127.0.0.1" + ;; Operator REPL over a unix socket, 0600 — filesystem-gated, never TCP by + ;; default (nREPL has no auth). /run/parts is systemd's RuntimeDirectory. + :repl/socket "/run/parts/nrepl.sock" :launch/launched? false} diff --git a/resources/public/marketing.js b/resources/public/marketing.js new file mode 100644 index 00000000..b72e930b --- /dev/null +++ b/resources/public/marketing.js @@ -0,0 +1,47 @@ +/* Analytics wiring for the public pages (marketing, legal, playground). + * + * Exists so those pages can carry a strict Content-Security-Policy with no + * 'unsafe-inline': elements declare what to track via data attributes and + * this file wires the listeners. + * + * data-analytics event name sent to plausible() + * data-analytics-source becomes {props: {source: ...}} + * data-analytics-on "click" (default) | "focus" | "submit" + * + * A waitlist-success fragment swapped in by htmx may carry + * data-counter-increment to bump the visible #counter once. + */ + +window.plausible = window.plausible || function () { + (window.plausible.q = window.plausible.q || []).push(arguments); +}; + +(function () { + function fire(el) { + var source = el.getAttribute('data-analytics-source'); + window.plausible(el.getAttribute('data-analytics'), + source ? { props: { source: source } } : undefined); + } + + function on(kind) { + return function (e) { + var el = e.target.closest && e.target.closest('[data-analytics]'); + if (el && (el.getAttribute('data-analytics-on') || 'click') === kind) { + fire(el); + } + }; + } + + document.addEventListener('click', on('click')); + document.addEventListener('focusin', on('focus')); + document.addEventListener('submit', on('submit'), true); + + document.addEventListener('htmx:afterSwap', function () { + var el = document.querySelector('[data-counter-increment]:not([data-counted])'); + var counter = document.getElementById('counter'); + if (el && counter) { + el.setAttribute('data-counted', ''); + counter.textContent = (parseInt(counter.textContent, 10) || 0) + 1; + } + }); +})(); diff --git a/scripts/add-instance.sh b/scripts/add-instance.sh index e0f19755..40224944 100755 --- a/scripts/add-instance.sh +++ b/scripts/add-instance.sh @@ -123,8 +123,8 @@ if [[ "$INSTALLED_VERSION" != "$OAUTH2_PROXY_VERSION" ]]; then fi # 2. postgres — a separate database AND role, so a leaked dev-instance -# password can't authenticate against the prod database. The parts role's -# CREATEROLE grant (from bootstrap-prod.sh) is what lets this run. +# password can't authenticate against the prod database. Everything here +# runs as the postgres superuser; the app role holds no CREATEROLE. if [[ "$FIRST_RUN" == true ]]; then # Create the role only if absent, but ALWAYS (re)set its password to the # value written into the env file below — a CREATE USER that hits an existing @@ -133,12 +133,20 @@ if [[ "$FIRST_RUN" == true ]]; then # if absent. role_exists=$(sudo -u postgres psql -tAc "SELECT 1 FROM pg_roles WHERE rolname='$DB_USER'") [[ "$role_exists" == 1 ]] || sudo -u postgres psql -c "CREATE ROLE $DB_USER" - printf "ALTER ROLE %s WITH LOGIN PASSWORD '%s';\n" "$DB_USER" "$DB_PASSWORD" \ + printf "ALTER ROLE %s WITH LOGIN NOCREATEROLE PASSWORD '%s';\n" "$DB_USER" "$DB_PASSWORD" \ | sudo -u postgres psql db_exists=$(sudo -u postgres psql -tAc "SELECT 1 FROM pg_database WHERE datname='$DB_NAME'") [[ "$db_exists" == 1 ]] || sudo -u postgres psql -c "CREATE DATABASE $DB_NAME OWNER $DB_USER" fi +# Erasure least-privilege (see bootstrap-prod.sh): role must pre-exist +# before first boot; only a superuser may grant membership. Idempotent, +# so it runs on every provision, not only FIRST_RUN. +dr_exists=$(sudo -u postgres psql -tAc "SELECT 1 FROM pg_roles WHERE rolname='deletion_role'") +[[ "$dr_exists" == 1 ]] || sudo -u postgres psql -c "CREATE ROLE deletion_role NOLOGIN" +# INHERIT FALSE is load-bearing — see bootstrap-prod.sh. +sudo -u postgres psql -c "GRANT deletion_role TO $DB_USER WITH INHERIT FALSE" + # Ownership force-sync (see bootstrap-prod.sh): a restored database can # leave the DB / `public` schema owned by the restoring role, and since # PostgreSQL 15 that denies the app role CREATE in `public` — later @@ -160,7 +168,10 @@ PARTS__DB__USER=$DB_USER PARTS__DB__PASSWORD=$DB_PASSWORD PARTS__SESSION__KEY=$SESSION_KEY PARTS__RENDER__FONT_DIR=$FONT_DIR -JAVA_OPTS=-server -Xms256m -Xmx256m +# Per-instance nREPL socket — prod.edn's default path belongs to the prod +# service; two instances must not race for one socket. +PARTS__REPL__SOCKET=/run/$SERVICE/nrepl.sock +JAVA_OPTS=-server -Xms256m -Xmx256m -Dorg.slf4j.simpleLogger.defaultLogLevel=warn EOF chown root:root "$ENV_FILE" chmod 600 "$ENV_FILE" @@ -174,6 +185,19 @@ if ! grep -q '^PARTS__RENDER__FONT_DIR=' "$ENV_FILE"; then echo "✓ Appended PARTS__RENDER__FONT_DIR to $ENV_FILE" fi +# Instances provisioned before the slf4j default: append the flag once. +if ! grep -q 'simpleLogger.defaultLogLevel' "$ENV_FILE"; then + sed -i 's/^JAVA_OPTS=.*/& -Dorg.slf4j.simpleLogger.defaultLogLevel=warn/' "$ENV_FILE" + echo "✓ Appended slf4j defaultLogLevel=warn to JAVA_OPTS" +fi + +# Instances provisioned before the unix-socket nREPL: give each its own +# socket path once (prod.edn's default path belongs to the prod service). +if ! grep -q '^PARTS__REPL__SOCKET=' "$ENV_FILE"; then + printf 'PARTS__REPL__SOCKET=/run/%s/nrepl.sock\n' "$SERVICE" >>"$ENV_FILE" + echo "✓ Appended PARTS__REPL__SOCKET to $ENV_FILE" +fi + # 4. app systemd unit — mirrors parts.service but with its own env file, # release symlink ($APP_DIR/current-$INSTANCE) and journal identifier. # The unit hardcodes nothing tunable: JAVA_OPTS (JVM flags), PARTS__ENV and @@ -188,6 +212,9 @@ After=network.target postgresql.service User=$APP_USER WorkingDirectory=$APP_DIR EnvironmentFile=$ENV_FILE +# /run/$SERVICE for this instance's 0600 unix-socket nREPL +RuntimeDirectory=$SERVICE +RuntimeDirectoryMode=0750 ExecStart=/usr/bin/java \$JAVA_OPTS -jar $APP_DIR/current-$INSTANCE Restart=on-failure RestartSec=5 @@ -284,12 +311,21 @@ $DOMAIN { X-Robots-Tag "noindex, nofollow" } + # The app's rate limiter trusts X-Real-IP alone; overwrite any + # client-supplied value with the real peer on both handles + # (oauth2-proxy forwards it to the app unmodified). handle /api/* { - reverse_proxy 127.0.0.1:$PORT + reverse_proxy 127.0.0.1:$PORT { + header_up -X-Real-IP + header_up X-Real-IP {http.request.remote.host} + } } handle { - reverse_proxy 127.0.0.1:$OAUTH2_PORT + reverse_proxy 127.0.0.1:$OAUTH2_PORT { + header_up -X-Real-IP + header_up X-Real-IP {http.request.remote.host} + } } } EOF diff --git a/scripts/bootstrap-prod.sh b/scripts/bootstrap-prod.sh index cc8dc02e..4b3a866c 100755 --- a/scripts/bootstrap-prod.sh +++ b/scripts/bootstrap-prod.sh @@ -57,7 +57,7 @@ chown -R "$APP_USER:$APP_USER" "$APP_DIR" # Empty until content is pushed — until then the app serves the bundled examples. mkdir -p /var/lib/parts/legal chown "$ADMIN_USER:$APP_USER" /var/lib/parts/legal -chmod 755 /var/lib/parts/legal +chmod 750 /var/lib/parts/legal # PDF document fonts — the renderer requires Noto Sans CJK TC (see # ADR-0008): FOP renders glyphs missing from its font as a literal `#`, @@ -105,7 +105,11 @@ else # force-syncs the two. The database is created only if absent, never dropped. role_exists=$(sudo -u postgres psql -tAc "SELECT 1 FROM pg_roles WHERE rolname='$APP_NAME'") [[ "$role_exists" == 1 ]] || sudo -u postgres psql -c "CREATE ROLE $APP_NAME" - printf "ALTER ROLE %s WITH LOGIN CREATEROLE PASSWORD '%s';\n" "$APP_NAME" "$DB_PASSWORD" \ + # NOCREATEROLE: add-instance.sh does all role creation as the postgres + # superuser, so the app role never needs it — and an app-level SQLi must + # not be able to CREATE ROLE for persistence. Re-running this on an + # existing box strips a previously granted CREATEROLE. + printf "ALTER ROLE %s WITH LOGIN NOCREATEROLE PASSWORD '%s';\n" "$APP_NAME" "$DB_PASSWORD" \ | sudo -u postgres psql db_exists=$(sudo -u postgres psql -tAc "SELECT 1 FROM pg_database WHERE datname='${APP_NAME}_prod'") [[ "$db_exists" == 1 ]] || sudo -u postgres psql -c "CREATE DATABASE ${APP_NAME}_prod OWNER $APP_NAME" @@ -124,7 +128,9 @@ PARTS__SESSION__KEY=$SESSION_KEY # PDF document fonts (Noto Sans CJK TC; see ADR-0008 and the runbook). PARTS__RENDER__FONT_DIR=/var/lib/parts/fonts -JAVA_OPTS=-server -Xms512m -Xmx512m +# slf4j at warn: it is the catch-all sink for chatty libs (JDBC, FOP) whose +# INFO lines can embed query fragments; structured logging goes via mulog. +JAVA_OPTS=-server -Xms512m -Xmx512m -Dorg.slf4j.simpleLogger.defaultLogLevel=warn # --- Optional: operator error-alert emails (stays off until all four are set; # see docs/runbook.md "Error alerts"). On Hetzner use port 587 (25/465 blocked). @@ -136,7 +142,9 @@ JAVA_OPTS=-server -Xms512m -Xmx512m #PARTS__ALERT__FROM= # --- Optional overrides (prod.edn already sets prod defaults) --- -#PARTS__REPL__PORT=7888 # prod nREPL bind port (loopback only) +#PARTS__REPL__SOCKET=/run/parts/nrepl.sock # unix-socket nREPL (0600; default) +#PARTS__REPL__PORT=7888 # loopback TCP nREPL escape hatch — any local +# # process can connect; prefer the socket #PARTS__HTTP__PORT=3000 EOF chown root:root /etc/$APP_NAME.env @@ -152,6 +160,29 @@ if ! grep -q '^PARTS__RENDER__FONT_DIR=' /etc/$APP_NAME.env; then echo "✓ Appended PARTS__RENDER__FONT_DIR to /etc/$APP_NAME.env" fi +# Boxes provisioned before the slf4j default was set: append the flag to the +# existing JAVA_OPTS line once (chatty libs' INFO can embed query fragments). +if ! grep -q 'simpleLogger.defaultLogLevel' /etc/$APP_NAME.env; then + sed -i 's/^JAVA_OPTS=.*/& -Dorg.slf4j.simpleLogger.defaultLogLevel=warn/' /etc/$APP_NAME.env + echo "✓ Appended slf4j defaultLogLevel=warn to JAVA_OPTS" +fi + +# DB-role hardening — OUTSIDE the first-run guard so existing boxes pick it +# up on re-provision, with no password touched. Idempotent: +# - the app role must not CREATE ROLE (SQLi persistence); +# - deletion_role must pre-exist before migrations run (the app role's +# NOCREATEROLE means the old migration's CREATE would fail), and only a +# superuser may grant the app role membership (erasure least-privilege, +# migration 20260726000000 + runbook). +sudo -u postgres psql -c "ALTER ROLE $APP_NAME NOCREATEROLE" +dr_exists=$(sudo -u postgres psql -tAc "SELECT 1 FROM pg_roles WHERE rolname='deletion_role'") +[[ "$dr_exists" == 1 ]] || sudo -u postgres psql -c "CREATE ROLE deletion_role NOLOGIN" +# INHERIT FALSE is load-bearing: a default (inheriting) membership hands the +# app role every deletion_role privilege passively, silently undoing the +# DELETE revoke. With it, the privileges arrive only via explicit SET ROLE +# in the purge. Re-granting updates the option on an existing membership. +sudo -u postgres psql -c "GRANT deletion_role TO $APP_NAME WITH INHERIT FALSE" + # Ownership force-sync — same reasoning as the ALTER ROLE above: a # database that arrived by restore (box migration) can leave the DB and # its `public` schema owned by the restoring role, and since @@ -176,11 +207,17 @@ cat >/etc/systemd/system/$APP_NAME.service </dev/null 2>&1 || \ + useradd --system --create-home --home-dir /home/$BACKUP_USER \ + --shell /usr/sbin/nologin $BACKUP_USER +chmod 700 /home/$BACKUP_USER + +# Read-only postgres role, peer-authenticated as the backup unix user. +backup_role_exists=$(sudo -u postgres psql -tAc "SELECT 1 FROM pg_roles WHERE rolname='$BACKUP_USER'") +[[ "$backup_role_exists" == 1 ]] || sudo -u postgres psql -c "CREATE ROLE \"$BACKUP_USER\" LOGIN" +sudo -u postgres psql -c "GRANT pg_read_all_data TO \"$BACKUP_USER\"" + # Age recipient (public key) — placeholder; operator must replace with real key mkdir -p /etc/$APP_NAME if [[ ! -f /etc/$APP_NAME/backup-recipient.age ]]; then @@ -210,11 +262,18 @@ EOF echo "⚠️ Created /etc/$APP_NAME/backup-recipient.age placeholder — replace with your age public key" fi -# rclone config for Scaleway — placeholder; operator must fill in API keys -RCLONE_DIR=/home/$APP_USER/.config/rclone -sudo -u $APP_USER mkdir -p "$RCLONE_DIR" +# rclone config for Scaleway, owned by the backup user. A pre-existing +# operator-filled config under the app user is migrated (moved, not copied — +# it must leave the app user's reach). +RCLONE_DIR=/home/$BACKUP_USER/.config/rclone +OLD_RCLONE=/home/$APP_USER/.config/rclone/rclone.conf +mkdir -p "$RCLONE_DIR" +if [[ ! -f "$RCLONE_DIR/rclone.conf" && -f "$OLD_RCLONE" ]]; then + mv "$OLD_RCLONE" "$RCLONE_DIR/rclone.conf" + echo "Migrated rclone.conf from $APP_USER to $BACKUP_USER" +fi if [[ ! -f "$RCLONE_DIR/rclone.conf" ]]; then - sudo -u $APP_USER tee "$RCLONE_DIR/rclone.conf" >/dev/null <<'EOF' + cat >"$RCLONE_DIR/rclone.conf" <<'EOF' [scaleway] type = s3 provider = Scaleway @@ -224,9 +283,81 @@ endpoint = s3.fr-par.scw.cloud region = fr-par acl = private EOF - sudo -u $APP_USER chmod 600 "$RCLONE_DIR/rclone.conf" echo "⚠️ Created $RCLONE_DIR/rclone.conf placeholder — fill in Scaleway API keys" fi +chown -R $BACKUP_USER:$BACKUP_USER /home/$BACKUP_USER/.config +chmod 600 "$RCLONE_DIR/rclone.conf" + +# Operator alert mailer — reuses the app's SMTP credentials so there is one +# place to configure alerting. Root-only (0700): it reads the env file's +# SMTP password. Body on stdin, subject as \$1. +cat >/usr/local/bin/$APP_NAME-alert </dev/null | cut -d= -f2- || true; } + +HOST=\$(val PARTS__SMTP__HOST) +USER=\$(val PARTS__SMTP__USER) +PASS=\$(val PARTS__SMTP__PASSWORD) +TO=\$(val PARTS__ALERT__TO) +FROM=\$(val PARTS__ALERT__FROM) +PORT=\$(val PARTS__SMTP__PORT) + +# Same rule as the app: alerting stays off until deliberately configured. +if [[ -z "\$HOST" || -z "\$USER" || -z "\$PASS" || -z "\$TO" ]]; then + echo "SMTP not configured in \$ENV_FILE — no alert sent" >&2 + exit 0 +fi + +FROM=\${FROM:-\$USER} +PORT=\${PORT:-465} +if [[ "\$PORT" == 587 ]]; then + URL="smtp://\$HOST:587" + TLS=(--ssl-reqd) # STARTTLS +else + URL="smtps://\$HOST:\$PORT" + TLS=() # implicit SSL +fi + +{ + printf 'From: %s\nTo: %s\nSubject: %s\n\n' "\$FROM" "\$TO" "\$SUBJECT" + cat +} | curl --silent --show-error --url "\$URL" "\${TLS[@]}" \\ + --user "\$USER:\$PASS" --mail-from "\$FROM" --mail-rcpt "\$TO" \\ + --upload-file - +EOF +chmod 700 /usr/local/bin/$APP_NAME-alert + +# Body of the failure notifier. A separate script because systemd does its +# own quote parsing: an inline `bash -c '... "..." ...'` in ExecStart is +# rejected as unbalanced quoting. +cat >/usr/local/bin/$APP_NAME-alert-unit </etc/systemd/system/$APP_NAME-alert@.service </usr/local/bin/$APP_NAME-backup <"\$TMP" +rclone copyto --s3-no-check-bucket --s3-no-head --no-check-dest \\ + "\$TMP" "\${BUCKET}/\${FILENAME}" echo "Uploaded \${BUCKET}/\${FILENAME}" EOF @@ -252,11 +393,14 @@ cat >/etc/systemd/system/$APP_NAME-backup.service </etc/caddy/Caddyfile cat >/etc/caddy/sites/parts.caddy <&2 + else + if date --version >/dev/null 2>&1; then + fresh_cutoff="$(date -u -d "${MAX_STALENESS_HOURS} hours ago" +%Y-%m-%dT%H%M%SZ)" + else + fresh_cutoff="$(date -u -v-"${MAX_STALENESS_HOURS}"H +%Y-%m-%dT%H%M%SZ)" + fi + if (( 10#$(printf '%s' "$newest" | tr -dc 0-9) < 10#$(printf '%s' "$fresh_cutoff" | tr -dc 0-9) )); then + echo "✗ FAIL: newest backup is ${newest}, older than ${MAX_STALENESS_HOURS}h — backups have STOPPED" >&2 + echo " check: systemctl status parts-backup.service parts-backup.timer" >&2 + fail=1 + else + echo "✓ newest backup ${newest} is within ${MAX_STALENESS_HOURS}h" + fi + fi +fi [[ -n "$unknown" ]] && { echo "⚠ files whose age couldn't be read from the name:" >&2; printf '%s' "$unknown" >&2; } # 2. Versioning must be off (best-effort: needs GetBucketVersioning permission / diff --git a/src/main/aps/parts/api/account.clj b/src/main/aps/parts/api/account.clj index 8cd230ef..11a92619 100644 --- a/src/main/aps/parts/api/account.clj +++ b/src/main/aps/parts/api/account.clj @@ -23,15 +23,26 @@ :standing (billing/account-standing user-record))) (response/status 200)))) +(defn- credential-change? + "True when the update touches a login credential (:email or :password)." + [body] + (boolean (some #{:email :password} (keys body)))) + (defn update-account - "Update own account info" + "Update own account info. Changing a login credential additionally requires + the caller's current password, so a captured session alone cannot take + over the account. `:current_password` is a transient input — it is not in + `user/allowed-update-fields`, so it never reaches the database." [request] - (let [user-id (auth/current-user-id request) - body (:body-params request) - updated-user (user/update! user-id body)] - (mulog/log ::update-account-success :user-id user-id) - (-> (response/response updated-user) - (response/status 200)))) + (let [user-id (auth/current-user-id request) + body (:body-params request)] + (when (and (credential-change? body) + (not (auth/current-password-valid? user-id (:current_password body)))) + (throw (ex-info "Current password is incorrect" {:type :validation}))) + (let [updated-user (user/update! user-id (dissoc body :current_password))] + (mulog/log ::update-account-success :user-id user-id) + (-> (response/response updated-user) + (response/status 200))))) (defn- populate-initial-map! "Populates a new map with demo parts and relationships. diff --git a/src/main/aps/parts/api/auth.clj b/src/main/aps/parts/api/auth.clj index ad9b650a..503f2b40 100644 --- a/src/main/aps/parts/api/auth.clj +++ b/src/main/aps/parts/api/auth.clj @@ -1,6 +1,8 @@ (ns aps.parts.api.auth (:require [aps.parts.auth :as auth] + [aps.parts.auth.session-store :as session-store] + [aps.parts.db :as db] [com.brunobonacci.mulog :as mulog] [ring.util.response :as response])) @@ -24,9 +26,22 @@ (defn logout "POST /api/auth/logout — drop the auth session. `:session nil` tells the - session middleware to clear the cookie." + session middleware to clear the cookie (and the DB store to delete the + row)." [_request] (mulog/log ::logout :status :success) (-> (response/response {:message "Logged out successfully"}) (response/status 200) (auth/clear-session))) + +(defn logout-everywhere + "POST /api/auth/logout-everywhere — revoke every session belonging to the + current user, this one included. The recovery move for a lost or shared + device: any stolen cookie dies server-side, immediately." + [request] + (let [user-id (auth/current-user-id request) + revoked (session-store/revoke-for-user! db/datasource user-id)] + (mulog/log ::logout-everywhere :user-id user-id :revoked revoked) + (-> (response/response {:message "Logged out everywhere" :revoked revoked}) + (response/status 200) + (auth/clear-session)))) diff --git a/src/main/aps/parts/api/maps_events.clj b/src/main/aps/parts/api/maps_events.clj index 5295496b..a2af6633 100644 --- a/src/main/aps/parts/api/maps_events.clj +++ b/src/main/aps/parts/api/maps_events.clj @@ -15,6 +15,7 @@ `:success false` never appears — failures throw instead." (:require [aps.parts.common.change-event :as change-event] + [aps.parts.common.constants :as constants] [aps.parts.entity.part :as part] [aps.parts.entity.relationship :as relationship] [next.jdbc :as jdbc])) @@ -74,6 +75,12 @@ time or process-time, propagates as a `:batch-failure` `ex-info` carrying `:failing-change`, and the transaction rolls back." [ds {:keys [map-id actor-id changes]}] + (when (and (sequential? changes) + (> (count changes) constants/max-change-batch)) + (throw (ex-info (str "Change batch exceeds the maximum of " + constants/max-change-batch " changes") + {:type :validation + :count (count changes)}))) (let [parsed (try (change-event/parse changes) (catch Throwable t diff --git a/src/main/aps/parts/auth.clj b/src/main/aps/parts/auth.clj index 5c498ed2..69eaca62 100644 --- a/src/main/aps/parts/auth.clj +++ b/src/main/aps/parts/auth.clj @@ -10,12 +10,13 @@ `require-auth`, `wrap-map-access`) lives separately and depends on this namespace." (:require + [aps.parts.auth.session-store :as session-store] [aps.parts.common.utils :refer [normalize-email]] [aps.parts.config :as conf] [aps.parts.db :as db] [buddy.auth.backends :as backends] [buddy.hashers :as hashers] - [ring.middleware.session.cookie :refer [cookie-store]])) + [clojure.string :as str])) ;; -- credentials ---------------------------------------------------------- @@ -27,18 +28,41 @@ [password hash] (:valid (hashers/verify password hash))) +(def ^:private timing-decoy-hash + "A throwaway bcrypt hash verified on the absent-user path, so a login + attempt takes the same time whether or not the email exists — response + timing must not enumerate accounts." + (delay (hash-password "timing-equalization-decoy"))) + (defn authenticate "Verify EMAIL + PASSWORD against the stored user. Returns the user map (without `password_hash`) on success, nil on a missing user or a wrong password. The caller establishes the auth session from the returned id." [{:keys [email password]}] - (let [normalized-email (normalize-email email)] - (when-let [user (db/query-one - (db/sql-format {:select [:*] - :from [:users] - :where [:= :email normalized-email]}))] + (let [normalized-email (normalize-email email) + user (db/query-one + (db/sql-format {:select [:*] + :from [:users] + :where [:= :email normalized-email]}))] + (if user (when (check-password password (:password_hash user)) - (dissoc user :password_hash))))) + (dissoc user :password_hash)) + (do (check-password (or password "") @timing-decoy-hash) + nil)))) + +(defn current-password-valid? + "True when `password` matches the stored hash for `user-id`; blank or + missing input is never valid. Step-up re-auth for credential changes — + holding the session must not suffice to rotate the login credentials. + Queries the hash directly because `user/fetch` strips it." + [user-id password] + (boolean + (and (not (str/blank? password)) + (when-let [user (db/query-one + (db/sql-format {:select [:password_hash] + :from [:users] + :where [:= :id (db/->uuid user-id)]}))] + (check-password password (:password_hash user)))))) ;; -- the auth session ----------------------------------------------------- @@ -49,19 +73,20 @@ (backends/session)) (def ^:private session-max-age - "Absolute auth-session lifetime — 14 days, in seconds (ADR-0007). With the - encrypted cookie store there is no server-side revocation, so this is the - one browser-enforced bound on a compromised cookie." + "Absolute auth-session lifetime — 14 days, in seconds (ADR-0007). The + DB-backed store enforces it server-side (`expires_at`); the cookie + Max-Age merely mirrors it for the browser." (* 14 24 60 60)) (defn session-config "Ring session config for the one auth session shared by the HTML routes - and /api: an encrypted (AES) cookie store, httpOnly, SameSite=Lax, Secure - in production only (dev is plain HTTP). The 16-byte key comes from config - and must be stable in prod — rotating it invalidates every session. See - ADR-0007." + and /api: a DB-backed store (`aps.parts.auth.session-store` — opaque id + in the cookie, data + server-side revocation in postgres), httpOnly, + SameSite=Lax, Secure in production only (dev is plain HTTP). Supersedes + ADR-0007's encrypted cookie store; the rest of that design (buddy + session backend, cookie attributes, anti-forgery) is unchanged." [] - {:store (cookie-store {:key (.getBytes ^String (conf/session-key) "UTF-8")}) + {:store (session-store/db-store db/datasource session-max-age) :cookie-name "parts-session" :cookie-attrs {:http-only true :same-site :lax diff --git a/src/main/aps/parts/auth/session_store.clj b/src/main/aps/parts/auth/session_store.clj new file mode 100644 index 00000000..2422404a --- /dev/null +++ b/src/main/aps/parts/auth/session_store.clj @@ -0,0 +1,79 @@ +(ns aps.parts.auth.session-store + "DB-backed ring session store (TASK-023, superseding ADR-0007's encrypted + cookie store). The cookie holds only an opaque random UUID; data lives in + `auth_sessions`, giving the server what a cookie store can't: revocation. + \"Log out everywhere\" deletes the user's rows, and account deletion + cascades them via the users FK. + + Expiry is ABSOLUTE from creation (ADR-0007's 14-day bound): a write + refreshes the data, never the deadline. Writing to an expired or unknown + id starts that id afresh — an expired session is indistinguishable from + no session." + (:require + [aps.parts.db :as db] + [clojure.edn :as edn] + [next.jdbc :as jdbc] + [next.jdbc.result-set :as rs] + [ring.middleware.session.store :as store]) + (:import + [java.util UUID])) + +(defn- ->uuid-or-nil + "The cookie value is untrusted input — anything that isn't a UUID (or is + a stale encrypted blob from the old cookie store) reads as no session." + [s] + (when (string? s) + (try (UUID/fromString s) (catch IllegalArgumentException _ nil)))) + +(deftype DbSessionStore [ds max-age-seconds] + store/SessionStore + (read-session [_ key] + (or (when-let [id (->uuid-or-nil key)] + (some-> (jdbc/execute-one! + ds + ["SELECT data FROM auth_sessions + WHERE id = ? AND expires_at > now()" id] + {:builder-fn rs/as-unqualified-maps}) + :data + edn/read-string)) + {})) + (write-session [_ key data] + (let [id (or (->uuid-or-nil key) (UUID/randomUUID)) + user-id (some-> (get-in data [:identity :sub]) ->uuid-or-nil)] + (jdbc/execute! + ds + ["INSERT INTO auth_sessions (id, user_id, data, expires_at) + VALUES (?, ?, ?, now() + make_interval(secs => ?)) + ON CONFLICT (id) DO UPDATE + SET data = EXCLUDED.data, + user_id = EXCLUDED.user_id, + expires_at = CASE WHEN auth_sessions.expires_at <= now() + THEN EXCLUDED.expires_at + ELSE auth_sessions.expires_at END" + id user-id (pr-str data) (double max-age-seconds)]) + (str id))) + (delete-session [_ key] + (when-let [id (->uuid-or-nil key)] + (jdbc/execute! ds ["DELETE FROM auth_sessions WHERE id = ?" id])) + nil)) + +(defn db-store + "A SessionStore over `auth_sessions` with an absolute `max-age-seconds`." + [ds max-age-seconds] + (->DbSessionStore ds max-age-seconds)) + +(defn revoke-for-user! + "Delete every auth session belonging to `user-id` — \"log out everywhere\". + Returns the number of sessions revoked." + [ds user-id] + (::jdbc/update-count + (jdbc/execute-one! + ds + ["DELETE FROM auth_sessions WHERE user_id = ?" (db/->uuid user-id)]))) + +(defn delete-expired! + "Sweep expired sessions; returns the number removed. Correctness doesn't + depend on this (reads filter on expires_at) — it only reclaims rows." + [ds] + (::jdbc/update-count + (jdbc/execute-one! ds ["DELETE FROM auth_sessions WHERE expires_at <= now()"]))) diff --git a/src/main/aps/parts/common/change_event.cljc b/src/main/aps/parts/common/change_event.cljc index 78142624..bae8014f 100644 --- a/src/main/aps/parts/common/change_event.cljc +++ b/src/main/aps/parts/common/change_event.cljc @@ -36,38 +36,47 @@ ;; `:create` requires the entity's mandatory attributes; `:update` is any ;; non-empty subset; `:remove` carries nothing. -(def ^:private forbidden-data-keys - "Keys that belong to the envelope (`:id`) or the batch (`:map_id`) and - must never appear in `:data`." - #{:id :map_id}) - -(defn- attribute-map? - "True when `m` carries only entity attributes — no envelope/batch keys." - [m] - (not-any? forbidden-data-keys (keys m))) +(def ^:private part-attr-keys + "The complete client-writable attribute surface per entity. `s/keys` is + open — without this closure a future column (or a server-owned + audit/temporal one) would ride through `:data` into the update path as + a mass-assignable column. Anything outside the set is rejected." + #{:type :label :position_x :position_y :description :width :height + :notes :body_location}) + +(def ^:private relationship-attr-keys + #{:type :source_id :target_id :notes :intensity}) + +(defn- attrs-only + "Predicate: `m`'s keys all belong to `allowed` — closing the otherwise + open `s/keys` specs (which also excludes the envelope's `:id`, the + batch's `:map_id`, and every server-owned column)." + [allowed] + (fn [m] (every? allowed (keys m)))) (s/def ::part-create-data (s/and (s/keys :req-un [::part/type ::part/label ::part/position_x ::part/position_y] :opt-un [::part/description ::part/width ::part/height ::part/notes ::part/body_location]) - attribute-map?)) + (attrs-only part-attr-keys))) (s/def ::part-update-data (s/and (s/keys :opt-un [::part/type ::part/label ::part/position_x ::part/position_y ::part/description ::part/width ::part/height ::part/notes ::part/body_location]) - attribute-map? + (attrs-only part-attr-keys) seq)) (s/def ::relationship-create-data (s/and (s/keys :req-un [::relationship/type ::relationship/source_id ::relationship/target_id] - :opt-un [::relationship/notes]) - attribute-map?)) + :opt-un [::relationship/notes ::relationship/intensity]) + (attrs-only relationship-attr-keys))) (s/def ::relationship-update-data (s/and (s/keys :opt-un [::relationship/type ::relationship/source_id - ::relationship/target_id ::relationship/notes]) - attribute-map? + ::relationship/target_id ::relationship/notes + ::relationship/intensity]) + (attrs-only relationship-attr-keys) seq)) (s/def ::remove-data (s/and map? empty?)) diff --git a/src/main/aps/parts/common/constants.cljc b/src/main/aps/parts/common/constants.cljc index 8277b3f2..c9b0cf34 100644 --- a/src/main/aps/parts/common/constants.cljc +++ b/src/main/aps/parts/common/constants.cljc @@ -24,6 +24,24 @@ the DB default for legacy rows." 100) +(def max-label-length + "Longest allowed short text (a Part's label). Bounded at the spec gate so + an oversized value is rejected wherever the model validates, in both + runtimes." + 200) + +(def max-text-length + "Longest allowed free-text field (notes, description). Generous for + clinical writing, but bounded — unbounded text lets one request persist + multi-megabyte values that drag every later fetch/render/export." + 10000) + +(def max-change-batch + "Most change events accepted in one /changes request. A real editing + session syncs tens of changes; thousands in one transaction is abuse + (lock contention, memory) — reject before any DB work." + 500) + (def relationship-type-order "Relationship types in canonical display order. Menus render from this vector rather than relying on map ordering." diff --git a/src/main/aps/parts/common/models/part.cljc b/src/main/aps/parts/common/models/part.cljc index 6eb1d388..7e5b3b04 100644 --- a/src/main/aps/parts/common/models/part.cljc +++ b/src/main/aps/parts/common/models/part.cljc @@ -1,6 +1,7 @@ (ns aps.parts.common.models.part (:require - [aps.parts.common.constants :refer [part-labels part-max-size + [aps.parts.common.constants :refer [max-label-length max-text-length + part-labels part-max-size part-min-size part-types]] [aps.parts.common.observe :as o] [aps.parts.common.utils :refer [validate-spec]] @@ -9,13 +10,13 @@ (s/def ::id (s/or :string string? :uuid uuid?)) (s/def ::map_id (s/or :string string? :uuid uuid?)) (s/def ::type part-types) -(s/def ::label string?) -(s/def ::description (s/nilable string?)) +(s/def ::label (s/and string? #(<= (count %) max-label-length))) +(s/def ::description (s/nilable (s/and string? #(<= (count %) max-text-length)))) (s/def ::position_x int?) (s/def ::position_y int?) (s/def ::width (s/nilable (s/and int? #(<= part-min-size % part-max-size)))) (s/def ::height (s/nilable (s/and int? #(<= part-min-size % part-max-size)))) -(s/def ::notes (s/nilable string?)) +(s/def ::notes (s/nilable (s/and string? #(<= (count %) max-text-length)))) ;; Body location — where in the client's body a Part is felt (its somatic ;; locus). A structured point on a body silhouette, never free text (see diff --git a/src/main/aps/parts/common/models/relationship.cljc b/src/main/aps/parts/common/models/relationship.cljc index d54f8abf..bbc103b6 100644 --- a/src/main/aps/parts/common/models/relationship.cljc +++ b/src/main/aps/parts/common/models/relationship.cljc @@ -1,6 +1,6 @@ (ns aps.parts.common.models.relationship (:require - [aps.parts.common.constants :refer [relationship-types]] + [aps.parts.common.constants :refer [max-text-length relationship-types]] [aps.parts.common.observe :as o] [aps.parts.common.utils :refer [validate-spec]] [clojure.spec.alpha :as s])) @@ -10,7 +10,7 @@ (s/def ::type #(contains? relationship-types %)) (s/def ::source_id (s/or :string string? :uuid uuid?)) (s/def ::target_id (s/or :string string? :uuid uuid?)) -(s/def ::notes (s/nilable string?)) +(s/def ::notes (s/nilable (s/and string? #(<= (count %) max-text-length)))) (s/def ::intensity (s/and number? #(<= 0 % 100))) (s/def ::relationship diff --git a/src/main/aps/parts/config.clj b/src/main/aps/parts/config.clj index 3030a037..9c3909c5 100644 --- a/src/main/aps/parts/config.clj +++ b/src/main/aps/parts/config.clj @@ -156,37 +156,68 @@ ":" (http-port))) +(defn assert-db-topology! + "Fail fast on the one combination that silently ships credentials and PII + in cleartext: production, TLS off, and a non-loopback DB host. Loopback + without TLS is the deliberate deployment shape (postgres shares the app's + box); the moment :db/host points elsewhere, PARTS__DB__SSL must be true." + [{:keys [host ssl prod?]}] + (when (and prod? + (not ssl) + (not (contains? #{nil "localhost" "127.0.0.1" "::1"} host))) + (throw (ex-info "Refusing cleartext postgres connection to a remote host in prod; set PARTS__DB__SSL=true" + {:type :config :db/host host}))) + true) + (defn database-config "Get complete database configuration map suitable for next.jdbc." [] - {:dbtype "postgresql" - :host (l-config/get config :db/host) - :port (l-config/get config :db/port) - :dbname (l-config/get config :db/name) - :user (l-config/get config :db/user) - :password (l-config/get config :db/password) - :ssl (l-config/get config :db/ssl)}) - -(def ^:private secret-key-substrings - #{"password" "secret" "token" "key"}) - -(defn- secret-key? - "True if the key's name suggests it holds a secret value that should not - appear in logs (e.g. :db/password, :session/key)." - [k] - (when-let [n (some-> k name cstr/lower-case)] - (boolean (some #(cstr/includes? n %) secret-key-substrings)))) + (let [host (l-config/get config :db/host) + ssl (parse-bool (l-config/get config :db/ssl))] + (assert-db-topology! {:host host :ssl ssl :prod? (prod?)}) + {:dbtype "postgresql" + :host host + :port (l-config/get config :db/port) + :dbname (l-config/get config :db/name) + :user (l-config/get config :db/user) + :password (l-config/get config :db/password) + :ssl ssl})) + +(defn client-ip-header + "The header carrying the proxy-vouched client IP, lower-cased for Ring + lookup. :ratelimit/client-ip-header (PARTS__RATELIMIT__CLIENT_IP_HEADER), + default \"x-real-ip\" as set by the generated Caddyfiles. Override only if + the trusted edge changes (e.g. a CDN in front of Caddy)." + [] + (-> (or (l-config/get config :ratelimit/client-ip-header) "x-real-ip") + cstr/lower-case)) + +(def ^:private printable-config-keys + "Config keys whose values may appear in the startup table. Everything + else prints : a new key is treated as secret until deliberately + named here, instead of leaking until its name happens to match a + substring heuristic." + #{:env + :db/type :db/host :db/port :db/name :db/user :db/ssl + :http/host :http/port :http/protocol + :app/base-url + :legal/content-dir :render/font-dir + :repl/socket :repl/port :repl/host + :ratelimit/client-ip-header + :launch/launched? + :smtp/host :smtp/port + :alert/to :alert/from}) (defn print-config-table "Print all accessed configuration keys, values, and sources as a table. - Values for keys matching `secret-key?` are redacted." + Values are redacted unless the key is in `printable-config-keys`." [] (let [cached @(:values config) rows (for [[k v] (sort-by key cached)] {:key k - :value (if (secret-key? k) - "" - (pr-str (:val v))) + :value (if (contains? printable-config-keys k) + (pr-str (:val v)) + "") :source (-> (:source v) str (cstr/replace #"^file:" "") diff --git a/src/main/aps/parts/db.clj b/src/main/aps/parts/db.clj index 66fafe12..b40f8850 100644 --- a/src/main/aps/parts/db.clj +++ b/src/main/aps/parts/db.clj @@ -32,6 +32,13 @@ (mulog/log ::initializing-database) (migratus/migrate migration-config)) +(defn migrate! + "`clojure -X:migrate` entry point. Lives here (not in the dev `repl` + namespace) so migrating needs no dev/test dependencies on the classpath + — CI runs it with production deps only." + [_opts] + (init-db)) + (defn ->uuid "Converts a string UUID to a java.util.UUID object if needed. If already a UUID object, returns it unchanged. diff --git a/src/main/aps/parts/db/erasure.clj b/src/main/aps/parts/db/erasure.clj index 4558c188..ee9b1f2e 100644 --- a/src/main/aps/parts/db/erasure.clj +++ b/src/main/aps/parts/db/erasure.clj @@ -69,7 +69,7 @@ [:not= :deletion_requested_at nil] [:= :deletion_completed_at nil] [:< :deletion_requested_at - [:- [:now] [:raw (str "interval '" grace-period-days " days'")]]] + [:- [:now] [:cast (str grace-period-days " days") :interval]]] (exclude-tombstone :id)]}) {:builder-fn rs/as-unqualified-maps}) (map :id))) @@ -80,14 +80,25 @@ Inside one transaction: 1. Set the session actor to the tombstone so audit triggers on the DELETEs below write rows that don't FK-reference the dying user. - 2. Hard-DELETE the user's email-keyed rows in invitations and + 2. Capture the ids of every entity about to be deleted (for step 5's + audit scrub, while the rows still exist). + 3. Hard-DELETE the user's email-keyed rows in invitations and waitlist_signups (resolving the email before the users row goes). - 3. Hard-DELETE relationships / parts / sessions (with their + 4. Hard-DELETE relationships / parts / sessions (with their activation links) / maps owned by the user. - 4. Pseudonymize any historical `audit_log` rows still attributing + 5. Scrub `before_row`/`after_row` from every audit_log row describing + those entities. The DELETEs in step 4 each fire the audit trigger, + writing a fresh full snapshot of the just-erased content, and older + rows hold its entire edit history — GDPR Art. 17 erasure of + special-category health data must remove both. The rows themselves + survive (who/when/what-table) for operational accountability; + scrubbing after the fact covers historical and purge-generated + rows in one statement, which is why capture isn't suppressed + instead. + 6. Pseudonymize any historical `audit_log` rows still attributing pre-deletion activity to this user — they survive but are anonymous. - 5. Mark `deletion_completed_at` (sentinel for log correlation). - 6. Hard-DELETE the user row. + 7. Mark `deletion_completed_at` (sentinel for log correlation). + 8. Hard-DELETE the user row. For the v1 owner-only model, every part/relationship in a user's map was authored by that same user, so the pseudonymization in step 3 makes @@ -102,7 +113,31 @@ {:type :forbidden :user-id user-id}))) (mulog/log ::purge-account-start :user-id user-id) (jdbc/with-transaction [tx ds] + ;; Assume the erasure-only role for the whole transaction (SET LOCAL + ;; resets at commit/rollback, so the pooled connection comes back + ;; unchanged). The everyday app role holds no DELETE on the temporal + ;; tables (migration 20260726000000) — this is the one deliberate + ;; path that does. + (jdbc/execute! tx ["SET LOCAL ROLE deletion_role"]) (bt/set-actor! tx tombstone-id) + ;; audit_log identifies entities by UUID in row_pk, so ids alone pin + ;; down the rows to scrub — immune to table renames in table_name. + (jdbc/execute! tx + ["CREATE TEMP TABLE purge_audit_targets ON COMMIT DROP AS + SELECT id::text AS row_id FROM maps WHERE owner_id = ? + UNION + SELECT id::text FROM map_metadata + WHERE map_id IN (SELECT id FROM maps WHERE owner_id = ?) + UNION + SELECT id::text FROM parts + WHERE map_id IN (SELECT id FROM maps WHERE owner_id = ?) + UNION + SELECT id::text FROM relationships + WHERE map_id IN (SELECT id FROM maps WHERE owner_id = ?) + UNION + SELECT id::text FROM sessions + WHERE map_id IN (SELECT id FROM maps WHERE owner_id = ?)" + user-uuid user-uuid user-uuid user-uuid user-uuid]) ;; Resolve the email before the users row is deleted: invitations and ;; waitlist_signups are keyed by email, not user-id. (let [email (:email (jdbc/execute-one! @@ -136,6 +171,13 @@ user-uuid]) (jdbc/execute! tx ["DELETE FROM maps WHERE owner_id = ?" user-uuid]) + (jdbc/execute! tx + ["UPDATE audit_log a + SET before_row = NULL, after_row = NULL + FROM purge_audit_targets t + WHERE a.row_pk->>'id' = t.row_id + AND (a.before_row IS NOT NULL + OR a.after_row IS NOT NULL)"]) (db/update! :audit_log {:actor_id [:cast (str tombstone-id) :uuid]} [:= :actor_id user-uuid] diff --git a/src/main/aps/parts/errors.clj b/src/main/aps/parts/errors.clj index 89740e0e..041caf81 100644 --- a/src/main/aps/parts/errors.clj +++ b/src/main/aps/parts/errors.clj @@ -22,7 +22,9 @@ (def postgres-sql-state-errors "A map of PostgreSQL SQL state codes to user-friendly error messages." - {"23505" "A resource with this unique identifier already exists" ; unique violation + ;; Deliberately vague on unique violations: naming the cause ("this id + ;; already exists") would let client-chosen ids probe for existence. + {"23505" "The change conflicts with existing data" ; unique violation "23514" "The provided data does not meet the required constraints" ; check constraint "23502" "A required field was missing" ; not null violation "23503" "The referenced resource does not exist"}) ; foreign key violation @@ -88,6 +90,10 @@ :not-found (exception-handler "Resource not found" 404) + ;; db/->uuid on a malformed id — client input, not a server fault. + :invalid-uuid + (exception-handler "Invalid identifier" 400) + ;; Optimistic-lock failure in the bitemporal write path: the entity was ;; superseded by a concurrent change between read and write. :conflict @@ -118,11 +124,12 @@ PSQLException postgres-constraint-violation-handler - ;; Default + ;; Default. Logs class only, like the PSQL/batch handlers: an + ;; exception message can interpolate input values, and this event + ;; feeds the operator alert email. ::exception/default (fn [^Exception e _request] (mulog/log ::unhandled-exception - :error (.getMessage e) :error-class (.getName (class e))) {:status 500 :body {:error "Internal server error"}})}))) diff --git a/src/main/aps/parts/export.clj b/src/main/aps/parts/export.clj index aceb2bcd..5240671f 100644 --- a/src/main/aps/parts/export.clj +++ b/src/main/aps/parts/export.clj @@ -20,15 +20,32 @@ detect the format (ADR-0010)." "1") +(def ^:private exported-columns + "Per-entity allowlists of exported keys (ADR-0010 data minimization). A + column added to one of these tables is NOT exported until deliberately + named here — so controller metadata and any future internal/sensitive + field stay out by default, rather than leaking on the day the column + lands. The export's REQUIRED clinical fields (notes, body_location, + trigger) are all present." + {:parts [:type :label :description :notes :position_x :position_y + :width :height :body_location :valid_from :valid_to] + :relationships [:type :source_id :target_id :notes :intensity + :valid_from :valid_to] + :map-metadata [:title :valid_from :valid_to] + :sessions [:id :ordinal :trigger :anchor_valid_at :activated_part_id]}) + +(defn- project + [entity row] + (select-keys row (exported-columns entity))) + (defn- by-entity "Group history versions by entity id into `[{:id … :versions […]}]`, earliest - entity first. Drops the now-redundant `:id` (the group key) and `:map_id` - (the whole export is scoped to one Map) from each version." - [versions] + entity first. Each version is projected through `exported-columns`." + [entity versions] (->> versions (group-by :id) (map (fn [[id vs]] - {:id id :versions (mapv #(dissoc % :id :map_id) vs)})) + {:id id :versions (mapv #(project entity %) vs)})) (sort-by (comp :valid_from first :versions)) vec)) @@ -51,11 +68,11 @@ :exported_at (OffsetDateTime/now) :map (assoc (map-identity ds mid) :title_history - (mapv #(dissoc % :id :map_id) + (mapv #(project :map-metadata %) (bt/history ds :map_metadata [:= :map_id mid]))) - :parts (by-entity (bt/history ds :parts [:= :map_id mid])) - :relationships (by-entity (bt/history ds :relationships [:= :map_id mid])) + :parts (by-entity :parts (bt/history ds :parts [:= :map_id mid])) + :relationships (by-entity :relationships + (bt/history ds :relationships [:= :map_id mid])) ;; Sessions are non-temporal (ADR-0014): each exports once, - ;; unversioned — the anchor instant is its valid-time place. Full - ;; rows, so a future Session column exports by default. - :sessions (mapv #(dissoc % :map_id) (session/index ds mid))})) + ;; unversioned — the anchor instant is its valid-time place. + :sessions (mapv #(project :sessions %) (session/index ds mid))})) diff --git a/src/main/aps/parts/frontend/api/queue.cljs b/src/main/aps/parts/frontend/api/queue.cljs index 8ffc930a..3d14beac 100644 --- a/src/main/aps/parts/frontend/api/queue.cljs +++ b/src/main/aps/parts/frontend/api/queue.cljs @@ -59,7 +59,11 @@ (when-let [backend (storage-registry/get-backend)] (rf/dispatch [:save-status/flush-started]) (let [response ( (get-in request [:form-params "email"]) normalize-email)] (cond (or (nil? email) (str/blank? email)) (-> (response/response @@ -37,14 +41,12 @@ (try (db/insert! :waitlist_signups {:email email}) (mulog/log ::waitlist_signup :email email) + ;; No inline script (CSP): marketing.js sees the swapped-in + ;; data-counter-increment and bumps the visible counter. (-> (response/response - (html [:div.success + (html [:div.success {:data-counter-increment "true"} [:div {:class "text-6xl mb-2"} "🎉"] - [:p "Thank you for your interest in Parts! We'll be in touch soon."] - [:script (raw-string - "const element = document.getElementById('counter'); - const currentValue = parseInt(element.textContent) || 0; - element.textContent = currentValue + 1;")]])) + [:p "Thank you for your interest in Parts! We'll be in touch soon."]])) (response/status 201)) (catch Exception _e (-> (response/response diff --git a/src/main/aps/parts/invitations.clj b/src/main/aps/parts/invitations.clj index da5aa478..a5a5d609 100644 --- a/src/main/aps/parts/invitations.clj +++ b/src/main/aps/parts/invitations.clj @@ -5,7 +5,9 @@ An invitation is an operator-minted, single-use bearer credential: the `token` in a magic link (`/invite/`) authorises creating one account. Lifecycle: issued -> redeemed | revoked (soft, via - `revoked_at`). No expiry. See CONTEXT.md (Invitation, Founding Circle). + `revoked_at`) | expired (30 days, `expires_at` — a bearer credential + must not stay live forever). See CONTEXT.md (Invitation, Founding + Circle). Operator workflow (production REPL, Path beta — links are BCC'd from the operator's own mail client): @@ -42,9 +44,12 @@ (def ^:private active-clause "HoneySQL `where` fragment for an invitation that is still live — neither - redeemed nor revoked. HoneySQL flattens nested `:and`, so it composes - inside a larger `[:and ...]`." - [:and [:is :redeemed_at nil] [:is :revoked_at nil]]) + redeemed, revoked, nor expired. HoneySQL flattens nested `:and`, so it + composes inside a larger `[:and ...]`." + [:and + [:is :redeemed_at nil] + [:is :revoked_at nil] + [:> :expires_at [:now]]]) (defn find-active "The active (un-redeemed, un-revoked) invitation row for `token`, or nil. diff --git a/src/main/aps/parts/jobs/session_cleanup.clj b/src/main/aps/parts/jobs/session_cleanup.clj new file mode 100644 index 00000000..7ac90b61 --- /dev/null +++ b/src/main/aps/parts/jobs/session_cleanup.clj @@ -0,0 +1,33 @@ +(ns aps.parts.jobs.session-cleanup + "Hourly sweep of expired rows in auth_sessions. Correctness never depends + on it (the store's reads filter on expires_at) — it only stops dead + sessions accumulating. Mirrors the deletion-purge job's async pattern." + (:require + [aps.parts.auth.session-store :as session-store] + [aps.parts.db :as db] + [clojure.core.async :as async] + [com.brunobonacci.mulog :as mulog])) + +(def ^:private interval-ms (* 60 60 1000)) + +(defn schedule! + "Start the cleanup loop. Returns a stop channel; close it to halt." + [] + (let [stop-ch (async/chan) + tick (fn [] + (try + (let [n (session-store/delete-expired! db/datasource)] + (when (pos? n) + (mulog/log ::sessions-swept :removed n))) + (catch Exception e + (mulog/log ::sweep-error + :error (.getMessage e) + :error-type (.getName (class e))))))] + (tick) + (async/go-loop [] + (let [timeout-ch (async/timeout interval-ms) + [_ ch] (async/alts! [stop-ch timeout-ch])] + (when (not= ch stop-ch) + (tick) + (recur)))) + stop-ch)) diff --git a/src/main/aps/parts/legal.clj b/src/main/aps/parts/legal.clj index 65df26cd..b5bef4d9 100644 --- a/src/main/aps/parts/legal.clj +++ b/src/main/aps/parts/legal.clj @@ -60,11 +60,14 @@ (defn pdf-file "java.io.File for the operator's `.pdf` in the content dir if present, else nil. PDFs are operator artifacts only — there is no bundled-example - fallback, so a fresh self-host has no PDF and the download link is hidden." + fallback, so a fresh self-host has no PDF and the download link is hidden. + The slug is checked against the document allowlist here, not only at the + call sites, so no future caller can turn it into a path probe." [slug] - (let [dir (conf/legal-content-dir) - file (when dir (io/file dir (str slug ".pdf")))] - (when (and file (.exists ^File file)) file))) + (when (contains? documents slug) + (let [dir (conf/legal-content-dir) + file (when dir (io/file dir (str slug ".pdf")))] + (when (and file (.exists ^File file)) file)))) (defn document "The loaded legal document for `slug`, or nil if the slug is unknown or no diff --git a/src/main/aps/parts/middleware.clj b/src/main/aps/parts/middleware.clj index a5c4ff53..68adc358 100644 --- a/src/main/aps/parts/middleware.clj +++ b/src/main/aps/parts/middleware.clj @@ -110,6 +110,24 @@ (fn [request] (assoc-in (handler request) [:headers "Content-Security-Policy"] policy)))) +(defn- public-content-security-policy + "CSP for the public pages (marketing, legal, playground): 'self' plus the + Plausible collector — no inline script; handlers are wired through data + attributes in /js/marketing.js. Lower stakes than the authed surfaces + (no auth cookie, no /api mutation) — this is defense-in-depth against + reflected/stored XSS." + [prod?] + (str "script-src 'self' https://plausible.io" + (when-not prod? " 'unsafe-eval'") + "; frame-ancestors 'none'")) + +(defn wrap-public-csp + "Set the public-page Content-Security-Policy on the wrapped routes." + [handler] + (let [policy (public-content-security-policy (conf/prod?))] + (fn [request] + (assoc-in (handler request) [:headers "Content-Security-Policy"] policy)))) + (defn wrap-core-middlewares "Apply essential Ring middleware for the entire application. - `wrap-resource`: Serves static files from resources/public diff --git a/src/main/aps/parts/ops.clj b/src/main/aps/parts/ops.clj index c7cc47b6..1712155f 100644 --- a/src/main/aps/parts/ops.clj +++ b/src/main/aps/parts/ops.clj @@ -99,11 +99,22 @@ Gosha -- https://gosha.net") +(defn- valid-recipient? + "One well-formed address, bounded, with no whitespace/control characters — + validated here so the message core is safe regardless of which caller + supplies the address." + [email] + (and (string? email) + (<= (count email) 254) + (some? (re-matches #"[^@\s\p{Cntrl}]+@[^@\s\p{Cntrl}]+\.[^@\s\p{Cntrl}]+" email)))) + (defn invite-message "The postal message map for an invite — the pure, testable core of `send-invitation-email!`. Plain text; the invite's magic link fills the [LINK] placeholder in the body." [{:keys [email magic-link]}] + (when-not (valid-recipient? email) + (throw (ex-info "Invalid invite recipient address" {:type :validation}))) {:from invite-from :to email :subject invite-subject diff --git a/src/main/aps/parts/ratelimit.clj b/src/main/aps/parts/ratelimit.clj index fee4bf48..2c47cd28 100644 --- a/src/main/aps/parts/ratelimit.clj +++ b/src/main/aps/parts/ratelimit.clj @@ -1,28 +1,32 @@ (ns aps.parts.ratelimit - "In-process per-IP rate limiting for the unauthenticated, abuse-prone - endpoints (login, register, invite redemption). + "In-process rate limiting: per client IP on the unauthenticated, + abuse-prone endpoints (login, register, invite redemption), per user id + on the authenticated write endpoints (map creation, change batches). - A token bucket per [route-key, client-ip]: `capacity` is the burst a single + A token bucket per [route-key, identity]: `capacity` is the burst a single client may make back-to-back, then requests are allowed at `refill-per-ms`. State lives in a module-level atom on purpose — the reitit router is rebuilt per request (see aps.parts.server), so state held in a middleware instance would reset every request and limit nothing. - Single-server, in-memory, no external store. Behind Caddy the client IP is - read from X-Forwarded-For; the app binds to localhost, so only the proxy - reaches it and that header is trustworthy." + Single-server, in-memory, no external store. The client identity is a + single proxy-set header (default X-Real-IP) that the edge proxy overwrites + on every request — never X-Forwarded-For, which is client-appendable and + whose chain length differs per route, so no fixed position in it is + reliably the client. See docs/runbook.md, 'Rate limiting & the trusted + client IP'." (:require + [aps.parts.config :as conf] [clojure.string :as str])) (defonce ^:private buckets (atom {})) (defn- client-ip - [request] - (or (some-> (get-in request [:headers "x-forwarded-for"]) - (str/split #",") - first - str/trim - not-empty) + "The bucketing identity: the proxy-vouched header, else :remote-addr. The + fallback collapses all clients into one bucket — over-throttling, never a + bypass — the safe failure mode if the proxy stops setting the header." + [request header] + (or (some-> (get-in request [:headers header]) str/trim not-empty) (:remote-addr request))) (defn step @@ -43,23 +47,41 @@ :headers {"Content-Type" "text/plain" "Retry-After" "60"} :body "Too many requests. Please slow down and try again shortly."}) -(defn limiter - "Reitit middleware that token-buckets requests per client IP under - `route-key`. opts: - :capacity burst size (default 10) - :refill-per-ms tokens added per millisecond (default 10/60000 = 10/min) - :now-ms clock thunk (default System/currentTimeMillis; for tests) - :store buckets atom (default the shared module atom; for tests)" - [route-key {:keys [capacity refill-per-ms now-ms store] - :or {capacity 10 - refill-per-ms (/ 10.0 60000) - now-ms #(System/currentTimeMillis) - store buckets}}] +(defn- limit-by + "Token-bucket middleware keyed by [route-key (identity-fn request)]. opts: + :capacity burst size (default 10) + :refill-per-ms tokens added per millisecond (default 10/60000 = 10/min) + :now-ms clock thunk (default System/currentTimeMillis; for tests) + :store buckets atom (default the shared module atom; for tests)" + [route-key identity-fn {:keys [capacity refill-per-ms now-ms store] + :or {capacity 10 + refill-per-ms (/ 10.0 60000) + now-ms #(System/currentTimeMillis) + store buckets}}] (fn [handler] (fn [request] - (let [k [route-key (client-ip request)] + (let [k [route-key (identity-fn request)] b (-> (swap! store update k step (now-ms) capacity refill-per-ms) (get k))] (if (:allowed? b) (handler request) too-many-response))))) + +(defn limiter + "Reitit middleware that token-buckets requests per client IP under + `route-key`. opts: see `limit-by`, plus + :client-ip-header trusted client-IP header (default conf/client-ip-header)" + [route-key {:keys [client-ip-header] :as opts}] + (let [header (or client-ip-header (conf/client-ip-header))] + (limit-by route-key #(client-ip % header) opts))) + +(defn user-limiter + "Reitit middleware that token-buckets requests per authenticated user id — + for session-authenticated write routes, where identity (not a possibly + NAT-shared client IP) is the right key. Sits inside require-auth so + :identity is present; if it ever isn't, all such requests share one + bucket — over-throttling, never a bypass. opts: see `limit-by`." + [route-key opts] + (limit-by route-key + (fn [request] (or (get-in request [:identity :sub]) "anonymous")) + opts)) diff --git a/src/main/aps/parts/render/document/labels.clj b/src/main/aps/parts/render/document/labels.clj index 51c01b55..27d6fdeb 100644 --- a/src/main/aps/parts/render/document/labels.clj +++ b/src/main/aps/parts/render/document/labels.clj @@ -60,8 +60,15 @@ (recur (rest words) "" (conj lines word)) (recur words "" (conj lines current)))))))) +(defn- drop-last-code-point + "`s` without its final Unicode code point — never splits a surrogate + pair, which would emit invalid XML and fail the user's own PDF export + on supplementary-plane characters (emoji, rare CJK)." + [^String s] + (subs s 0 (.offsetByCodePoints s (count s) -1))) + (defn- truncate-with-ellipsis - "Shrink `text` one character at a time from the right until + "Shrink `text` one code point at a time from the right until `text + ellipsis` fits within `max-px`." [font text max-px] (loop [s text] @@ -73,7 +80,7 @@ (str s label-ellipsis) :else - (recur (subs s 0 (dec (count s))))))) + (recur (drop-last-code-point s))))) (defn wrap-capped "Greedy word-wrap `text` in `font` into at most `max-lines` lines of diff --git a/src/main/aps/parts/render/pdf.clj b/src/main/aps/parts/render/pdf.clj index 45e3783d..bdcd7f00 100644 --- a/src/main/aps/parts/render/pdf.clj +++ b/src/main/aps/parts/render/pdf.clj @@ -18,7 +18,8 @@ [com.brunobonacci.mulog :as mulog]) (:import (java.io ByteArrayInputStream ByteArrayOutputStream StringReader) - (org.apache.batik.transcoder TranscoderInput TranscoderOutput) + (org.apache.batik.transcoder SVGAbstractTranscoder TranscoderInput + TranscoderOutput) (org.apache.fop.configuration DefaultConfigurationBuilder) (org.apache.fop.svg PDFTranscoder))) @@ -56,7 +57,12 @@ ever makes it matter, the escape hatch is subclassing PDFTranscoder to retain a FontManager across calls." (doto (PDFTranscoder.) - (.configure (fop-configuration)))) + (.configure (fop-configuration)) + ;; Batik denies external resources by default; pin it explicitly so a + ;; library upgrade can't quietly start fetching URLs referenced from + ;; the (user-shaped) SVG. + (.addTranscodingHint SVGAbstractTranscoder/KEY_ALLOW_EXTERNAL_RESOURCES + Boolean/FALSE))) (defn svg->pdf "Transcode an SVG document string to PDF bytes. Returns a `byte[]`. diff --git a/src/main/aps/parts/routes.clj b/src/main/aps/parts/routes.clj index 57ede0ba..5e413f92 100644 --- a/src/main/aps/parts/routes.clj +++ b/src/main/aps/parts/routes.clj @@ -91,12 +91,14 @@ ;; - Proper HTML content-type and string conversion ;; A form is present on the homepage, so we apply CSRF protection - ["/" {:middleware [middleware/wrap-html-defaults + ["/" {:middleware [middleware/wrap-public-csp + middleware/wrap-html-defaults auth-mw/wrap-session-auth middleware/wrap-html-response] :get {:handler pages/home-page}}] - ["/playground" {:middleware [middleware/wrap-html-defaults + ["/playground" {:middleware [middleware/wrap-public-csp + middleware/wrap-html-defaults middleware/wrap-html-response] :get {:handler pages/playground}}] @@ -114,8 +116,14 @@ :get {:handler pages/app-shell}}] ;; Legacy map URLs now live under /app. Redirect existing bookmarks. + ;; The param is validated before it reaches the Location header — no + ;; unvetted client input in a response header. ["/maps/:id" {:get {:handler (fn [{{:keys [id]} :path-params}] - (response/redirect (str "/app/maps/" id)))}}] + (if (parse-uuid id) + (response/redirect (str "/app/maps/" id)) + {:status 400 + :headers {"Content-Type" "text/plain"} + :body "Invalid map id"}))}}] ["/up" {:get {:handler (fn [_] {:status 200 :body "OK"})}}] @@ -138,15 +146,18 @@ ;; Legal documents — Privacy Policy, Terms of Service, DPA. Server-rendered ;; and public (no auth, no launch gate). Content is operator-supplied at ;; runtime (see aps.parts.legal); the repo ships only example templates. - ["/privacy" {:middleware [middleware/wrap-html-defaults + ["/privacy" {:middleware [middleware/wrap-public-csp + middleware/wrap-html-defaults middleware/wrap-html-response]} ["" {:get {:handler (legal/page "privacy")}}] ["/download" {:get {:handler (legal/download "privacy")}}]] - ["/terms" {:middleware [middleware/wrap-html-defaults + ["/terms" {:middleware [middleware/wrap-public-csp + middleware/wrap-html-defaults middleware/wrap-html-response]} ["" {:get {:handler (legal/page "terms")}}] ["/download" {:get {:handler (legal/download "terms")}}]] - ["/dpa" {:middleware [middleware/wrap-html-defaults + ["/dpa" {:middleware [middleware/wrap-public-csp + middleware/wrap-html-defaults middleware/wrap-html-response]} ["" {:get {:handler (legal/page "dpa")}}] ["/download" {:get {:handler (legal/download "dpa")}}]] @@ -175,7 +186,9 @@ ["/login" {:middleware [(ratelimit/limiter :login {})] :post {:handler api.auth/login}}] ["/logout" {:post {:middleware [auth-mw/require-auth] - :handler api.auth/logout}}]] + :handler api.auth/logout}}] + ["/logout-everywhere" {:post {:middleware [auth-mw/require-auth] + :handler api.auth/logout-everywhere}}]] ["/account" ["/register" {:middleware [(ratelimit/limiter :register {}) @@ -187,8 +200,14 @@ :delete {:handler api.account/delete-account}}]] ["/maps" {:middleware [auth-mw/require-auth]} + ;; Write limits are per-user (session identity), far above any real + ;; editing pace: 20 burst + 1/min for map creation, 120 burst + 1/s + ;; sustained for change batches (the SPA debounces at 2s). ["" {:get {:handler api.maps/list-maps} - :post {:handler api.maps/create-map}}] + :post {:middleware [(ratelimit/user-limiter + :create-map + {:capacity 20 :refill-per-ms (/ 1.0 60000)})] + :handler api.maps/create-map}}] ;; This uses coercion for the `parameters`, see the note at the top of this ;; namespace. @@ -202,7 +221,10 @@ ["/render.pdf" {:get {:parameters {:query {(ds/opt :at) string?}} :handler api.maps/render-pdf}}] ["/export.json" {:get {:handler api.maps/export-json}}] - ["/changes" {:post {:handler api.maps/process-changes}}] + ["/changes" {:post {:middleware [(ratelimit/user-limiter + :changes + {:capacity 120 :refill-per-ms (/ 1.0 1000)})] + :handler api.maps/process-changes}}] ["/sessions" ["" {:get {:handler api.sessions/list-sessions} :post {:handler api.sessions/create-session}}] diff --git a/src/main/aps/parts/server.clj b/src/main/aps/parts/server.clj index 7b41f51c..a1635dc0 100644 --- a/src/main/aps/parts/server.clj +++ b/src/main/aps/parts/server.clj @@ -8,6 +8,7 @@ [aps.parts.db :as db] [aps.parts.errors :as errors] [aps.parts.jobs.deletion-purge :as deletion-purge] + [aps.parts.jobs.session-cleanup :as session-cleanup] [aps.parts.middleware :as middleware] [aps.parts.routes :as r] [aps.parts.version :as version] @@ -18,6 +19,9 @@ [org.httpkit.server :as server] [reitit.ring :as ring] [ring.middleware.head :as head]) + (:import + [java.nio.file Files Path] + [java.nio.file.attribute PosixFilePermissions]) (:gen-class)) (defn app @@ -59,7 +63,7 @@ non-prod environments where another mechanism (e.g. the dev tap publisher in src/dev/mulog_events.clj) handles publishing." [] - (when conf/prod? + (when (conf/prod?) (mulog/start-publisher! {:type :console-json :pretty? false :transform observe/mulog-transform}))) @@ -82,37 +86,64 @@ :reason "SMTP not configured (PARTS__SMTP__*)") nil))) +(defn- owner-only! + "Restrict `path` to rw for its owner (0600). nREPL creates the socket with + the process umask, which typically leaves it group/world-connectable." + [path] + (Files/setPosixFilePermissions + (Path/of path (into-array String [])) + (PosixFilePermissions/fromString "rw-------"))) + +(defn- preload-ops! + "Preload the operator console so a connected REPL has it at hand." + [] + (try + (require 'aps.parts.ops) + (catch Exception e + (mulog/log ::ops-preload-failed :error (.getMessage e))))) + (defn start-nrepl - "Starts an nREPL server if enabled via environment configuration. + "Starts the production nREPL on a unix domain socket (:repl/socket), + permissioned 0600 — nREPL has no authentication, so \"may connect\" must + mean filesystem access as the app user, not merely \"is local\" + (a TCP loopback port is connectable by ANY local process). A loopback + TCP REPL remains available as an explicit operator escape hatch via + PARTS__REPL__PORT, which prod.edn deliberately does not set. Returns the server instance or nil if disabled." [] - (when conf/prod? - (when-let [repl-port (l-config/get conf/config :repl/port)] - (try - (let [port (Integer/parseInt repl-port) - bind-address (or (l-config/get conf/config :repl/host) "127.0.0.1") - server (nrepl/start-server :bind bind-address :port port)] - (mulog/log ::nrepl-started :port port :bind bind-address) - (println (format "nREPL server started on %s:%d" bind-address port)) - ;; Preload the operator console - (try - (require 'aps.parts.ops) - (catch Exception e - (mulog/log ::ops-preload-failed :error (.getMessage e)))) + (when (conf/prod?) + (try + (if-let [socket-path (l-config/get conf/config :repl/socket)] + (let [server (nrepl/start-server :socket socket-path)] + (owner-only! socket-path) + (mulog/log ::nrepl-started :socket socket-path) + (println (format "nREPL server started on unix socket %s" socket-path)) + (preload-ops!) server) - (catch Exception e - (mulog/log ::nrepl-start-error - :error (.getMessage e) - :error_type (.getName (class e))) - (println "Failed to start nREPL server:" (.getMessage e)) - nil))))) + (when-let [repl-port (l-config/get conf/config :repl/port)] + (let [port (Integer/parseInt repl-port) + bind-address (or (l-config/get conf/config :repl/host) "127.0.0.1") + server (nrepl/start-server :bind bind-address :port port)] + (mulog/log ::nrepl-started :port port :bind bind-address) + (println (format "nREPL server started on %s:%d" bind-address port)) + (preload-ops!) + server))) + (catch Exception e + (mulog/log ::nrepl-start-error + :error (.getMessage e) + :error_type (.getName (class e))) + (println "Failed to start nREPL server:" (.getMessage e)) + nil)))) (defn start-server "Starts the web server with the configured application handler. Returns a function that can be called to stop the server." [port] (mulog/log ::starting-server :port port) - (server/run-server (app) {:port port})) + ;; Explicit request-size ceiling: a full change-batch (max-change-batch + ;; changes with max-text-length notes) is ~5 MB of transit; 8 MB leaves + ;; headroom without letting one request buffer arbitrary bytes. + (server/run-server (app) {:port port :max-body (* 8 1024 1024)})) (defn -main "Entry point into the application via clojure.main -M. @@ -131,16 +162,13 @@ ;; Initialize database (db/init-db) - ;; Fail fast on a missing/misconfigured session key — never run on a - ;; guessable secret (ADR-0007). - (conf/session-key) - ;; Start nREPL server if configured (let [stop-alert-pub (start-alert-publisher) nrepl-server (start-nrepl) ;; Start server and background processes stop-fn (start-server port) - deletion-stop-ch (deletion-purge/schedule!)] + deletion-stop-ch (deletion-purge/schedule!) + sessions-stop-ch (session-cleanup/schedule!)] (println "Parts: Server started on port" port) ;; Print configuration on startup @@ -151,6 +179,7 @@ (fn [] (stop-fn) (async/close! deletion-stop-ch) + (async/close! sessions-stop-ch) (when nrepl-server (nrepl/stop-server nrepl-server) (println "nREPL server stopped")) diff --git a/src/main/aps/parts/stats.clj b/src/main/aps/parts/stats.clj index 03e93ae8..f281e67b 100644 --- a/src/main/aps/parts/stats.clj +++ b/src/main/aps/parts/stats.clj @@ -168,7 +168,7 @@ {:select [[[:count [:distinct :actor_id]] :c]] :from [:audit_log] :where [:and - [:>= :occurred_at [:- [:now] [:raw (str "interval '" interval "'")]]] + [:>= :occurred_at [:- [:now] [:cast interval :interval]]] (erasure/exclude-tombstone :actor_id)]})) :c)) diff --git a/src/main/aps/parts/views/partials.clj b/src/main/aps/parts/views/partials.clj index 06902e26..8a25e50e 100644 --- a/src/main/aps/parts/views/partials.clj +++ b/src/main/aps/parts/views/partials.clj @@ -40,11 +40,16 @@ (for [href (or styles [])] [:link {:rel "stylesheet" :href href}]) (when analytics? + ;; No inline script: the plausible queue bootstrap and the + ;; data-attribute event wiring live in marketing.js, so these pages + ;; hold a CSP without 'unsafe-inline' (TASK-069). (list [:script {:defer true :data-domain (conf/app-domain) :src "https://plausible.io/js/script.outbound-links.tagged-events.js"}] - [:script "window.plausible = window.plausible || function() { (window.plausible.q = window.plausible.q || []).push(arguments) }"]))])) + ;; Not under /js/ — that whole directory is shadow-cljs build + ;; output (gitignored); this file is a tracked static asset. + [:script {:src "/marketing.js" :defer true}]))])) (defn header-signup "Post-launch site header: Log in + Create an account buttons." @@ -66,9 +71,10 @@ :href "/app/login"} "Log in"] [:a - {:class "btn btn-primary" - :href "/app/signup" - :onclick "plausible('Create Account Click', {props: {source: 'homepage-header'}}); return true;"} + {:class "btn btn-primary" + :href "/app/signup" + :data-analytics "Create Account Click" + :data-analytics-source "homepage-header"} "Create an account"]]]]]) (defn header-waitlist @@ -88,14 +94,16 @@ :src "/images/parts-logo-horizontal.svg"}]] [:div {:class "flex items-center space-x-4"} [:a - {:href "#signup", - :class "text-ifs-green font-semibold hover:underline" - :onclick "plausible('Join Founding Circle Click', {props: {source: 'homepage'}}); return true;"} + {:href "#signup", + :class "text-ifs-green font-semibold hover:underline" + :data-analytics "Join Founding Circle Click" + :data-analytics-source "homepage"} "Join Founding Circle"] [:a - {:href "/app/login" - :class "btn btn-soft" - :onclick "plausible('Login Click', {props: {source: 'homepage'}}); return true;"} + {:href "/app/login" + :class "btn btn-soft" + :data-analytics "Login Click" + :data-analytics-source "homepage"} "Log in"]]]]]) (defn header @@ -201,18 +209,22 @@ [{:keys [message value]}] [:div#signup-form [:form - {:hx-post "/waitlist-signup" - :hx-target "#signup-form" - :hx-swap "outerHTML" - :hx-on:submit "plausible('Waitlist Signup', {props: {source: 'homepage'}}); return true;"} + {:hx-post "/waitlist-signup" + :hx-target "#signup-form" + :hx-swap "outerHTML" + :data-analytics "Waitlist Signup" + :data-analytics-on "submit" + :data-analytics-source "homepage"} [:div.join.rounded-xl [:input.join-item.input.input-xl.text-gray-800 - {:type "email" - :id "email" - :name "email" - :placeholder "self@you.com" - :value value - :hx-on:focus "plausible('Email Field Focus', {props: {source: 'homepage'}}); return true;"}] + {:type "email" + :id "email" + :name "email" + :placeholder "self@you.com" + :value value + :data-analytics "Email Field Focus" + :data-analytics-on "focus" + :data-analytics-source "homepage"}] [:input {:type "hidden" :id "__anti-forgery-token" :name "__anti-forgery-token" @@ -294,10 +306,14 @@ :required true}] [:span {:class "text-sm text-left"} "I have read and agree to the " + ;; noreferrer: this form renders on the invite page, whose URL carries + ;; the invite token — the legal pages load analytics, and a default + ;; same-origin Referer would hand them the token. (interpose ", " (for [{:keys [slug label]} c/legal-documents] [:a {:href (str "/" slug) - :target "_blank"} + :target "_blank" + :rel "noreferrer noopener"} label])) "."]] [:button {:class "btn btn-primary w-full" :type "submit"} diff --git a/test/aps/parts/api/account_test.clj b/test/aps/parts/api/account_test.clj index f6fa9974..c4bb4526 100644 --- a/test/aps/parts/api/account_test.clj +++ b/test/aps/parts/api/account_test.clj @@ -37,10 +37,13 @@ (deftest test-update-account (testing "correctly updates the user data" - (let [user (create-test-user!) + (let [pw "correct horse battery" + user (create-test-user! {:password pw + :password_confirmation pw}) mock-request {:identity {:sub (:id user)} - :body-params {:email (str "added" (:email user)) - :display_name "Updated"}} + :body-params {:email (str "added" (:email user)) + :display_name "Updated" + :current_password pw}} response (account/update-account mock-request) updated-fields (select-keys (:body response) [:email :display_name])] (is (= 200 (:status response))) @@ -56,6 +59,60 @@ (is (thrown-with-msg? clojure.lang.ExceptionInfo #"Nothing to update" (account/update-account mock-request)))))) +(deftest test-update-account-credential-reauth + (let [pw "correct horse battery" + mk-user #(create-test-user! {:password pw :password_confirmation pw}) + req (fn [user body] {:identity {:sub (:id user)} :body-params body})] + + (testing "password change without the current password is rejected" + (let [user (mk-user)] + (is (thrown-with-msg? clojure.lang.ExceptionInfo #"Current password is incorrect" + (account/update-account + (req user {:password "new-password-1" + :password_confirmation "new-password-1"})))))) + + (testing "password change with a wrong current password is rejected" + (let [user (mk-user)] + (is (thrown-with-msg? clojure.lang.ExceptionInfo #"Current password is incorrect" + (account/update-account + (req user {:password "new-password-1" + :password_confirmation "new-password-1" + :current_password "not the password"})))))) + + (testing "password change with the correct current password rotates the credential" + (let [user (mk-user) + new-pw "brand new password 9" + response (account/update-account + (req user {:password new-pw + :password_confirmation new-pw + :current_password pw}))] + (is (= 200 (:status response))) + (is (some? (auth/authenticate {:email (:email user) :password new-pw})) + "the new password authenticates") + (is (nil? (auth/authenticate {:email (:email user) :password pw})) + "the old password no longer authenticates"))) + + (testing "email change without the current password is rejected" + (let [user (mk-user)] + (is (thrown-with-msg? clojure.lang.ExceptionInfo #"Current password is incorrect" + (account/update-account + (req user {:email "new@example.com"})))))) + + (testing "email change with the correct current password succeeds" + (let [user (mk-user) + response (account/update-account + (req user {:email (str "changed" (:email user)) + :current_password pw}))] + (is (= 200 (:status response))) + (is (= (str "changed" (:email user)) (:email (:body response)))))) + + (testing "display-name-only change needs no current password" + (let [user (mk-user) + response (account/update-account + (req user {:display_name "Just A Rename"}))] + (is (= 200 (:status response))) + (is (= "Just A Rename" (:display_name (:body response)))))))) + (deftest test-delete-account (testing "does not delete without a confirmation param" (let [user (create-test-user!) diff --git a/test/aps/parts/api/maps_test.clj b/test/aps/parts/api/maps_test.clj index 6650c93d..dcf10d9c 100644 --- a/test/aps/parts/api/maps_test.clj +++ b/test/aps/parts/api/maps_test.clj @@ -2,6 +2,7 @@ (:require [aps.parts.api.maps :as api] [aps.parts.api.maps-events :as events] + [aps.parts.common.constants :as constants] [aps.parts.db :as db] [aps.parts.entity.map :as parts-map] [aps.parts.entity.part :as part] @@ -191,6 +192,56 @@ (testing "the valid earlier change was never applied" (is (= "Original" (:label (part/fetch part-id)))))))) +(deftest test-batch-size-and-text-length-bounds + (testing "a batch over max-change-batch is rejected before any DB work" + (let [user (create-test-user!) + the-map (parts-map/create! {:title "Bounds Test" :owner_id (:id user)} (:id user)) + batch (vec (repeat (inc constants/max-change-batch) + {:entity "part" :type "update" + :id (random-uuid) :data {:label "x"}}))] + (try + (events/apply-changes! db/datasource + {:map-id (:id the-map) + :actor-id (:id user) + :changes batch}) + (is false "expected apply-changes! to throw") + (catch clojure.lang.ExceptionInfo e + (is (= :validation (:type (ex-data e)))) + (is (= (inc constants/max-change-batch) (:count (ex-data e)))))))) + + (testing "an over-length text field is rejected at the spec gate" + (let [user (create-test-user!) + the-map (parts-map/create! {:title "Long Text" :owner_id (:id user)} (:id user)) + batch [{:entity "part" :type "create" + :id (random-uuid) + :data {:type "manager" + :label "Ok" + :notes (apply str (repeat (inc constants/max-text-length) "a")) + :position_x 0 + :position_y 0}}]] + (is (thrown? clojure.lang.ExceptionInfo + (events/apply-changes! db/datasource + {:map-id (:id the-map) + :actor-id (:id user) + :changes batch}))))) + + (testing "a normal-sized batch with normal text still succeeds" + (let [user (create-test-user!) + the-map (parts-map/create! {:title "Normal" :owner_id (:id user)} (:id user)) + results (events/apply-changes! + db/datasource + {:map-id (:id the-map) + :actor-id (:id user) + :changes [{:entity "part" :type "create" + :id (random-uuid) + :data {:type "manager" + :label "Reasonable" + :notes "A normal note." + :position_x 0 + :position_y 0}}]})] + (is (= 1 (count results))) + (is (every? :success results))))) + (deftest test-batch-accepts-repeated-updates-to-one-entity ;; Regression for the live 422: the 2s debounce queue legitimately batches ;; two commits to one Part (move + move, move + resize). The bitemporal @@ -317,10 +368,13 @@ at-tip (api/render-pdf (make-request user :params {:id map-id})) length #(Long/parseLong (get-in % [:headers "Content-Length"]))] - (testing "?at= renders the Map as of that Session — less - content than the tip, so a smaller PDF" + ;; Content is asserted on the SVG the PDF transcodes (below): compressed + ;; PDF sizes are not monotonic in content — the embedded render date + ;; alone shifts them a few bytes either way. + (testing "?at= renders the Map as of that Session" (is (= 200 (:status at-s1))) - (is (< (length at-s1) (length at-tip)))) + (is (pos? (length at-s1))) + (is (pos? (length at-tip)))) (testing "the filename names the Session, so exporting several Sessions doesn't overwrite one file" @@ -329,26 +383,26 @@ (is (str/includes? (get-in at-tip [:headers "Content-Disposition"]) "Time travel.pdf"))) - (testing "?at at the latest Session is the live view — more content - than S1 (the header differs from the tip render by design: - Session subtitle + the Session's date)" + (testing "?at at the latest Session is the live view (the header differs + from the tip render by design: Session subtitle + date)" (let [at-s2 (api/render-pdf (make-request user :params {:id map-id} :query {:at (str (:id s2))}))] (is (= 200 (:status at-s2))) - (is (> (length at-s2) (length at-s1))) (is (str/includes? (get-in at-s2 [:headers "Content-Disposition"]) "Time travel - Session 2.pdf")))) (testing "the rendered document is structure-only: as-of content excludes later Parts, and no Session data — trigger text, badge ordinals — can reach it (AC #6)" - (let [svg (document/render - (parts-map/fetch map-id - (session/as-of-instant map-id (str (:id s1)))))] + (let [svg (document/render + (parts-map/fetch map-id + (session/as-of-instant map-id (str (:id s1))))) + svg-tip (document/render (parts-map/fetch map-id))] (is (str/includes? svg "In S1")) (is (not (str/includes? svg "In S2"))) - (is (not (str/includes? svg "SENSITIVE-TRIGGER"))))) + (is (not (str/includes? svg "SENSITIVE-TRIGGER"))) + (is (str/includes? svg-tip "In S2") "the tip render has the later Part"))) (testing "the Maps-list thumbnail always renders the tip — the preview route takes no ?at by design" diff --git a/test/aps/parts/architecture_test.clj b/test/aps/parts/architecture_test.clj index ca1ebe19..3ae6d4a0 100644 --- a/test/aps/parts/architecture_test.clj +++ b/test/aps/parts/architecture_test.clj @@ -77,6 +77,17 @@ (is (re-find (re-pattern (str "\\.edge-" (name type) "\\s*\\{")) css) (str "main.css lacks an .edge-" (name type) " selector")))))) +(deftest raw-sql-is-banned + (testing + "HoneySQL [:raw ...] splices strings straight into SQL, bypassing + parameter binding — one request-tainted argument away from injection. + Bind values instead (e.g. [:cast x :interval] for interval arithmetic)" + (let [patterns [#"\[:raw\b"] + offenders (offending-files patterns [])] + (is (empty? offenders) + (str "These files use [:raw ...]; bind parameters instead:\n " + (str/join "\n " offenders)))))) + (def ^:private delete-quarantine "Which namespaces may hard-delete rows from which tables. Every delete spelling — raw SQL, `db/delete!`, a hand-built `:delete-from` map — is diff --git a/test/aps/parts/auth/session_store_test.clj b/test/aps/parts/auth/session_store_test.clj new file mode 100644 index 00000000..b7195e50 --- /dev/null +++ b/test/aps/parts/auth/session_store_test.clj @@ -0,0 +1,93 @@ +(ns aps.parts.auth.session-store-test + (:require + [aps.parts.auth.session-store :as ss] + [aps.parts.db :as db] + [aps.parts.helpers.utils :refer [create-test-user! with-test-db]] + [clojure.test :refer [deftest is testing use-fixtures]] + [next.jdbc :as jdbc] + [next.jdbc.result-set :as rs] + [ring.middleware.session.store :as store])) + +(use-fixtures :once with-test-db) + +(def ^:private day (* 24 60 60)) + +(deftest test-roundtrip + (let [s (ss/db-store db/datasource day) + user (create-test-user!) + data {:identity {:sub (str (:id user))} + :ring.middleware.anti-forgery/anti-forgery-token "tok-123"} + key (store/write-session s nil data)] + (testing "write mints an opaque id and read returns the exact map back" + (is (uuid? (parse-uuid key))) + (is (= data (store/read-session s key)))) + (testing "a rewrite under the same key updates the data" + (store/write-session s key (assoc data :extra 1)) + (is (= 1 (:extra (store/read-session s key))))) + (testing "delete revokes server-side; the old key reads as no session" + (is (nil? (store/delete-session s key))) + (is (= {} (store/read-session s key)))))) + +(deftest test-garbage-keys-read-as-no-session + (let [s (ss/db-store db/datasource day)] + (is (= {} (store/read-session s nil))) + (is (= {} (store/read-session s "not-a-uuid"))) + (is (= {} (store/read-session s (str (random-uuid)))) "unknown id"))) + +(deftest test-absolute-expiry + (let [s-dead (ss/db-store db/datasource 0) + s-live (ss/db-store db/datasource day) + key (store/write-session s-dead nil {:x 1})] + (testing "an expired session reads as no session" + (is (= {} (store/read-session s-dead key)))) + (testing "a live write does NOT extend an existing deadline" + (let [k (store/write-session s-live nil {:x 1}) + deadline (fn [] + (:expires_at + (jdbc/execute-one! + db/datasource + ["SELECT expires_at FROM auth_sessions WHERE id = ?" + (parse-uuid k)] + {:builder-fn rs/as-unqualified-maps}))) + before (deadline)] + (store/write-session s-live k {:x 2}) + (is (= before (deadline))))) + (testing "writing to an expired id starts it afresh" + (store/write-session s-live key {:x 2}) + (is (= {:x 2} (store/read-session s-live key)))))) + +(deftest test-revoke-for-user + (let [s (ss/db-store db/datasource day) + alice (create-test-user!) + bob (create-test-user!) + mk (fn [u] (store/write-session s nil {:identity {:sub (str (:id u))}})) + a1 (mk alice) + a2 (mk alice) + b1 (mk bob)] + (is (= 2 (ss/revoke-for-user! db/datasource (:id alice))) + "both of alice's sessions are revoked") + (is (= {} (store/read-session s a1))) + (is (= {} (store/read-session s a2))) + (is (seq (store/read-session s b1)) "bob's session is untouched"))) + +(deftest test-account-deletion-cascades-sessions + (let [s (ss/db-store db/datasource day) + user (create-test-user!) + key (store/write-session s nil {:identity {:sub (str (:id user))}})] + (jdbc/execute! db/datasource + ["DELETE FROM users WHERE id = ?" (db/->uuid (:id user))]) + (is (= {} (store/read-session s key)) + "the users FK cascade removed the session row"))) + +(deftest test-expired-sweep + (let [s-dead (ss/db-store db/datasource 0) + s-live (ss/db-store db/datasource day) + dead (store/write-session s-dead nil {:x 1}) + live (store/write-session s-live nil {:x 1})] + (is (pos? (ss/delete-expired! db/datasource))) + (is (zero? (:c (jdbc/execute-one! + db/datasource + ["SELECT count(*) AS c FROM auth_sessions WHERE id = ?" + (parse-uuid dead)] + {:builder-fn rs/as-unqualified-maps})))) + (is (seq (store/read-session s-live live)) "live sessions survive the sweep"))) diff --git a/test/aps/parts/config_test.clj b/test/aps/parts/config_test.clj index 856ddcb4..99791466 100644 --- a/test/aps/parts/config_test.clj +++ b/test/aps/parts/config_test.clj @@ -17,6 +17,23 @@ (is (true? (config/parse-bool true))) (is (false? (config/parse-bool false))))) +(deftest test-assert-db-topology + (testing "prod + no TLS + remote host is refused" + (is (thrown-with-msg? clojure.lang.ExceptionInfo #"Refusing cleartext" + (config/assert-db-topology! + {:host "db.example.com" :ssl false :prod? true})))) + (testing "prod + loopback without TLS is the deliberate shape — allowed" + (is (true? (config/assert-db-topology! + {:host "localhost" :ssl false :prod? true}))) + (is (true? (config/assert-db-topology! + {:host "127.0.0.1" :ssl false :prod? true})))) + (testing "prod + remote host with TLS is allowed" + (is (true? (config/assert-db-topology! + {:host "db.example.com" :ssl true :prod? true})))) + (testing "outside prod the guard does not apply" + (is (true? (config/assert-db-topology! + {:host "db.example.com" :ssl false :prod? false}))))) + (deftest test-smtp-config (testing "returns nil when SMTP env is unconfigured — alerting stays off by default" (is (nil? (config/smtp-config))))) diff --git a/test/aps/parts/db/deletion_role_test.clj b/test/aps/parts/db/deletion_role_test.clj new file mode 100644 index 00000000..98e3acc1 --- /dev/null +++ b/test/aps/parts/db/deletion_role_test.clj @@ -0,0 +1,102 @@ +(ns aps.parts.db.deletion-role-test + "Fitness tests for the erasure least-privilege wiring. + + The test connection is typically a superuser (CI: postgres), which + bypasses table ACLs — so 'the app role cannot DELETE' can't be asserted + against the real app role here; that holds on prod/staging where the app + role is ordinary (see docs/runbook.md for the live-box check). What these + tests pin down instead: + - deletion_role holds every privilege purge-account! uses, so assuming + the role can never make the purge fail (the erasure tests exercise + the real SET LOCAL ROLE path end-to-end); + - a role WITHOUT those grants is denied DELETE on the temporal tables, + proving no PUBLIC grant quietly undermines the revoke." + (:require + [aps.parts.db :as db] + [aps.parts.helpers.utils :refer [with-test-db]] + [clojure.test :refer [deftest is testing use-fixtures]] + [next.jdbc :as jdbc] + [next.jdbc.result-set :as rs])) + +(use-fixtures :once with-test-db) + +(def ^:private purge-privileges + "Every (table, privilege) pair purge-account! relies on while running as + deletion_role. Extend this WHEN extending the purge — the coverage test + fails when a grant is missing, before a live purge can." + {"parts" ["SELECT" "DELETE"] + "relationships" ["SELECT" "DELETE"] + "maps" ["SELECT" "DELETE"] + "map_metadata" ["SELECT" "DELETE"] + "sessions" ["SELECT" "DELETE"] + "session_activations" ["SELECT" "DELETE"] + "invitations" ["SELECT" "DELETE"] + "waitlist_signups" ["SELECT" "DELETE"] + "policy_acceptances" ["SELECT" "DELETE"] + "users" ["SELECT" "UPDATE" "DELETE"] + "audit_log" ["SELECT" "INSERT" "UPDATE"]}) + +(deftest test-deletion-role-grants-cover-the-purge + (doseq [[table privs] purge-privileges + priv privs] + (testing (str "deletion_role can " priv " " table) + (is (true? (:ok (jdbc/execute-one! + db/datasource + ["SELECT has_table_privilege('deletion_role', ?, ?) AS ok" + table priv] + {:builder-fn rs/as-unqualified-maps})))))) + (testing "the audit trigger's id sequence is usable under the role" + (is (true? (:ok (jdbc/execute-one! + db/datasource + ["SELECT has_sequence_privilege('deletion_role', + 'audit_log_id_seq', + 'USAGE') AS ok"] + {:builder-fn rs/as-unqualified-maps})))))) + +(deftest test-membership-confers-nothing-without-set-role + ;; Caught live on staging: a default (INHERIT TRUE) membership hands the + ;; member every deletion_role privilege passively, silently undoing the + ;; DELETE revoke. Provisioning grants WITH INHERIT FALSE; this probe + ;; mirrors that grant and pins both halves of the wanted semantics. + (jdbc/execute! db/datasource + ["DO $$ BEGIN + IF NOT EXISTS (SELECT 1 FROM pg_roles + WHERE rolname = 'app_shaped_probe') THEN + CREATE ROLE app_shaped_probe NOLOGIN; + END IF; + END $$"]) + (jdbc/execute! db/datasource + ["GRANT deletion_role TO app_shaped_probe WITH INHERIT FALSE"]) + (testing "membership alone does not confer DELETE" + (is (thrown-with-msg? + org.postgresql.util.PSQLException #"permission denied" + (jdbc/with-transaction [tx db/datasource] + (jdbc/execute! tx ["SET LOCAL ROLE app_shaped_probe"]) + (jdbc/execute! tx ["DELETE FROM parts WHERE false"]))))) + (testing "explicitly assuming deletion_role does — the purge's one path + (membership admitting SET ROLE for a non-superuser session is a + server-side property; verified on a live box, not provable from + this superuser test connection)" + (jdbc/with-transaction [tx db/datasource] + (jdbc/execute! tx ["SET LOCAL ROLE deletion_role"]) + (is (zero? (::jdbc/update-count + (jdbc/execute-one! tx ["DELETE FROM parts WHERE false"]))) + "deletion_role's own grants carry the purge")))) + +(deftest test-delete-is-denied-without-the-role + ;; A role holding no grants stands in for the post-revoke app role (the + ;; test connection itself is a superuser and can't be denied anything). + (jdbc/execute! db/datasource + ["DO $$ BEGIN + IF NOT EXISTS (SELECT 1 FROM pg_roles + WHERE rolname = 'no_priv_probe') THEN + CREATE ROLE no_priv_probe NOLOGIN; + END IF; + END $$"]) + (doseq [table ["users" "maps" "map_metadata" "parts" "relationships"]] + (testing (str "an ungranted role cannot DELETE FROM " table) + (is (thrown-with-msg? + org.postgresql.util.PSQLException #"permission denied" + (jdbc/with-transaction [tx db/datasource] + (jdbc/execute! tx ["SET LOCAL ROLE no_priv_probe"]) + (jdbc/execute! tx [(str "DELETE FROM " table)]))))))) diff --git a/test/aps/parts/db/erasure_test.clj b/test/aps/parts/db/erasure_test.clj index 00932290..f1b7e033 100644 --- a/test/aps/parts/db/erasure_test.clj +++ b/test/aps/parts/db/erasure_test.clj @@ -208,6 +208,55 @@ (testing "the audit trail survives, reassigned to the tombstone" (is (pos? (:c tombstone-rows))))))) +(deftest test-purge-scrubs-audit-snapshots + ;; GDPR Art. 17: the audit trail may keep who/when/what-table, but not the + ;; clinical row snapshots — including the fresh before_row copies written + ;; by the purge's own DELETEs firing the audit trigger. + (let [canary "ERASURE-CANARY-7f3a" + user (create-test-user!) + the-map (create-test-map! (:id user) (str "Map " canary)) + actor {:actor-id (:id user)} + part-id (random-uuid)] + (bt/insert! db/datasource :parts + {:id part-id + :map_id (:id the-map) + :type "manager" + :label (str "Part " canary) + :notes (str "Notes about " canary) + :position_x 0 :position_y 0} + actor) + ;; An UPDATE too, so history rows (not only the DELETE snapshot) carry it. + (bt/update! db/datasource :parts part-id + {:notes (str "Edited notes " canary)} + actor) + ;; Session trigger text goes through audit/record!, not the trigger. + (session/update-trigger! (:id (session/create! (:id the-map) (:id user))) + (:id the-map) + (str "Session trigger " canary) + (:id user)) + + (let [snapshot-hits (fn [] + (:c (jdbc/execute-one! + db/datasource + ["SELECT count(*) AS c FROM audit_log + WHERE before_row::text LIKE ? + OR after_row::text LIKE ?" + (str "%" canary "%") (str "%" canary "%")] + {:builder-fn rs/as-unqualified-maps})))] + (is (pos? (snapshot-hits)) "seeding wrote clinical content into audit snapshots") + + (erasure/purge-account! db/datasource (:id user)) + + (testing "no audit snapshot retains the erased user's content" + (is (zero? (snapshot-hits)))) + (testing "the scrubbed audit rows themselves survive" + (is (pos? (:c (jdbc/execute-one! + db/datasource + ["SELECT count(*) AS c FROM audit_log + WHERE row_pk->>'id' = ?" + (str part-id)] + {:builder-fn rs/as-unqualified-maps})))))))) + (deftest test-purge-refuses-to-delete-the-tombstone (testing "guard prevents accidentally wiping the schema's anchor user" (is (thrown-with-msg? diff --git a/test/aps/parts/errors_test.clj b/test/aps/parts/errors_test.clj index 6b23fe58..252f55ac 100644 --- a/test/aps/parts/errors_test.clj +++ b/test/aps/parts/errors_test.clj @@ -41,7 +41,9 @@ request (mock/request :get "/test") response (app request)] (is (= 409 (:status response))) - (is (= {:error "A resource with this unique identifier already exists"} (:body response))))) + ;; Opaque on purpose: naming the cause would let client-chosen ids + ;; probe for existence. + (is (= {:error "The change conflicts with existing data"} (:body response))))) (testing "handles PostgreSQL check constraint violation (23514)" (let [exception (PSQLException. "check constraint failed" PSQLState/CHECK_VIOLATION) diff --git a/test/aps/parts/export_test.clj b/test/aps/parts/export_test.clj index 4a95c76c..17358ede 100644 --- a/test/aps/parts/export_test.clj +++ b/test/aps/parts/export_test.clj @@ -61,6 +61,42 @@ (testing "sessions section is present (empty here)" (is (= [] (:sessions result))))))) +(deftest test-export-projects-by-allowlist + ;; Pins the exported key sets exactly. Projection is select-keys over an + ;; explicit allowlist, so a future column can never auto-export; if that + ;; ever regresses to a dissoc denylist, the new key surfaces here. + (let [user (create-test-user!) + the-map (create-test-map! (:id user)) + part (assoc (part-row (:id the-map)) + :description "desc" + :notes "note" + :width 100 + :height 100 + :body_location {:view "front" :x 0.5 :y 0.5}) + _ (bt/insert! db/datasource :parts part {:actor-id (:id user)}) + rel {:id (random-uuid) + :map_id (db/->uuid (:id the-map)) + :type "protects" + :source_id (:id part) + :target_id (:id part) + :notes "rel note" + :intensity 40} + _ (bt/insert! db/datasource :relationships rel {:actor-id (:id user)}) + s1 (session/create! (:id the-map) (:id user)) + _ (session/update-trigger! (:id s1) (:id the-map) "t" (:id user)) + _ (session/set-activation! (:id s1) (:id the-map) (:id part) (:id user)) + result (export/export-map db/datasource (:id the-map))] + (is (= #{:type :label :description :notes :position_x :position_y + :width :height :body_location :valid_from :valid_to} + (set (keys (first (:versions (first (:parts result)))))))) + (is (= #{:type :source_id :target_id :notes :intensity + :valid_from :valid_to} + (set (keys (first (:versions (first (:relationships result)))))))) + (is (= #{:title :valid_from :valid_to} + (set (keys (first (:title_history (:map result))))))) + (is (= #{:id :ordinal :trigger :anchor_valid_at :activated_part_id} + (set (keys (first (:sessions result)))))))) + (deftest test-export-includes-sessions (testing "the export carries Sessions — ordinal, trigger, anchor — and their activated Part links (GDPR Art. 15/20, ADR-0014)" diff --git a/test/aps/parts/ratelimit_test.clj b/test/aps/parts/ratelimit_test.clj index debe9924..64ed0eac 100644 --- a/test/aps/parts/ratelimit_test.clj +++ b/test/aps/parts/ratelimit_test.clj @@ -34,7 +34,7 @@ (testing "denies with 429 after the burst is exhausted (AC#1/#2)" (let [store (atom {}) handler (mk :login store 0) - req {:headers {"x-forwarded-for" "203.0.113.7"}} + req {:headers {"x-real-ip" "203.0.113.7"}} rs (repeatedly 3 #(handler req))] (is (= [200 200 429] (map :status rs))) (is (= "60" (get-in (last rs) [:headers "Retry-After"]))))) @@ -42,8 +42,8 @@ (testing "buckets are independent per client IP (AC#3 — one user can't lock out another)" (let [store (atom {}) handler (mk :login store 0) - a {:headers {"x-forwarded-for" "198.51.100.1"}} - b {:headers {"x-forwarded-for" "198.51.100.2"}}] + a {:headers {"x-real-ip" "198.51.100.1"}} + b {:headers {"x-real-ip" "198.51.100.2"}}] (dotimes [_ 3] (handler a)) ; exhaust A (is (= 200 (:status (handler b))) "B is unaffected by A's flood"))) @@ -51,12 +51,59 @@ (let [store (atom {}) login (mk :login store 0) reg (mk :register store 0) - req {:headers {"x-forwarded-for" "203.0.113.9"}}] + req {:headers {"x-real-ip" "203.0.113.9"}}] (dotimes [_ 3] (login req)) ; exhaust login (is (= 200 (:status (reg req))) "register has its own bucket"))) - (testing "falls back to remote-addr when X-Forwarded-For is absent" + (testing "falls back to remote-addr when the trusted header is absent" (let [store (atom {}) handler (mk :login store 0) req {:remote-addr "10.0.0.5"}] (is (= [200 200 429] (map :status (repeatedly 3 #(handler req)))))))) + +(defn- mk-user [route-key store now] + ((rl/user-limiter route-key {:capacity 2 :refill-per-ms 0.0 :now-ms (constantly now) :store store}) + ok-handler)) + +(deftest user-limiter-test + (testing "sustained rapid writes from one user are throttled" + (let [store (atom {}) + handler (mk-user :changes store 0) + req {:identity {:sub "user-a"}}] + (is (= [200 200 429] (map :status (repeatedly 3 #(handler req))))))) + + (testing "independent users do not share a bucket" + (let [store (atom {}) + handler (mk-user :changes store 0) + a {:identity {:sub "user-a"}} + b {:identity {:sub "user-b"}}] + (dotimes [_ 3] (handler a)) + (is (= 200 (:status (handler b))) "B is unaffected by A's flood"))) + + (testing "keys on user identity, not client IP" + (let [store (atom {}) + handler (mk-user :changes store 0) + req (fn [n] {:identity {:sub "user-a"} + :headers {"x-real-ip" (str "198.51.100." n)}}) + rs (mapv #(handler (req %)) (range 3))] + (is (= [200 200 429] (mapv :status rs)) + "rotating IPs does not grant the same user fresh buckets")))) + +(deftest spoofed-header-test + (testing "rotating X-Forwarded-For never grants a fresh bucket (TASK-088 bypass)" + (let [store (atom {}) + handler (mk :login store 0) + req (fn [n] {:headers {"x-real-ip" "203.0.113.7" + "x-forwarded-for" (str "198.51.100." n)}}) + rs (mapv #(handler (req %)) (range 5))] + (is (= [200 200 429 429 429] (mapv :status rs)) + "the limiter keys on the proxy-set header, ignoring the spoofable one"))) + + (testing "with no trusted header, rotating X-Forwarded-For collapses to one shared bucket" + (let [store (atom {}) + handler (mk :login store 0) + req (fn [n] {:headers {"x-forwarded-for" (str "198.51.100." n)} + :remote-addr "127.0.0.1"}) + rs (mapv #(handler (req %)) (range 5))] + (is (= [200 200 429 429 429] (mapv :status rs)) + "misconfiguration over-throttles; it never opens a bypass")))) diff --git a/test/aps/parts/server_test.clj b/test/aps/parts/server_test.clj index d89ea154..384a2962 100644 --- a/test/aps/parts/server_test.clj +++ b/test/aps/parts/server_test.clj @@ -26,11 +26,20 @@ (is (some? v) path) (is (str/includes? v "script-src 'self'") path) (is (str/includes? v "frame-ancestors 'none'") path)))) - (testing "marketing pages are deliberately excluded (they load Plausible)" - (is (nil? (csp app "/")) "no CSP on the marketing home")))) + (testing "public pages carry the Plausible-allowlisting CSP, no inline + script (analytics is wired via /js/marketing.js data + attributes)" + (doseq [path ["/" "/playground" "/privacy" "/terms" "/dpa"]] + (let [v (csp app path)] + (is (some? v) path) + (is (str/includes? v "script-src 'self' https://plausible.io") path) + (is (not (str/includes? v "unsafe-inline")) path) + (is (str/includes? v "frame-ancestors 'none'") path)))))) (deftest content-security-policy-prod-is-strict-test (testing "prod permits no eval; non-prod allows it for shadow-cljs dev loading" (is (= "script-src 'self'; frame-ancestors 'none'" (#'middleware/content-security-policy true))) - (is (str/includes? (#'middleware/content-security-policy false) "'unsafe-eval'")))) + (is (str/includes? (#'middleware/content-security-policy false) "'unsafe-eval'")) + (is (= "script-src 'self' https://plausible.io; frame-ancestors 'none'" + (#'middleware/public-content-security-policy true)))))