From dffcbc17c65e4aeed069a9465fa6e342119b6677 Mon Sep 17 00:00:00 2001 From: codeGlaze Date: Wed, 4 Nov 2026 00:25:39 +0000 Subject: [PATCH 01/27] Limit resend-verification mail per address and per host, as password reset is --- src/clj/orcpub/routes.clj | 4 +++- src/clj/orcpub/security.clj | 14 +++++++++++++ test/clj/orcpub/routes_test.clj | 37 +++++++++++++++++++++++++++++++++ 3 files changed, 54 insertions(+), 1 deletion(-) diff --git a/src/clj/orcpub/routes.clj b/src/clj/orcpub/routes.clj index e643be560..f21d4f4ce 100644 --- a/src/clj/orcpub/routes.clj +++ b/src/clj/orcpub/routes.clj @@ -715,7 +715,7 @@ {:status 400})) {:status 400})) -(defn re-verify [{:keys [query-params db conn] :as request}] +(defn re-verify [{:keys [query-params db conn remote-addr] :as request}] (let [email (:email query-params) {:keys [:orcpub.user/verification-sent :orcpub.user/verified? @@ -725,6 +725,8 @@ ;; No account for this address: answer like a resend and create nothing. Passing ;; {:db/id nil} on would register a key-only record and email a link to any address typed. (nil? id) {:status 200} + ;; Over the limit: the same answer as an unknown address, so the limit is not a membership oracle. + (not (security/reverify-email-allowed? email remote-addr)) {:status 200} :else (do-verification request (merge query-params diff --git a/src/clj/orcpub/security.clj b/src/clj/orcpub/security.clj index 1e946dd19..83c85a0f0 100644 --- a/src/clj/orcpub/security.clj +++ b/src/clj/orcpub/security.clj @@ -286,6 +286,18 @@ (and (under-limit? [:reset-address email] reset-per-address-hourly (hours 1)) (under-limit? [:reset-host ip] reset-per-host-hourly (hours 1)))) +;; Same ceilings as reset: the resend endpoint mails any registered, unverified +;; address just as the reset endpoint does, so it gets the same two limits. +(def reverify-per-address-hourly 3) +(def reverify-per-host-hourly 10) + +(defn reverify-email-allowed? + "True while `email` and `ip` are both under their hourly resend-verification + limits. Counts the attempt against each limit, so call it once per request." + [email ip] + (and (under-limit? [:reverify-address email] reverify-per-address-hourly (hours 1)) + (under-limit? [:reverify-host ip] reverify-per-host-hourly (hours 1)))) + ;; What this defends is NOT the account table -- an unverified account cannot log ;; in, so bulk signups sit inert. What signup CAN do is send mail to an address ;; the filler doesn't own, same as the reset endpoint. Sized to real use (eight @@ -322,6 +334,8 @@ (let [caps {:register registrations-per-host-hourly :reset-address reset-per-address-hourly :reset-host reset-per-host-hourly + :reverify-address reverify-per-address-hourly + :reverify-host reverify-per-host-hourly :image-probe-host image-probe-per-host-hourly} near (for [[what n] highs :let [cap (get caps what)] diff --git a/test/clj/orcpub/routes_test.clj b/test/clj/orcpub/routes_test.clj index 8a401109f..b42fc43ea 100644 --- a/test/clj/orcpub/routes_test.clj +++ b/test/clj/orcpub/routes_test.clj @@ -442,6 +442,43 @@ (is (= {:status 200} (routes/send-password-reset request))))))) +(defn- clear-limits! [] + (reset! @#'security/sightings {})) + +(deftest resend-verification-is-limited-per-address-and-answers-the-same + (let [sent (atom 0) + resend (fn [email ip] + (routes/re-verify {:query-params {:email email} :db nil :conn nil + :remote-addr ip}))] + (clear-limits!) + (with-redefs [routes/user-for-email (constantly {:db/id 17}) + routes/do-verification (fn [& _] (swap! sent inc) {:status 200})] + (testing "within the per-address limit, mail goes out" + (dotimes [_ 3] + (is (= {:status 200} (resend "someone@example.com" "1.2.3.4")))) + (is (= 3 @sent))) + (testing "the fourth in the hour sends nothing and answers the same" + (is (= {:status 200} (resend "someone@example.com" "1.2.3.4"))) + (is (= 3 @sent)))) + (clear-limits!))) + +(deftest resend-verification-is-limited-per-host-and-answers-the-same + (let [sent (atom 0) + resend (fn [n] (routes/re-verify {:query-params {:email (str "user" n "@example.com")} + :db nil :conn nil :remote-addr "5.6.7.8"}))] + (clear-limits!) + (with-redefs [routes/user-for-email (constantly {:db/id 17}) + routes/do-verification (fn [& _] (swap! sent inc) {:status 200})] + (testing "ten different addresses from one host get mail" + (dotimes [n 10] + (is (= {:status 200} (resend n)))) + (is (= 10 @sent))) + (testing "the eleventh sends nothing and answers the same" + (is (= {:status 200} (resend 10))) + (is (= 10 @sent)))) + (clear-limits!))) + + (deftest the-owner-is-told-when-one-account-is-tried-from-several-places (let [posted (promise) request {:scheme :https :headers {"host" "example.test"}} From e082c3b86938bcee67f904a5b7a92166b092a339 Mon Sep 17 00:00:00 2001 From: codeGlaze Date: Wed, 4 Nov 2026 01:56:01 +0000 Subject: [PATCH 02/27] Test password reset limits per address and per host and the uniform answer --- test/clj/orcpub/routes_test.clj | 51 +++++++++++++++++++++++++++++++++ 1 file changed, 51 insertions(+) diff --git a/test/clj/orcpub/routes_test.clj b/test/clj/orcpub/routes_test.clj index b42fc43ea..72c81c1d8 100644 --- a/test/clj/orcpub/routes_test.clj +++ b/test/clj/orcpub/routes_test.clj @@ -478,6 +478,57 @@ (is (= 10 @sent)))) (clear-limits!))) +(deftest password-reset-is-limited-per-address-and-answers-the-same + (let [sent (atom 0) + reset (fn [email ip] + (routes/send-password-reset {:query-params {:email email} :db nil :conn nil + :remote-addr ip}))] + (clear-limits!) + (with-redefs [routes/user-for-email (constantly {:db/id 17}) + routes/do-send-password-reset (fn [& _] (swap! sent inc) {:status 200})] + (let [first-response (reset "someone@example.com" "1.2.3.4")] + (testing "within the per-address limit, mail goes out" + (dotimes [_ 2] + (is (= first-response (reset "someone@example.com" "1.2.3.4")))) + (is (= 3 @sent))) + (testing "the fourth in the hour sends nothing and answers the same" + (is (= first-response (reset "someone@example.com" "1.2.3.4"))) + (is (= 3 @sent))))) + (clear-limits!))) + +(deftest password-reset-is-limited-per-host-and-answers-the-same + (let [sent (atom 0) + reset (fn [n] (routes/send-password-reset {:query-params {:email (str "user" n "@example.com")} + :db nil :conn nil :remote-addr "5.6.7.8"}))] + (clear-limits!) + (with-redefs [routes/user-for-email (constantly {:db/id 17}) + routes/do-send-password-reset (fn [& _] (swap! sent inc) {:status 200})] + (let [first-response (reset 0)] + (testing "ten different addresses from one host get mail" + (dotimes [n 9] + (is (= first-response (reset (inc n))))) + (is (= 10 @sent))) + (testing "the eleventh sends nothing and answers the same" + (is (= first-response (reset 10))) + (is (= 10 @sent))))) + (clear-limits!))) + +(deftest password-reset-for-an-unknown-address-sends-nothing-and-answers-the-same + (let [sent (atom 0) + reset (fn [email] (routes/send-password-reset {:query-params {:email email} :db nil :conn nil + :remote-addr "9.9.9.9"}))] + (clear-limits!) + (with-redefs [routes/do-send-password-reset (fn [& _] (swap! sent inc) {:status 200})] + (let [known (with-redefs [routes/user-for-email (constantly {:db/id 17})] + (reset "known@example.com")) + sent-for-known @sent + unknown (with-redefs [routes/user-for-email (constantly {})] + (reset "nobody@example.com"))] + (is (= 1 sent-for-known)) + (is (= known unknown)) + (is (= 1 @sent)))) + (clear-limits!))) + (deftest the-owner-is-told-when-one-account-is-tried-from-several-places (let [posted (promise) From 07cff9980b25b924ad78e3558636144c7a43649a Mon Sep 17 00:00:00 2001 From: codeGlaze Date: Wed, 4 Nov 2026 02:29:39 +0000 Subject: [PATCH 03/27] Ask for a Cloudflare Turnstile check on sign-up when both keys are set Managed mode, sign-up form only. The server checks the token before the per-host sign-up allowance, so a bot that fails the check does not use up a real visitor's signups. If Cloudflare cannot be reached the signup goes through. Off unless both TURNSTILE_SITE_KEY and TURNSTILE_SECRET_KEY are set; the secret is never printed. --- .env.example | 5 ++ docker-compose.yaml | 2 + docs/ENVIRONMENT.md | 3 + scripts/swarm.sh | 2 + src/clj/orcpub/config.clj | 33 ++++++- src/clj/orcpub/index.clj | 5 +- src/clj/orcpub/pedestal.clj | 4 +- src/clj/orcpub/routes.clj | 13 +++ src/clj/orcpub/turnstile.clj | 62 +++++++++++++ src/cljs/orcpub/dnd/e5/events.cljs | 18 +++- src/cljs/orcpub/dnd/e5/views.cljs | 2 + src/cljs/orcpub/turnstile.cljs | 79 +++++++++++++++++ test/clj/orcpub/turnstile_test.clj | 136 +++++++++++++++++++++++++++++ 13 files changed, 358 insertions(+), 6 deletions(-) create mode 100644 src/clj/orcpub/turnstile.clj create mode 100644 src/cljs/orcpub/turnstile.cljs create mode 100644 test/clj/orcpub/turnstile_test.clj diff --git a/.env.example b/.env.example index bfdfa54d6..5870b7910 100644 --- a/.env.example +++ b/.env.example @@ -209,6 +209,11 @@ PROFILE_ENCRYPTION_KEYS= # ORCPUB_SHARE_PRUNE_DAYS=180 # Check new passwords against known breaches (Have I Been Pwned). on or off. Default on. # ORCPUB_PWNED_CHECK=on +# Cloudflare Turnstile on the sign-up form (managed mode). Off unless BOTH are set. Fails open +# if Cloudflare cannot be reached. Cloudflare's test keys always pass: +# site key 1x00000000000000000000AA secret 1x0000000000000000000000000000000AA +# TURNSTILE_SITE_KEY= +# TURNSTILE_SECRET_KEY= # --- Branding (optional) --- # The site's name, logos, links and email identity. Each has a default in fork/branding.clj; diff --git a/docker-compose.yaml b/docker-compose.yaml index 1a4096fde..a22fac238 100644 --- a/docker-compose.yaml +++ b/docker-compose.yaml @@ -107,6 +107,8 @@ services: ORCPUB_SHARE_MAX_ACCOUNT_KB: ${ORCPUB_SHARE_MAX_ACCOUNT_KB:-} ORCPUB_SHARE_PRUNE_DAYS: ${ORCPUB_SHARE_PRUNE_DAYS:-} ORCPUB_PWNED_CHECK: ${ORCPUB_PWNED_CHECK:-} + TURNSTILE_SITE_KEY: ${TURNSTILE_SITE_KEY:-} + TURNSTILE_SECRET_KEY: ${TURNSTILE_SECRET_KEY:-} # Branding (docs/BRANDING-AND-INTEGRATIONS.md). Set, these override the branding file's defaults APP_NAME: ${APP_NAME:-} APP_TAGLINE: ${APP_TAGLINE:-} diff --git a/docs/ENVIRONMENT.md b/docs/ENVIRONMENT.md index 095202b52..2ea3af4a2 100644 --- a/docs/ENVIRONMENT.md +++ b/docs/ENVIRONMENT.md @@ -50,6 +50,7 @@ start-up output, so you can decide which ones matter for your site. | `ORCPUB_SHARE_MAX_UPLOAD_KB`, `ORCPUB_SHARE_MAX_TEXT_KB`, `ORCPUB_SHARE_MAX_ACCOUNT_KB` | How much homebrew a share link and an account may keep | [Share links](#share-links) | | `ORCPUB_SHARE_PRUNE_DAYS` | How long an unused share link is kept | [Share links](#share-links) | | `ORCPUB_PWNED_CHECK` | Whether new passwords are checked against known breaches | [Security](#security) | +| `TURNSTILE_SITE_KEY`, `TURNSTILE_SECRET_KEY` | Cloudflare Turnstile bot check on the sign-up form | [Security](#security) | | `TRUST_CLOUDFLARE`, `TRUSTED_PROXIES` | Which proxies to trust when finding a player's real address | [Security](#security) | | `APP_EMAIL_SIGNOFF` | Who the friendlier emails are signed from | [BRANDING-AND-INTEGRATIONS.md](BRANDING-AND-INTEGRATIONS.md) | @@ -212,6 +213,8 @@ the table in half. Plain ASCII, no colour: it is read in aggregators as often as | `CSP_POLICY` | `strict` | Content Security Policy mode: `strict`, `permissive`, or `none` | | `DEV_MODE` | `"true"` (in :dev profile) | When true, **no CSP header is sent at all** — that is what lets Figwheel's `ws://localhost:3449` through. Must be the string `"true"` (case-insensitive); any other value, including `"1"`, `"yes"` or empty, is false. | | `ORCPUB_PWNED_CHECK` | `on` | Screen new passwords against the Have I Been Pwned corpus. Accepts `on`/`off`, `true`/`false`, `1`/`0`, `yes`/`no`. | +| `TURNSTILE_SITE_KEY` | unset | Cloudflare Turnstile site key (public; sent to the browser). The sign-up form shows the managed-mode check only when **both** this and `TURNSTILE_SECRET_KEY` are set; otherwise the feature is entirely off. Adds `https://challenges.cloudflare.com` to the CSP `frame-src` (and, under `CSP_POLICY=permissive`, `script-src`). Fails open: if Cloudflare cannot be reached, sign-up goes through. For testing, Cloudflare's dummy keys always pass: site key `1x00000000000000000000AA`, secret `1x0000000000000000000000000000000AA`. | +| `TURNSTILE_SECRET_KEY` | unset | Turnstile secret key; server-side only, never logged or shown (the startup report says only set / NOT SET). See `TURNSTILE_SITE_KEY`. | | `TRUST_CLOUDFLARE` | unset | Set to `true` only when the site is served through Cloudflare. The sign-in, sign-up and reset limits and the security log then see each player's real address instead of Cloudflare's. Leave it unset otherwise: anyone can send requests from Cloudflare's addresses, so trusting them on a site not behind Cloudflare would let a visitor pick their own address. | | `TRUSTED_PROXIES` | unset | Other proxies in front of the app, as comma-separated addresses or ranges (`203.0.113.10,198.51.100.0/24`). Private networks, where Docker, Swarm, Traefik and nginx proxies sit, are always trusted. | | `PROFILE_ENCRYPTION_KEYS` | — | Encrypts preferred names at rest: comma-separated `id:base64` keys of 32 bytes; the first encrypts, all decrypt. Also read from the Docker secret `profile_encryption_keys`. Unset = preferred names cannot be saved. Losing it makes stored names unreadable. `./run` generates one. | diff --git a/scripts/swarm.sh b/scripts/swarm.sh index 584920836..6b91ee308 100644 --- a/scripts/swarm.sh +++ b/scripts/swarm.sh @@ -443,6 +443,8 @@ generate_swarm_compose() { "ORCPUB_SHARE_MAX_ACCOUNT_KB:\${ORCPUB_SHARE_MAX_ACCOUNT_KB:-}" "ORCPUB_SHARE_PRUNE_DAYS:\${ORCPUB_SHARE_PRUNE_DAYS:-}" "ORCPUB_PWNED_CHECK:\${ORCPUB_PWNED_CHECK:-}" + "TURNSTILE_SITE_KEY:\${TURNSTILE_SITE_KEY:-}" + "TURNSTILE_SECRET_KEY:\${TURNSTILE_SECRET_KEY:-}" "APP_NAME:\${APP_NAME:-}" "APP_TAGLINE:\${APP_TAGLINE:-}" "APP_PAGE_TITLE:\${APP_PAGE_TITLE:-}" diff --git a/src/clj/orcpub/config.clj b/src/clj/orcpub/config.clj index 9ba21ba53..bd020d230 100644 --- a/src/clj/orcpub/config.clj +++ b/src/clj/orcpub/config.clj @@ -78,6 +78,8 @@ :img-src "'self' data: https:" :object-src "'none'"}) +(def turnstile-origin "https://challenges.cloudflare.com") + (defn get-csp-policy "Return the CSP policy from CSP_POLICY env var. Defaults to 'strict'." [] @@ -349,6 +351,22 @@ (let [raw (some-> (env-raw "ORCPUB_PWNED_CHECK") str/trim (.toLowerCase Locale/ROOT))] (not (contains? #{"off" "false" "0" "no"} raw)))) +(defn turnstile-site-key + "TURNSTILE_SITE_KEY (public, sent to the browser), or nil when unset or blank." + [] + (env-raw "TURNSTILE_SITE_KEY")) + +(defn turnstile-secret-key + "TURNSTILE_SECRET_KEY, or nil when unset or blank. NEVER log, print or send it." + [] + (env-raw "TURNSTILE_SECRET_KEY")) + +(defn turnstile-enabled? + "Whether the sign-up form asks for a Cloudflare Turnstile check: only when BOTH + TURNSTILE_SITE_KEY and TURNSTILE_SECRET_KEY are set." + [] + (boolean (and (turnstile-site-key) (turnstile-secret-key)))) + (defn- positive-int-text? "Whether text `raw` reads as a positive whole number." [raw] @@ -436,6 +454,10 @@ :accepts #(contains? #{"on" "off" "true" "false" "1" "0" "yes" "no"} (.toLowerCase (str/trim %) Locale/ROOT)) :expects "on or off" :note "checks new passwords against known breaches"} + {:group "security" :var "TURNSTILE_SITE_KEY" :since current-release :get #(turnstile-site-key) + :note "Turnstile on sign-up; needs the secret key too"} + {:group "security" :var "TURNSTILE_SECRET_KEY" :since current-release :secret? true + :note "Turnstile on sign-up; needs the site key too"} {:group "retention" :var "ORCPUB_SHARE_PRUNE_DAYS" :since current-release :get #(get-share-prune-days) :accepts #(some-> % str/trim parse-long (>= 0)) :expects "a whole number of days, 0 or more" :note "days before an unused share link is deleted; 0 never"}])) @@ -456,7 +478,8 @@ "ORCPUB_PORTRAIT_CONCURRENCY" "ORCPUB_PORTRAIT_QUEUE_TIMEOUT_MS" "PORTRAIT_STORE_DIR" "ORCPUB_PDF_MAX_RETRIES" "ORCPUB_PDF_MAX_CASTER_SECTIONS" "ORCPUB_PDF_MAX_CARDS" "ORCPUB_SHARE_MAX_UPLOAD_KB" "ORCPUB_SHARE_MAX_TEXT_KB" "ORCPUB_SHARE_MAX_ACCOUNT_KB" - "ORCPUB_PWNED_CHECK" "ORCPUB_SHARE_PRUNE_DAYS"] + "ORCPUB_PWNED_CHECK" "ORCPUB_SHARE_PRUNE_DAYS" "TURNSTILE_SITE_KEY" + "TURNSTILE_SECRET_KEY"] (repeat :tuning)))) (def ^:private tunables @@ -738,5 +761,11 @@ {:content-security-policy-settings nil} ;; Default to permissive + ;; Turnstile loads its script and renders in a frame from Cloudflare. :else - {:content-security-policy-settings permissive-csp-settings})) + {:content-security-policy-settings + (if (turnstile-enabled?) + (assoc permissive-csp-settings + :script-src (str (:script-src permissive-csp-settings) " " turnstile-origin) + :frame-src (str "'self' " turnstile-origin)) + permissive-csp-settings)})) diff --git a/src/clj/orcpub/index.clj b/src/clj/orcpub/index.clj index d2fbc3bf7..9e5a4f319 100644 --- a/src/clj/orcpub/index.clj +++ b/src/clj/orcpub/index.clj @@ -272,7 +272,10 @@ html { (script-tag {:nonce nonce} ;; raw: operator settings as JSON, escaped for a script by script-json (h/raw (str "window.__BRANDING__=" (script-json (branding/client-config)) ";" - "window.__INTEGRATIONS__=" (script-json (integrations/client-config)) ";")))] + "window.__INTEGRATIONS__=" (script-json (integrations/client-config)) ";" + ;; The PUBLIC site key only, and only when Turnstile is fully configured. + (when (config/turnstile-enabled?) + (str "window.__TURNSTILE_SITE_KEY__=" (script-json (config/turnstile-site-key)) ";")))))] [:body {:style "margin:0;line-height:1"} [:div#app (if splash? diff --git a/src/clj/orcpub/pedestal.clj b/src/clj/orcpub/pedestal.clj index 00b676206..aeb1913f4 100644 --- a/src/clj/orcpub/pedestal.clj +++ b/src/clj/orcpub/pedestal.clj @@ -74,7 +74,9 @@ ;; branch is unreachable in dev mode. :dev-mode? false :extra-connect-src (:connect-src integrations/csp-domains) - :extra-frame-src (:frame-src integrations/csp-domains))) + :extra-frame-src (cond-> (vec (:frame-src integrations/csp-domains)) + (config/turnstile-enabled?) + (conj config/turnstile-origin)))) ctx))})) ;; Create the nonce interceptor with current dev-mode? setting diff --git a/src/clj/orcpub/routes.clj b/src/clj/orcpub/routes.clj index f21d4f4ce..2921f7f58 100644 --- a/src/clj/orcpub/routes.clj +++ b/src/clj/orcpub/routes.clj @@ -62,6 +62,7 @@ [orcpub.dnd.e5.emblems :as emblems] [orcpub.registration :as registration] [orcpub.pwned :as pwned] + [orcpub.turnstile :as turnstile] [orcpub.entity.strict :as se] [orcpub.entity :as entity] [orcpub.security :as security] @@ -597,6 +598,9 @@ (str "Too many accounts have been created from this connection in the last hour. " "Try again a little later, or email us if you are stuck.")) +(def ^:private turnstile-failed-message + "We couldn't confirm you're not a bot. Please try the check again.") + (defn register [{:keys [json-params db conn remote-addr] :as request}] (let [{:keys [username email password send-updates?]} json-params username (when username (s/trim username)) @@ -612,6 +616,15 @@ validation (if (seq validation) validation (or (breach-errors password) validation)) + ;; Before the host allowance, so a bot that fails the challenge does not use up the + ;; host's signups. After validation and the breach check, so a form that was going to + ;; be rejected anyway never costs a verification. :unreachable is a pass (fail open). + ;; :general for the same reason as the throttle below. + validation (if (and (empty? validation) + (turnstile/enabled?) + (= :fail (turnstile/verify (:turnstile-token json-params) remote-addr))) + (assoc validation :general [turnstile-failed-message]) + validation) ;; Checked last, so a form that was going to be rejected anyway is not ;; counted against the host. :general rather than a field key: nobody ;; can edit their way past a rate limit, so it must not sit in the map diff --git a/src/clj/orcpub/turnstile.clj b/src/clj/orcpub/turnstile.clj new file mode 100644 index 000000000..d1e49a103 --- /dev/null +++ b/src/clj/orcpub/turnstile.clj @@ -0,0 +1,62 @@ +(ns orcpub.turnstile + "Cloudflare Turnstile check for the sign-up form (managed mode). + GOTCHA: fails OPEN. If Cloudflare cannot be reached, the signup goes through; only an + answer of success=false (or no token at all) refuses. The secret key is never logged." + (:require [clj-http.client :as client] + [clojure.string :as s] + [orcpub.config :as config])) + +(def ^:private endpoint "https://challenges.cloudflare.com/turnstile/v0/siteverify") + +;; Short enough that a stalled third party cannot hold a signup open (same idea as orcpub.pwned). +(def ^:private timeout-ms 4000) + +(defn enabled? + "True only when both TURNSTILE_SITE_KEY and TURNSTILE_SECRET_KEY are set." + [] + (config/turnstile-enabled?)) + +(defn- post-siteverify + "POSTs to Cloudflare; returns the parsed JSON body as a map. Throws on transport failure, + non-2xx or an unparseable body. A separate fn so tests can with-redefs it." + [token remote-ip] + (let [{:keys [status body]} + (client/post endpoint + {:form-params (cond-> {:secret (config/turnstile-secret-key) + :response token} + (not (s/blank? remote-ip)) (assoc :remoteip remote-ip)) + :as :json + :socket-timeout timeout-ms + :connection-timeout timeout-ms + :throw-exceptions false + :cookie-policy :none + :redirect-strategy :none})] + (if (<= 200 status 299) + body + (throw (ex-info "siteverify non-2xx" {:status status}))))) + +;; A sustained outage would otherwise log a line per signup. +(def ^:private log-window-ms 60000) +(def ^:private last-logged (atom 0)) + +(defn- warn-unreachable! [reason] + (let [now (System/currentTimeMillis) + [before _] (swap-vals! last-logged #(if (> (- now %) log-window-ms) now %))] + (when (> (- now before) log-window-ms) + ;; Reason is an exception class name or HTTP status: never the secret or the token. + (println "turnstile: siteverify unreachable, letting signup through -" reason)))) + +(defn verify + "Checks a Turnstile `token` for `remote-ip`. Returns :pass, :fail, or :unreachable (the caller + treats :unreachable as a pass). A blank token is :fail without calling Cloudflare." + [token remote-ip] + (if (s/blank? token) + :fail + (try + (let [result (post-siteverify token remote-ip)] + (if (true? (:success result)) :pass :fail)) + (catch Exception e + (warn-unreachable! (if-let [st (:status (ex-data e))] + (str "HTTP " st) + (.. e getClass getSimpleName))) + :unreachable)))) diff --git a/src/cljs/orcpub/dnd/e5/events.cljs b/src/cljs/orcpub/dnd/e5/events.cljs index 7fd3b3a71..045d5b341 100644 --- a/src/cljs/orcpub/dnd/e5/events.cljs +++ b/src/cljs/orcpub/dnd/e5/events.cljs @@ -124,6 +124,7 @@ [orcpub.errors :as errors] [orcpub.fork.integrations :as integrations] [orcpub.fork.branding :as branding] + [orcpub.turnstile :as turnstile] [clojure.set :as sets] [cljsjs.filesaverjs] [clojure.pprint :as pprint]) @@ -3810,7 +3811,19 @@ {:general ["Registration is currently unavailable. Please contact the site administrator."]} (and (map? body) (not (contains? body :error))) body :else {:general ["Registration failed. Please try again."]})) - :dispatch [:clear-login]}))) + ;; A Turnstile token is single use: any failed attempt needs a fresh one. + :dispatch-n [[:clear-login] [:turnstile-reset]]}))) + +(reg-event-db + :turnstile-token + (fn [db [_ token]] + (assoc db :turnstile-token token))) + +(reg-event-fx + :turnstile-reset + (fn [_ _] + (turnstile/reset-widget!) + nil)) #_ ;; dead stub — real impl is orcpub.registration/validate-registration (defn validate-registration []) @@ -3906,7 +3919,8 @@ {:db (assoc db :temp-email (:email registration-form)) :http {:method :post :url (backend-url (bidi/path-for routes/routes routes/register-route)) - :json-params registration-form + :json-params (cond-> registration-form + (:turnstile-token db) (assoc :turnstile-token (:turnstile-token db))) :on-success [:register-success backtrack?] :on-failure [:register-failure]}}))) diff --git a/src/cljs/orcpub/dnd/e5/views.cljs b/src/cljs/orcpub/dnd/e5/views.cljs index 8b8994d5e..36dd9a611 100644 --- a/src/cljs/orcpub/dnd/e5/views.cljs +++ b/src/cljs/orcpub/dnd/e5/views.cljs @@ -65,6 +65,7 @@ [orcpub.dnd.e5.orcbrew-validation :as orcbrew-val] [orcpub.fork.integrations :as integrations] [orcpub.fork.branding :as branding] + [orcpub.turnstile :as turnstile] [orcpub.fork.splash :as splash] [orcpub.fork.user-tier] [orcpub.ver :as v] @@ -1271,6 +1272,7 @@ [:div.m-t-20.t-a-l.m-l-15 [comps/labeled-checkbox (str "Yes! Send me updates about " branding/app-name) send-updates? false #(dispatch [:registration-send-updates? (not send-updates?)])]] + [turnstile/widget] ] :tail [:div diff --git a/src/cljs/orcpub/turnstile.cljs b/src/cljs/orcpub/turnstile.cljs new file mode 100644 index 000000000..4fef363e6 --- /dev/null +++ b/src/cljs/orcpub/turnstile.cljs @@ -0,0 +1,79 @@ +(ns orcpub.turnstile + "Cloudflare Turnstile widget for the sign-up form (managed mode). + Loaded only when the server put a site key on the page (window.__TURNSTILE_SITE_KEY__), + and only when the form mounts, so no other page fetches anything from Cloudflare. + Fails open on the client: if the script never loads, nothing is blocked; the server decides." + (:require [reagent.core :as r] + [re-frame.core :refer [dispatch]])) + +(def ^:private script-id "cf-turnstile-api") +(def ^:private script-src "https://challenges.cloudflare.com/turnstile/v0/api.js?render=explicit") + +(defn site-key + "The public site key, or nil when Turnstile is not configured." + [] + (let [k (aget js/window "__TURNSTILE_SITE_KEY__")] + (when (and (string? k) (seq k)) k))) + +(defonce ^:private widget-id (atom nil)) + +(defn- api [] (aget js/window "turnstile")) + +(defn- call-api + "Calls window.turnstile[method] by string name, so advanced compilation cannot rename it." + [method & args] + (let [t (api)] + (.apply (aget t method) t (to-array args)))) + +(defn- with-api + "Calls `f` once the Turnstile API is available, loading its script once. Never throws." + [f] + (if (api) + (f) + (if-let [existing (.getElementById js/document script-id)] + (.addEventListener existing "load" f) + (let [el (.createElement js/document "script")] + (set! (.-id el) script-id) + (set! (.-src el) script-src) + (set! (.-async el) true) + (set! (.-defer el) true) + (.addEventListener el "load" f) + ;; Script failed to load: leave the form as it is; the server fails open. + (.addEventListener el "error" (fn [_] (dispatch [:turnstile-token nil]))) + (.appendChild (.-head js/document) el))))) + +(defn reset-widget! + "Tokens are single use: asks the widget for a fresh one. No-op without a widget." + [] + (dispatch [:turnstile-token nil]) + (when-let [id @widget-id] + (try (call-api "reset" id) (catch :default _ nil)))) + +(defn- render! [el key] + (when (and (api) (nil? @widget-id) (.-isConnected el)) + (reset! widget-id + (try + (call-api "render" el + #js {:sitekey key + :callback (fn [token] (dispatch [:turnstile-token token])) + :expired-callback (fn [] (dispatch [:turnstile-token nil])) + :error-callback (fn [] (dispatch [:turnstile-token nil]))}) + (catch :default _ nil))))) + +(defn widget + "The challenge container. Renders nothing when no site key is configured." + [] + (when-let [key (site-key)] + (let [el (atom nil)] + (r/create-class + {:display-name "turnstile-widget" + :component-did-mount + (fn [_] (with-api #(when @el (render! @el key)))) + :component-will-unmount + (fn [_] + (when-let [id @widget-id] + (try (call-api "remove" id) (catch :default _ nil))) + (reset! widget-id nil) + (dispatch [:turnstile-token nil])) + :reagent-render + (fn [] [:div.m-t-10 {:ref #(reset! el %)}])})))) diff --git a/test/clj/orcpub/turnstile_test.clj b/test/clj/orcpub/turnstile_test.clj new file mode 100644 index 000000000..8563c3eb7 --- /dev/null +++ b/test/clj/orcpub/turnstile_test.clj @@ -0,0 +1,136 @@ +(ns orcpub.turnstile-test + "Cloudflare Turnstile on the sign-up form: off unless both keys are set, fails open when + Cloudflare is unreachable, refuses only on an explicit failure, and a refused attempt does + not use up the host's signup allowance. No test reaches the network." + (:require + [clojure.string :as str] + [clojure.test :refer [deftest is testing use-fixtures]] + [datomic.api :as d] + [orcpub.config :as config] + [orcpub.email :as email] + [orcpub.errors :as errors] + [orcpub.pedestal :as pedestal] + [orcpub.pwned :as pwned] + [orcpub.routes :as routes] + [orcpub.security :as security] + [orcpub.turnstile :as turnstile] + [orcpub.db.schema :as schema]) + (:import [java.util UUID])) + +(def ^:private secret "s3cr3t-turnstile-value-9f2c") + +(use-fixtures :each + (fn [f] + (reset! @#'security/sightings {}) + (with-redefs [email/configured? (constantly true) + pwned/check (constantly 0)] + (binding [errors/*error-prefix* "TEST_ERROR:"] + (f))) + (reset! @#'security/sightings {}))) + +(defn- fresh-conn [] + (let [uri (str "datomic:mem:turnstile-test-" (UUID/randomUUID))] + (d/create-database uri) + (let [conn (d/connect uri)] + @(d/transact conn schema/all-schemas) + conn))) + +(defn- request [conn token] + {:conn conn :db (d/db conn) :scheme :https :headers {"host" "example.test"} + :remote-addr "7.7.7.7" + :json-params (cond-> {:username "newcomer" :email "newcomer@test.com" + :verify-email "newcomer@test.com" + :password "hunter2hunter2" :send-updates? false} + token (assoc :turnstile-token token))}) + +(defn- user-exists? [conn] + (some? (d/q '[:find ?e . :where [?e :orcpub.user/username "newcomer"]] (d/db conn)))) + +(defn- host-count [] + (count (get @@#'security/sightings [:register "7.7.7.7"]))) + + +(deftest disabled-register-works-and-never-calls-cloudflare + (let [conn (fresh-conn) calls (atom 0)] + (with-redefs [turnstile/enabled? (constantly false) + turnstile/verify (fn [& _] (swap! calls inc) :fail) + turnstile/post-siteverify (fn [& _] (swap! calls inc) (throw (ex-info "no" {})))] + (is (= 200 (:status (routes/register (request conn nil))))) + (is (user-exists? conn)) + (is (zero? @calls) "siteverify is never called")))) + +(deftest enabled-and-passing-creates-the-account + (let [conn (fresh-conn)] + (with-redefs [turnstile/enabled? (constantly true) + turnstile/post-siteverify (fn [& _] {:success true})] + (is (= 200 (:status (routes/register (request conn "good-token"))))) + (is (user-exists? conn))))) + +(deftest enabled-and-failing-refuses-without-using-the-host-allowance + (let [conn (fresh-conn)] + (with-redefs [turnstile/enabled? (constantly true) + turnstile/post-siteverify (fn [& _] {:success false})] + (let [resp (routes/register (request conn "bad-token"))] + (is (= 400 (:status resp))) + (is (= 1 (count (get-in resp [:body :general]))) "a :general error") + (is (str/includes? (first (get-in resp [:body :general])) "not a bot")) + (is (= [:general] (keys (:body resp))) "no field key") + (is (not (user-exists? conn)) "nothing created") + (is (zero? (host-count)) "the host's allowance is not consumed"))))) + +(deftest enabled-and-unreachable-fails-open + (let [conn (fresh-conn)] + (with-redefs [turnstile/enabled? (constantly true) + turnstile/post-siteverify (fn [& _] (throw (java.net.SocketTimeoutException. "slow")))] + (is (= 200 (:status (routes/register (request conn "any-token"))))) + (is (user-exists? conn))))) + +(deftest a-blank-token-fails-without-calling-cloudflare + (let [calls (atom 0)] + (with-redefs [turnstile/post-siteverify (fn [& _] (swap! calls inc) {:success true})] + (doseq [t [nil "" " "]] + (is (= :fail (turnstile/verify t "1.2.3.4")))) + (is (zero? @calls) "no HTTP call")) + (testing "and through register, while enabled" + (let [conn (fresh-conn)] + (with-redefs [turnstile/enabled? (constantly true) + turnstile/post-siteverify (fn [& _] (swap! calls inc) {:success true})] + (is (= 400 (:status (routes/register (request conn nil))))) + (is (zero? @calls))))))) + +(deftest verify-maps-cloudflare-answers + (with-redefs [turnstile/post-siteverify (fn [& _] {:success true})] + (is (= :pass (turnstile/verify "t" "1.2.3.4")))) + (with-redefs [turnstile/post-siteverify (fn [& _] {:success false :error-codes ["x"]})] + (is (= :fail (turnstile/verify "t" "1.2.3.4")))) + (with-redefs [turnstile/post-siteverify (fn [& _] (throw (ex-info "siteverify non-2xx" {:status 500})))] + (is (= :unreachable (turnstile/verify "t" "1.2.3.4"))))) + +(deftest only-both-keys-enable-it + (doseq [[site secret-key expected] [[nil nil false] ["s" nil false] [nil "k" false] ["s" "k" true]]] + (with-redefs [config/turnstile-site-key (constantly site) + config/turnstile-secret-key (constantly secret-key)] + (is (= expected (turnstile/enabled?)))))) + +(defn- frame-src-of [csp-header] + (some #(when (str/starts-with? % "frame-src") %) (str/split csp-header #"; "))) + +(deftest csp-allows-cloudflare-frames-only-when-enabled + (let [leave (:leave (pedestal/make-nonce-interceptor false)) + header (fn [] (get-in (leave {:request {:csp-nonce "n"} :response {:headers {}}}) + [:response :headers "Content-Security-Policy"]))] + (with-redefs [config/turnstile-enabled? (constantly true)] + (is (str/includes? (or (frame-src-of (header)) "") "https://challenges.cloudflare.com"))) + (with-redefs [config/turnstile-enabled? (constantly false)] + (is (not (str/includes? (header) "challenges.cloudflare.com")))))) + +(deftest the-settings-report-never-contains-the-secret + (let [env {"TURNSTILE_SITE_KEY" "1x00000000000000000000AA" "TURNSTILE_SECRET_KEY" secret}] + (with-redefs [config/env-raw (fn [n] (get env n))] + (let [rows (filter #(#{"TURNSTILE_SITE_KEY" "TURNSTILE_SECRET_KEY"} (:var %)) (config/report)) + printed (str/join "\n" (config/report-lines (vec rows)))] + (is (= 2 (count rows))) + (is (not (str/includes? (pr-str rows) secret)) "not in the rows") + (is (not (str/includes? printed secret)) "not in the banner") + (is (str/includes? printed "1x00000000000000000000AA") "the public site key may show") + (is (:set? (first (filter #(= "TURNSTILE_SECRET_KEY" (:var %)) rows)))))))) From e902c8740272a9837b8dd30a285986f63d891b8c Mon Sep 17 00:00:00 2001 From: codeGlaze Date: Wed, 4 Nov 2026 03:47:02 +0000 Subject: [PATCH 04/27] Move the Turnstile server check into security and its tests with it --- src/clj/orcpub/routes.clj | 5 +- src/clj/orcpub/security.clj | 65 +++++++++++++- src/clj/orcpub/turnstile.clj | 62 ------------- test/clj/orcpub/security_test.clj | 137 ++++++++++++++++++++++++++++- test/clj/orcpub/turnstile_test.clj | 136 ---------------------------- 5 files changed, 201 insertions(+), 204 deletions(-) delete mode 100644 src/clj/orcpub/turnstile.clj delete mode 100644 test/clj/orcpub/turnstile_test.clj diff --git a/src/clj/orcpub/routes.clj b/src/clj/orcpub/routes.clj index 2921f7f58..f303802fa 100644 --- a/src/clj/orcpub/routes.clj +++ b/src/clj/orcpub/routes.clj @@ -62,7 +62,6 @@ [orcpub.dnd.e5.emblems :as emblems] [orcpub.registration :as registration] [orcpub.pwned :as pwned] - [orcpub.turnstile :as turnstile] [orcpub.entity.strict :as se] [orcpub.entity :as entity] [orcpub.security :as security] @@ -621,8 +620,8 @@ ;; be rejected anyway never costs a verification. :unreachable is a pass (fail open). ;; :general for the same reason as the throttle below. validation (if (and (empty? validation) - (turnstile/enabled?) - (= :fail (turnstile/verify (:turnstile-token json-params) remote-addr))) + (security/turnstile-enabled?) + (= :fail (security/turnstile-verify (:turnstile-token json-params) remote-addr))) (assoc validation :general [turnstile-failed-message]) validation) ;; Checked last, so a form that was going to be rejected anyway is not diff --git a/src/clj/orcpub/security.clj b/src/clj/orcpub/security.clj index 83c85a0f0..d92ce6d13 100644 --- a/src/clj/orcpub/security.clj +++ b/src/clj/orcpub/security.clj @@ -1,7 +1,9 @@ (ns orcpub.security "Login attempt tracking and rate limiting. See orcpub.time for date/time utilities." - (:require [clojure.string] + (:require [clj-http.client :as client] + [clojure.string :as s] + [orcpub.config :as config] [orcpub.time :as time :refer [minutes hours ago]])) (defn compare-dates [attempt-1 attempt-2] @@ -354,3 +356,64 @@ (println line)) (when-let [line (busiest-summary highs 0.8)] (println line)))) + +;; --------------------------------------------------------------------------- +;; Cloudflare Turnstile check for the sign-up form (managed mode). +;; GOTCHA: fails OPEN. If Cloudflare cannot be reached, the signup goes through; only an +;; answer of success=false (or no token at all) refuses. The secret key is never logged. +;; --------------------------------------------------------------------------- + +(def ^:private turnstile-endpoint "https://challenges.cloudflare.com/turnstile/v0/siteverify") + +;; Short enough that a stalled third party cannot hold a signup open (same idea as orcpub.pwned). +(def ^:private turnstile-timeout-ms 4000) + +(defn turnstile-enabled? + "True only when both TURNSTILE_SITE_KEY and TURNSTILE_SECRET_KEY are set." + [] + (config/turnstile-enabled?)) + +(defn- post-siteverify + "POSTs to Cloudflare; returns the parsed JSON body as a map. Throws on transport failure, + non-2xx or an unparseable body. A separate fn so tests can with-redefs it." + [token remote-ip] + (let [{:keys [status body]} + (client/post turnstile-endpoint + {:form-params (cond-> {:secret (config/turnstile-secret-key) + :response token} + (not (s/blank? remote-ip)) (assoc :remoteip remote-ip)) + :as :json + :socket-timeout turnstile-timeout-ms + :connection-timeout turnstile-timeout-ms + :throw-exceptions false + :cookie-policy :none + :redirect-strategy :none})] + (if (<= 200 status 299) + body + (throw (ex-info "siteverify non-2xx" {:status status}))))) + +;; A sustained outage would otherwise log a line per signup. +(def ^:private turnstile-log-window-ms 60000) +(def ^:private turnstile-last-logged (atom 0)) + +(defn- turnstile-warn-unreachable! [reason] + (let [now (System/currentTimeMillis) + [before _] (swap-vals! turnstile-last-logged #(if (> (- now %) turnstile-log-window-ms) now %))] + (when (> (- now before) turnstile-log-window-ms) + ;; Reason is an exception class name or HTTP status: never the secret or the token. + (println "turnstile: siteverify unreachable, letting signup through -" reason)))) + +(defn turnstile-verify + "Checks a Turnstile `token` for `remote-ip`. Returns :pass, :fail, or :unreachable (the caller + treats :unreachable as a pass). A blank token is :fail without calling Cloudflare." + [token remote-ip] + (if (s/blank? token) + :fail + (try + (let [result (post-siteverify token remote-ip)] + (if (true? (:success result)) :pass :fail)) + (catch Exception e + (turnstile-warn-unreachable! (if-let [st (:status (ex-data e))] + (str "HTTP " st) + (.. e getClass getSimpleName))) + :unreachable)))) diff --git a/src/clj/orcpub/turnstile.clj b/src/clj/orcpub/turnstile.clj deleted file mode 100644 index d1e49a103..000000000 --- a/src/clj/orcpub/turnstile.clj +++ /dev/null @@ -1,62 +0,0 @@ -(ns orcpub.turnstile - "Cloudflare Turnstile check for the sign-up form (managed mode). - GOTCHA: fails OPEN. If Cloudflare cannot be reached, the signup goes through; only an - answer of success=false (or no token at all) refuses. The secret key is never logged." - (:require [clj-http.client :as client] - [clojure.string :as s] - [orcpub.config :as config])) - -(def ^:private endpoint "https://challenges.cloudflare.com/turnstile/v0/siteverify") - -;; Short enough that a stalled third party cannot hold a signup open (same idea as orcpub.pwned). -(def ^:private timeout-ms 4000) - -(defn enabled? - "True only when both TURNSTILE_SITE_KEY and TURNSTILE_SECRET_KEY are set." - [] - (config/turnstile-enabled?)) - -(defn- post-siteverify - "POSTs to Cloudflare; returns the parsed JSON body as a map. Throws on transport failure, - non-2xx or an unparseable body. A separate fn so tests can with-redefs it." - [token remote-ip] - (let [{:keys [status body]} - (client/post endpoint - {:form-params (cond-> {:secret (config/turnstile-secret-key) - :response token} - (not (s/blank? remote-ip)) (assoc :remoteip remote-ip)) - :as :json - :socket-timeout timeout-ms - :connection-timeout timeout-ms - :throw-exceptions false - :cookie-policy :none - :redirect-strategy :none})] - (if (<= 200 status 299) - body - (throw (ex-info "siteverify non-2xx" {:status status}))))) - -;; A sustained outage would otherwise log a line per signup. -(def ^:private log-window-ms 60000) -(def ^:private last-logged (atom 0)) - -(defn- warn-unreachable! [reason] - (let [now (System/currentTimeMillis) - [before _] (swap-vals! last-logged #(if (> (- now %) log-window-ms) now %))] - (when (> (- now before) log-window-ms) - ;; Reason is an exception class name or HTTP status: never the secret or the token. - (println "turnstile: siteverify unreachable, letting signup through -" reason)))) - -(defn verify - "Checks a Turnstile `token` for `remote-ip`. Returns :pass, :fail, or :unreachable (the caller - treats :unreachable as a pass). A blank token is :fail without calling Cloudflare." - [token remote-ip] - (if (s/blank? token) - :fail - (try - (let [result (post-siteverify token remote-ip)] - (if (true? (:success result)) :pass :fail)) - (catch Exception e - (warn-unreachable! (if-let [st (:status (ex-data e))] - (str "HTTP " st) - (.. e getClass getSimpleName))) - :unreachable)))) diff --git a/test/clj/orcpub/security_test.clj b/test/clj/orcpub/security_test.clj index 52fb46acd..4fbfd7ab3 100644 --- a/test/clj/orcpub/security_test.clj +++ b/test/clj/orcpub/security_test.clj @@ -1,8 +1,18 @@ (ns orcpub.security-test - (:require [clojure.test :refer [deftest is testing]] + (:require [clojure.string :as str] + [clojure.test :refer [deftest is testing use-fixtures]] + [datomic.api :as d] + [orcpub.config :as config] + [orcpub.email :as email] + [orcpub.errors :as errors] + [orcpub.pedestal :as pedestal] + [orcpub.pwned :as pwned] + [orcpub.routes :as routes] [orcpub.time :as time :refer [seconds minutes hours millis ago now]] [orcpub.security :as s] - [clojure.set :as sets])) + [orcpub.db.schema :as schema] + [clojure.set :as sets]) + (:import [java.util UUID])) ;; Convenience wrappers for tests - these take n and return an Instant n units ago (defn seconds-ago [n] (-> n seconds ago)) @@ -296,3 +306,126 @@ (s/absorb-password-changes! {} 8000) (is (false? (s/token-withdrawn? "wash" 6000)) "and expired entries still drop out") (s/restore-password-changes! {})) + +;; ---- Cloudflare Turnstile on the sign-up form (moved from turnstile_test.clj) ---- +;; Off unless both keys are set, fails open when Cloudflare is unreachable, refuses only on an +;; explicit failure, and a refused attempt does not use up the host's signup allowance. +;; No test reaches the network. + +(use-fixtures :each + (fn [f] + (reset! @#'s/sightings {}) + (with-redefs [email/configured? (constantly true) + pwned/check (constantly 0)] + (binding [errors/*error-prefix* "TEST_ERROR:"] + (f))) + (reset! @#'s/sightings {}))) + +(def ^:private secret "s3cr3t-turnstile-value-9f2c") + +(defn- fresh-conn [] + (let [uri (str "datomic:mem:turnstile-test-" (UUID/randomUUID))] + (d/create-database uri) + (let [conn (d/connect uri)] + @(d/transact conn schema/all-schemas) + conn))) + +(defn- request [conn token] + {:conn conn :db (d/db conn) :scheme :https :headers {"host" "example.test"} + :remote-addr "7.7.7.7" + :json-params (cond-> {:username "newcomer" :email "newcomer@test.com" + :verify-email "newcomer@test.com" + :password "hunter2hunter2" :send-updates? false} + token (assoc :turnstile-token token))}) + +(defn- user-exists? [conn] + (some? (d/q '[:find ?e . :where [?e :orcpub.user/username "newcomer"]] (d/db conn)))) + +(defn- host-count [] + (count (get @@#'s/sightings [:register "7.7.7.7"]))) + + +(deftest disabled-register-works-and-never-calls-cloudflare + (let [conn (fresh-conn) calls (atom 0)] + (with-redefs [s/turnstile-enabled? (constantly false) + s/turnstile-verify (fn [& _] (swap! calls inc) :fail) + s/post-siteverify (fn [& _] (swap! calls inc) (throw (ex-info "no" {})))] + (is (= 200 (:status (routes/register (request conn nil))))) + (is (user-exists? conn)) + (is (zero? @calls) "siteverify is never called")))) + +(deftest enabled-and-passing-creates-the-account + (let [conn (fresh-conn)] + (with-redefs [s/turnstile-enabled? (constantly true) + s/post-siteverify (fn [& _] {:success true})] + (is (= 200 (:status (routes/register (request conn "good-token"))))) + (is (user-exists? conn))))) + +(deftest enabled-and-failing-refuses-without-using-the-host-allowance + (let [conn (fresh-conn)] + (with-redefs [s/turnstile-enabled? (constantly true) + s/post-siteverify (fn [& _] {:success false})] + (let [resp (routes/register (request conn "bad-token"))] + (is (= 400 (:status resp))) + (is (= 1 (count (get-in resp [:body :general]))) "a :general error") + (is (str/includes? (first (get-in resp [:body :general])) "not a bot")) + (is (= [:general] (keys (:body resp))) "no field key") + (is (not (user-exists? conn)) "nothing created") + (is (zero? (host-count)) "the host's allowance is not consumed"))))) + +(deftest enabled-and-unreachable-fails-open + (let [conn (fresh-conn)] + (with-redefs [s/turnstile-enabled? (constantly true) + s/post-siteverify (fn [& _] (throw (java.net.SocketTimeoutException. "slow")))] + (is (= 200 (:status (routes/register (request conn "any-token"))))) + (is (user-exists? conn))))) + +(deftest a-blank-token-fails-without-calling-cloudflare + (let [calls (atom 0)] + (with-redefs [s/post-siteverify (fn [& _] (swap! calls inc) {:success true})] + (doseq [t [nil "" " "]] + (is (= :fail (s/turnstile-verify t "1.2.3.4")))) + (is (zero? @calls) "no HTTP call")) + (testing "and through register, while enabled" + (let [conn (fresh-conn)] + (with-redefs [s/turnstile-enabled? (constantly true) + s/post-siteverify (fn [& _] (swap! calls inc) {:success true})] + (is (= 400 (:status (routes/register (request conn nil))))) + (is (zero? @calls))))))) + +(deftest verify-maps-cloudflare-answers + (with-redefs [s/post-siteverify (fn [& _] {:success true})] + (is (= :pass (s/turnstile-verify "t" "1.2.3.4")))) + (with-redefs [s/post-siteverify (fn [& _] {:success false :error-codes ["x"]})] + (is (= :fail (s/turnstile-verify "t" "1.2.3.4")))) + (with-redefs [s/post-siteverify (fn [& _] (throw (ex-info "siteverify non-2xx" {:status 500})))] + (is (= :unreachable (s/turnstile-verify "t" "1.2.3.4"))))) + +(deftest only-both-keys-enable-it + (doseq [[site secret-key expected] [[nil nil false] ["s" nil false] [nil "k" false] ["s" "k" true]]] + (with-redefs [config/turnstile-site-key (constantly site) + config/turnstile-secret-key (constantly secret-key)] + (is (= expected (s/turnstile-enabled?)))))) + +(defn- frame-src-of [csp-header] + (some #(when (str/starts-with? % "frame-src") %) (str/split csp-header #"; "))) + +(deftest csp-allows-cloudflare-frames-only-when-enabled + (let [leave (:leave (pedestal/make-nonce-interceptor false)) + header (fn [] (get-in (leave {:request {:csp-nonce "n"} :response {:headers {}}}) + [:response :headers "Content-Security-Policy"]))] + (with-redefs [config/turnstile-enabled? (constantly true)] + (is (str/includes? (or (frame-src-of (header)) "") "https://challenges.cloudflare.com"))) + (with-redefs [config/turnstile-enabled? (constantly false)] + (is (not (str/includes? (header) "challenges.cloudflare.com")))))) + +(deftest the-settings-report-never-contains-the-secret + (let [env {"TURNSTILE_SITE_KEY" "1x00000000000000000000AA" "TURNSTILE_SECRET_KEY" secret}] + (with-redefs [config/env-raw (fn [n] (get env n))] + (let [rows (filter #(#{"TURNSTILE_SITE_KEY" "TURNSTILE_SECRET_KEY"} (:var %)) (config/report)) + printed (str/join "\n" (config/report-lines (vec rows)))] + (is (= 2 (count rows))) + (is (not (str/includes? (pr-str rows) secret)) "not in the rows") + (is (not (str/includes? printed secret)) "not in the banner") + (is (str/includes? printed "1x00000000000000000000AA") "the public site key may show") + (is (:set? (first (filter #(= "TURNSTILE_SECRET_KEY" (:var %)) rows)))))))) diff --git a/test/clj/orcpub/turnstile_test.clj b/test/clj/orcpub/turnstile_test.clj deleted file mode 100644 index 8563c3eb7..000000000 --- a/test/clj/orcpub/turnstile_test.clj +++ /dev/null @@ -1,136 +0,0 @@ -(ns orcpub.turnstile-test - "Cloudflare Turnstile on the sign-up form: off unless both keys are set, fails open when - Cloudflare is unreachable, refuses only on an explicit failure, and a refused attempt does - not use up the host's signup allowance. No test reaches the network." - (:require - [clojure.string :as str] - [clojure.test :refer [deftest is testing use-fixtures]] - [datomic.api :as d] - [orcpub.config :as config] - [orcpub.email :as email] - [orcpub.errors :as errors] - [orcpub.pedestal :as pedestal] - [orcpub.pwned :as pwned] - [orcpub.routes :as routes] - [orcpub.security :as security] - [orcpub.turnstile :as turnstile] - [orcpub.db.schema :as schema]) - (:import [java.util UUID])) - -(def ^:private secret "s3cr3t-turnstile-value-9f2c") - -(use-fixtures :each - (fn [f] - (reset! @#'security/sightings {}) - (with-redefs [email/configured? (constantly true) - pwned/check (constantly 0)] - (binding [errors/*error-prefix* "TEST_ERROR:"] - (f))) - (reset! @#'security/sightings {}))) - -(defn- fresh-conn [] - (let [uri (str "datomic:mem:turnstile-test-" (UUID/randomUUID))] - (d/create-database uri) - (let [conn (d/connect uri)] - @(d/transact conn schema/all-schemas) - conn))) - -(defn- request [conn token] - {:conn conn :db (d/db conn) :scheme :https :headers {"host" "example.test"} - :remote-addr "7.7.7.7" - :json-params (cond-> {:username "newcomer" :email "newcomer@test.com" - :verify-email "newcomer@test.com" - :password "hunter2hunter2" :send-updates? false} - token (assoc :turnstile-token token))}) - -(defn- user-exists? [conn] - (some? (d/q '[:find ?e . :where [?e :orcpub.user/username "newcomer"]] (d/db conn)))) - -(defn- host-count [] - (count (get @@#'security/sightings [:register "7.7.7.7"]))) - - -(deftest disabled-register-works-and-never-calls-cloudflare - (let [conn (fresh-conn) calls (atom 0)] - (with-redefs [turnstile/enabled? (constantly false) - turnstile/verify (fn [& _] (swap! calls inc) :fail) - turnstile/post-siteverify (fn [& _] (swap! calls inc) (throw (ex-info "no" {})))] - (is (= 200 (:status (routes/register (request conn nil))))) - (is (user-exists? conn)) - (is (zero? @calls) "siteverify is never called")))) - -(deftest enabled-and-passing-creates-the-account - (let [conn (fresh-conn)] - (with-redefs [turnstile/enabled? (constantly true) - turnstile/post-siteverify (fn [& _] {:success true})] - (is (= 200 (:status (routes/register (request conn "good-token"))))) - (is (user-exists? conn))))) - -(deftest enabled-and-failing-refuses-without-using-the-host-allowance - (let [conn (fresh-conn)] - (with-redefs [turnstile/enabled? (constantly true) - turnstile/post-siteverify (fn [& _] {:success false})] - (let [resp (routes/register (request conn "bad-token"))] - (is (= 400 (:status resp))) - (is (= 1 (count (get-in resp [:body :general]))) "a :general error") - (is (str/includes? (first (get-in resp [:body :general])) "not a bot")) - (is (= [:general] (keys (:body resp))) "no field key") - (is (not (user-exists? conn)) "nothing created") - (is (zero? (host-count)) "the host's allowance is not consumed"))))) - -(deftest enabled-and-unreachable-fails-open - (let [conn (fresh-conn)] - (with-redefs [turnstile/enabled? (constantly true) - turnstile/post-siteverify (fn [& _] (throw (java.net.SocketTimeoutException. "slow")))] - (is (= 200 (:status (routes/register (request conn "any-token"))))) - (is (user-exists? conn))))) - -(deftest a-blank-token-fails-without-calling-cloudflare - (let [calls (atom 0)] - (with-redefs [turnstile/post-siteverify (fn [& _] (swap! calls inc) {:success true})] - (doseq [t [nil "" " "]] - (is (= :fail (turnstile/verify t "1.2.3.4")))) - (is (zero? @calls) "no HTTP call")) - (testing "and through register, while enabled" - (let [conn (fresh-conn)] - (with-redefs [turnstile/enabled? (constantly true) - turnstile/post-siteverify (fn [& _] (swap! calls inc) {:success true})] - (is (= 400 (:status (routes/register (request conn nil))))) - (is (zero? @calls))))))) - -(deftest verify-maps-cloudflare-answers - (with-redefs [turnstile/post-siteverify (fn [& _] {:success true})] - (is (= :pass (turnstile/verify "t" "1.2.3.4")))) - (with-redefs [turnstile/post-siteverify (fn [& _] {:success false :error-codes ["x"]})] - (is (= :fail (turnstile/verify "t" "1.2.3.4")))) - (with-redefs [turnstile/post-siteverify (fn [& _] (throw (ex-info "siteverify non-2xx" {:status 500})))] - (is (= :unreachable (turnstile/verify "t" "1.2.3.4"))))) - -(deftest only-both-keys-enable-it - (doseq [[site secret-key expected] [[nil nil false] ["s" nil false] [nil "k" false] ["s" "k" true]]] - (with-redefs [config/turnstile-site-key (constantly site) - config/turnstile-secret-key (constantly secret-key)] - (is (= expected (turnstile/enabled?)))))) - -(defn- frame-src-of [csp-header] - (some #(when (str/starts-with? % "frame-src") %) (str/split csp-header #"; "))) - -(deftest csp-allows-cloudflare-frames-only-when-enabled - (let [leave (:leave (pedestal/make-nonce-interceptor false)) - header (fn [] (get-in (leave {:request {:csp-nonce "n"} :response {:headers {}}}) - [:response :headers "Content-Security-Policy"]))] - (with-redefs [config/turnstile-enabled? (constantly true)] - (is (str/includes? (or (frame-src-of (header)) "") "https://challenges.cloudflare.com"))) - (with-redefs [config/turnstile-enabled? (constantly false)] - (is (not (str/includes? (header) "challenges.cloudflare.com")))))) - -(deftest the-settings-report-never-contains-the-secret - (let [env {"TURNSTILE_SITE_KEY" "1x00000000000000000000AA" "TURNSTILE_SECRET_KEY" secret}] - (with-redefs [config/env-raw (fn [n] (get env n))] - (let [rows (filter #(#{"TURNSTILE_SITE_KEY" "TURNSTILE_SECRET_KEY"} (:var %)) (config/report)) - printed (str/join "\n" (config/report-lines (vec rows)))] - (is (= 2 (count rows))) - (is (not (str/includes? (pr-str rows) secret)) "not in the rows") - (is (not (str/includes? printed secret)) "not in the banner") - (is (str/includes? printed "1x00000000000000000000AA") "the public site key may show") - (is (:set? (first (filter #(= "TURNSTILE_SECRET_KEY" (:var %)) rows)))))))) From 1e1070013cc521897dc5a6fcfb2a48fffa0d56fb Mon Sep 17 00:00:00 2001 From: codeGlaze Date: Wed, 4 Nov 2026 03:55:40 +0000 Subject: [PATCH 05/27] Move the account and sign-in handlers out of routes into routes.auth --- dev/user.clj | 11 +- src/clj/orcpub/routes.clj | 893 +----------------- src/clj/orcpub/routes/auth.clj | 830 ++++++++++++++++ test/clj/orcpub/artist_accounts_test.clj | 27 +- test/clj/orcpub/artist_credit_test.clj | 10 +- test/clj/orcpub/email_change_test.clj | 49 +- test/clj/orcpub/registration_email_test.clj | 11 +- .../clj/orcpub/registration_no_email_test.clj | 11 +- test/clj/orcpub/routes_test.clj | 119 +-- test/clj/orcpub/security_audit_test.clj | 9 +- test/clj/orcpub/security_test.clj | 11 +- test/clj/orcpub/user_email_test.clj | 17 +- 12 files changed, 1011 insertions(+), 987 deletions(-) create mode 100644 src/clj/orcpub/routes/auth.clj diff --git a/dev/user.clj b/dev/user.clj index bb11611dd..b3ba85b9d 100644 --- a/dev/user.clj +++ b/dev/user.clj @@ -5,6 +5,7 @@ [datomic.api :as datomic] [buddy.hashers :as hashers] [orcpub.routes :as r] + [orcpub.routes.auth :as auth] [orcpub.system :as s] [orcpub.common :as common] [orcpub.server :as server] @@ -125,9 +126,9 @@ since the email never gets sent." [username-or-email] (with-db [conn db] - (let [user (r/find-user-by-username-or-email db username-or-email) + (let [user (auth/find-user-by-username-or-email db username-or-email) verification-key (:orcpub.user/verification-key user)] - (r/verify {:query-params {:key verification-key} + (auth/verify {:query-params {:key verification-key} :conn conn :db db})))) @@ -170,7 +171,7 @@ (let [username "test" email "test@example.com" password "testpass"] - (r/register {:username username :email email :password password :verified true})) + (auth/register {:username username :email email :password password :verified true})) (println "add-test-user is disabled outside dev environment."))) ;; --------------------------------------------------------------------------- @@ -236,7 +237,7 @@ Does not require a running server." [conn username-or-email] (let [db (datomic/db conn) - user (r/find-user-by-username-or-email db username-or-email)] + user (auth/find-user-by-username-or-email db username-or-email)] (if-not user (throw (ex-info "User not found" {:username-or-email username-or-email})) @(datomic/transact conn [[:db/add (:db/id user) :orcpub.user/verified? true]])))) @@ -245,7 +246,7 @@ "Remove a user entity by username or email. Dev only." [conn username-or-email] (let [db (datomic/db conn) - user (r/find-user-by-username-or-email db username-or-email)] + user (auth/find-user-by-username-or-email db username-or-email)] (if-not user (throw (ex-info "User not found" {:username-or-email username-or-email})) @(datomic/transact conn [[:db/retractEntity (:db/id user)]])))) diff --git a/src/clj/orcpub/routes.clj b/src/clj/orcpub/routes.clj index f303802fa..2105b08af 100644 --- a/src/clj/orcpub/routes.clj +++ b/src/clj/orcpub/routes.clj @@ -1,6 +1,5 @@ (ns orcpub.routes (:require [io.pedestal.http :as http] - [orcpub.artist-accounts :as artist-accounts] [orcpub.bounded-cache :as bounded-cache] [cheshire.core :as cheshire] [orcpub.work-pool :as work-pool] @@ -19,11 +18,10 @@ [buddy.auth.protocols :as proto] [buddy.auth.backends :as backends] [buddy.sign.jwt :as jwt] - [buddy.hashers :as hashers] [buddy.auth.middleware :refer [authentication-request]] [clojure.edn :as edn] [clojure.java.io :as io] - [orcpub.time :as time :refer [hours ago from-now instant before?]] + [orcpub.time :as time] [clojure.string :as s] [clojure.spec.alpha :as spec] [clojure.pprint] @@ -44,14 +42,12 @@ [orcpub.privacy :as privacy] [orcpub.config :as config] [orcpub.email :as email] - [orcpub.outbox :as outbox] [orcpub.loading-spinner :as spinner] [orcpub.index :refer [index-page]] [orcpub.pdf :as pdf] [orcpub.pdf.draw :as draw] [orcpub.pdf.cards :as cards] [orcpub.portrait-render :as portrait-render] - [orcpub.reset-key :as reset-key] [orcpub.portrait-pack.strands :as strands] [orcpub.dnd.e5.portrait-effects :as portrait-fx] [orcpub.artist-credit :as artist-credit] @@ -60,19 +56,15 @@ [orcpub.crypto :as crypto] [orcpub.spellbook :as spellbook] [orcpub.dnd.e5.emblems :as emblems] - [orcpub.registration :as registration] - [orcpub.pwned :as pwned] [orcpub.entity.strict :as se] [orcpub.entity :as entity] [orcpub.security :as security] - [orcpub.user-email :as user-email] [orcpub.fork.branding :as branding] - [orcpub.fork.auth :as auth] - [orcpub.fork.user-data :as user-data] + [orcpub.fork.auth :as fork-auth] + [orcpub.routes.auth :as auth] [orcpub.routes.party :as party] [orcpub.routes.folder :as folder] [orcpub.routes.share :as share] - [orcpub.datomic :as odb] [hiccup.page :as page] [hiccup2.core :as h] [orcpub.env :as env] @@ -89,101 +81,7 @@ (deftype FixedBuffer [^long len]) -(def ^:private jwt-secret - "JWT signing secret: /run/secrets/signature, else SIGNATURE (config/signature), nil when unset - or blank. Never read the environment directly here, or a Docker-secrets deployment gets nil. - Blank must be nil: buddy signs and verifies with \"\", so an empty SIGNATURE= accepted forged - tokens. docs/kb/blank-env-values.md." - (config/signature)) - -(when-not jwt-secret - (println (str "WARNING: " config/signature-missing-message))) - -(defn- signature-or-throw - "The JWT secret, or an error that says how to fix it. - - The token-minting paths used to read the env var straight into jwt/sign, which fails deep - inside the library with nothing an operator can act on. check-auth already answered a - clear 500; these did not." - [] - (or jwt-secret - (throw (ex-info config/signature-missing-message {:error :signature-not-set})))) - -(def backend (backends/jws {:secret jwt-secret})) - -(defn first-user-by [db query value] - (let [result (d/q query - db - value) - user-id (ffirst result)] - (d/pull db '[*] user-id))) - -(def username-query - '[:find ?e - :in $ ?username - :where [?e :orcpub.user/username ?username]]) - -;; Email lookup by the indexed key, or the stored address when it equals the key: registration has -;; long stored addresses lowercased, so those match while the start-up backfill has yet to reach -;; them (orcpub.user-email). Callers pass (user-email/email-key address). -(def email-query - '[:find ?e - :in $ ?email - :where (or-join [?e ?email] - [?e :orcpub.user/email-key ?email] - [?e :orcpub.user/email ?email])]) - -(defn find-user-by-username-or-email - "The account, pulled whole, whose username is `username-or-email` or whose email matches it in - any casing; nil when none does." - [db username-or-email] - (d/q - '[:find (pull ?e [*]) . - :in $ ?name ?key - :where (or-join [?e ?name ?key] - [?e :orcpub.user/username ?name] - [?e :orcpub.user/email-key ?key] - [?e :orcpub.user/email ?key])] - db - username-or-email - (or (user-email/email-key username-or-email) ""))) - -(defn find-user-by-username [db username] - (d/q '[:find (pull ?e [*]) . - :in $ ?username - :where [?e :orcpub.user/username ?username]] - db - username)) - -(defn lookup-user-by-username [db username password] - (let [user (d/q '[:find (pull ?e [*]) . - :in $ [?username ?password] - :where - [?e :orcpub.user/username ?username] - [?e :orcpub.user/password ?enc] - [(buddy.hashers/check ?password ?enc)]] - db - [username password])] - user)) - -(defn lookup-user-by-email - "The account, pulled whole, whose email matches `email` in any casing and whose password is - `password`; without a :db/id when none does." - [db email password] - (first-user-by db - '{:find [?e] - :in [$ [?email ?password]] - :where [(or-join [?e ?email] - [?e :orcpub.user/email-key ?email] - [?e :orcpub.user/email ?email]) - [?e :orcpub.user/password ?enc] - [(buddy.hashers/check ?password ?enc)]]} - [(user-email/email-key email) password])) - -(defn lookup-user [db username password] - (if (re-matches registration/email-format username) - (lookup-user-by-email db username password) - (lookup-user-by-username db username password))) +(def backend (backends/jws {:secret auth/jwt-secret})) (defn terminate-request [context status message] (-> context @@ -197,7 +95,7 @@ (interceptor/interceptor {:name :check-auth :enter (fn [context] - (if-not jwt-secret + (if-not auth/jwt-secret ;; The full remedy, not just the symptom: whoever sees this 500 in a log is ;; the person who can fix it. (terminate-request context 500 @@ -237,7 +135,7 @@ grants an attacker with a session nothing -- they can sign themselves out." [{:keys [conn db identity] :as _request}] (let [username (:user identity) - {:keys [:db/id]} (when username (first-user-by db username-query username))] + {:keys [:db/id]} (when username (auth/first-user-by db auth/username-query username))] (if-not id {:status 400 :body {:error :user-not-found}} (let [now (java.util.Date.)] @@ -265,7 +163,7 @@ lifetime matter, since older ones already expired. See account-flows.md." [db] (let [since (java.util.Date. (- (System/currentTimeMillis) - (* auth/token-lifetime-hours 60 60 1000))) + (* fork-auth/token-lifetime-hours 60 60 1000))) rows (d/q recent-password-changes-query db since)] (security/absorb-password-changes! (reduce (fn [m [username ^java.util.Date changed]] @@ -331,338 +229,8 @@ (= (:user identity) owner) context :else (terminate-request context 401 "You don't own this folder"))))})) -(defn redirect [route-key] - (ring-resp/redirect (route-map/path-for route-key))) - - -(defn verification-expired? [verification-sent] - (before? (instant verification-sent) (-> 24 hours ago))) - -(defn login-error [error-key & [data]] - {:status 401 :body (merge - data - {:error error-key})}) - -(defn create-token [username exp] - ;; :minted, not :iat. buddy validates the registered claims it recognises, and - ;; a standard iat is seconds where this is millis -- naming it apart keeps the - ;; library out of it entirely. - (jwt/sign {:user username - :minted (System/currentTimeMillis) - :exp exp} - (signature-or-throw))) - -(defn following-usernames [db ids] - (map :orcpub.user/username - (d/pull-many db '[:orcpub.user/username] ids))) - -(defn artist-credit-body - "What the account page needs to show an artist their credit." - [db user-id] - (when-let [{:keys [artist-id default current own locked]} (artist-credit/credit-for-account db user-id)] - {:artist-id (name artist-id) - :default default - :current (select-keys current (into [:artist/id :artist/name :artist/link :artist/links] - (vals artist-credit/page-switches))) - :own own - :locked locked - ;; so the page can show which icon a link will get as it's typed - :services (for [[icon {:keys [label color hosts]}] artist-credit/services] - {:icon icon :label label :color color :hosts (vec hosts)}) - :max-links artist-credit/max-links})) - (def max-preferred-name-length 40) -(defn user-body - "Build the user API response. Core fields are inline; fork-specific - fields (e.g. tier data) are added by user-data/enrich-response." - [db user] - (cond-> (user-data/enrich-response - {:username (:orcpub.user/username user) - :email (:orcpub.user/email user) - :send-updates? (boolean (:orcpub.user/send-updates? user)) - :following (following-usernames db (map :db/id (:orcpub.user/following user)))} - user) - (:orcpub.user/pending-email user) - (assoc :pending-email (:orcpub.user/pending-email user)) - - ;; whether this deployment can store one at all (it needs a key) - true - (assoc :preferred-name-enabled? (crypto/enabled?)) - - (:orcpub.user/preferred-name user) - (assoc :preferred-name (crypto/decrypt crypto/preferred-name-purpose - (:orcpub.user/preferred-name user))) - - (:orcpub.user/artist user) - (assoc :artist-credit (artist-credit-body db (:db/id user))) - - (some? (:orcpub.user/dark-button-text? user)) - (assoc :dark-button-text? (:orcpub.user/dark-button-text? user)))) - -(defn base-url [{:keys [scheme headers]}] - (str (or (headers "x-forwarded-proto") (name scheme)) "://" (headers "host"))) - -(defn bad-credentials-response [db username ip request] - (security/add-failed-login-attempt! username ip) - (if (security/too-many-attempts-for-username? username) - (do (security/note-refusal! :login-username) - (login-error errors/too-many-attempts)) - (let [user-for-username (find-user-by-username-or-email db username)] - ;; A name with no account is not logged: it is sometimes a password typed in the wrong box. - (security/audit! :sign-in-failed request (:orcpub.user/username user-for-username)) - ;; Several addresses failing against ONE account inside a minute is also what - ;; a person with a phone, a laptop and a tablet looks like -- so it notifies - ;; the owner rather than locking them out. Runs on another thread, and its - ;; outcome never reaches the response: failing logins must not learn a thing. - (when (and (:db/id user-for-username) - (security/multiple-ip-attempts-to-same-account? username) - (security/claim-sign-in-notice! username)) - (future - (try - (outbox/enqueue! (:conn request) :sign-in-attempts - (email/sign-in-attempts-message - (base-url request) - {:email (:orcpub.user/email user-for-username) - :first-and-last-name (:orcpub.user/first-and-last-name user-for-username) - :user-agent (get (:headers request) "user-agent")})) - (catch Exception e - (println "ERROR: could not queue a sign-in attempts notice:" (.getMessage e)))))) - ;; One answer for both. Telling somebody the username does not exist made - ;; the login form the same membership test the reset endpoint was, and a - ;; cheaper one, since it needs no mail to be sent. - (login-error errors/bad-credentials)))) - -(defn create-login-response [db conn user id & [headers]] - (let [token (create-token (:orcpub.user/username user) - (-> auth/token-lifetime-hours hours from-now)) - now (java.util.Date.)] - (when auth/track-last-login? - (d/transact conn [{:db/id id - :orcpub.user/last-login now}])) - {:status 200 - :headers headers - :body {:user-data (user-body db user) - :token token}})) - -(defn login-response - [{:keys [json-params db conn remote-addr] :as request}] - (let [{raw-username :username raw-password :password} json-params] - (cond - (s/blank? raw-username) (login-error errors/username-required) - (s/blank? raw-password) (login-error errors/password-required) - - ;; Checked before the credentials, not on the failure path: stuffing ends on - ;; the one account it guesses right, so a check that only runs after a failed - ;; lookup would never see that attempt. Trips on five DISTINCT usernames - ;; failing from this address inside a minute -- one person on several devices can't, a spray across accounts can. - (security/multiple-account-access? remote-addr) - (do (security/note-refusal! :login-spray) - (login-error errors/too-many-attempts)) - - :else (let [username (s/trim raw-username) - password (s/trim raw-password) - {:keys [:orcpub.user/verified? - :orcpub.user/verification-sent - :orcpub.user/email - :db/id] :as user} (lookup-user db username password) - unverified? (not verified?) - expired? (and verification-sent (verification-expired? verification-sent))] - (cond - (nil? id) (bad-credentials-response db username remote-addr request) - (and unverified? expired?) (login-error errors/unverified-expired) - unverified? (login-error errors/unverified {:email email}) - :else - (do (security/audit! :sign-in request (:orcpub.user/username user)) - (create-login-response db conn user id))))))) - -(defn login [request] - (login-response request)) - - -(defn user-for-email - "The account, pulled whole, whose email matches `email` in any casing; without a :db/id when none - does." - [db email] - (first-user-by db - '{:find [?e] - :in [$ ?email] - :where [(or-join [?e ?email] - [?e :orcpub.user/email-key ?email] - [?e :orcpub.user/email ?email])]} - (user-email/email-key email))) - -(defn preferred-name-of - "The name an email greets the account by: its preferred name, decrypted, else the fork's - fallback, else its username." - [user] - (or (crypto/decrypt crypto/preferred-name-purpose (:orcpub.user/preferred-name user)) - auth/verification-display-name - (:orcpub.user/username user))) - - -(defn do-verification - "Creates or refreshes a pending verification and queues its email in the same transaction - (orcpub.outbox), so the account and the email are saved together or not at all; the outbox - sends it and retries while the mail server is down. `params` is the user map, `tx-data` the - account attributes (an existing {:db/id} for a resend). Returns the response map. - Tests: registration_email_test.clj. docs/email-system.md mirrors this flow; change both." - [request params conn & [tx-data]] - (cond - ;; No SMTP and no ALLOW_UNVERIFIED_REGISTRATION: fail closed. A typo'd or empty mount must - ;; not quietly turn the site into open registration. - (and (not (email/configured?)) - (not (email/unverified-registration-allowed?))) - (do - (println "ERROR: registration unavailable — EMAIL_SERVER_URL is unset, so no" - "verification email can be sent. Set it, or set" - "ALLOW_UNVERIFIED_REGISTRATION=true to accept accounts without" - "verifying the address.") - ;; A response, not a throw. A throw reaches the client as a bare 500 it - ;; cannot tell apart from any other failure, so the form showed nothing. - {:status 503 :body {:error :email-not-configured}}) - - ;; Deliberately running without email: verify on the spot rather than - ;; promising a mail that cannot be sent. The operator of a mail-less - ;; instance is handing out the accounts themselves, so address ownership is - ;; not being proved by anyone anyway. - (not (email/configured?)) - (do - (println "INFO: EMAIL_SERVER_URL is unset — verifying" (:username params) - "on creation instead of sending a verification email.") - (try - @(d/transact conn [(merge tx-data {:orcpub.user/verified? true})]) - ;; The client branches on this to show "registration complete, you can - ;; log in" rather than "check your email". - {:status 200 :body {:verified? true}} - (catch Exception e - (println "ERROR: Failed to create account:" (.getMessage e)) - (throw (ex-info "Unable to complete registration. Please try again or contact support." - {:error :verification-failed} - e))))) - :else - (let [verification-key (str (java.util.UUID/randomUUID)) - existing-id (:db/id tx-data)] - (try - @(d/transact - conn - [(merge - tx-data - {:db/id (or existing-id "verification-subject") - :orcpub.user/verified? false - :orcpub.user/verification-key verification-key - :orcpub.user/verification-sent (java.util.Date.)}) - (outbox/email-tx :verification - (email/verification-message (base-url request) params verification-key))]) - (catch Exception e - (println "ERROR: Failed to create verification record:" (.getMessage e)) - (throw (ex-info "Unable to complete registration. Please try again or contact support." - {:error :verification-failed} - e)))) - (outbox/sent!) - {:status 200}))) - -(defn- breach-message - "Why this reads as a strength verdict, not a security warning: the corpus - measures commonness, not a breach or an attacker targeting this person. - GOTCHA: speaks like the strength meter under the \"Too common\" badge, so it - must not repeat what the badge already said. See account-flows.md." - [_n] - "A few words strung together are harder to guess and easier to remember.") - -(def ^:private breach-refusal-threshold - "How many corpus appearances make a password common enough to refuse. - GOTCHA: below this line it's advisory only, surfaced by the strength meter - while typing; at or above, refusal at submit is reserved for the egregious - case -- one appearance is an old leak, four figures ships in every cracking - wordlist. See account-flows.md." - 1000) - -(defn- breach-errors - "A validation map for an egregiously common password, or nil. - - Only a positive answer counts, and only one at or above the threshold: an - unreachable service must read as no objection, and nor must a handful of - appearances." - [password] - (let [result (pwned/check password)] - (when (and (number? result) (>= result breach-refusal-threshold)) - ;; Its OWN key, not :password: a strength verdict, not a rule fault, so it - ;; belongs to the meter -- the only thing on the page judging password quality. - ;; Keyed with the rule faults instead, it would render as a red field error - ;; sitting right above a meter reporting UNCOMMON in green: two disagreeing verdicts. - {:password-common [(breach-message result)]}))) - -(def ^:private registration-throttled-message - (str "Too many accounts have been created from this connection in the last hour. " - "Try again a little later, or email us if you are stuck.")) - -(def ^:private turnstile-failed-message - "We couldn't confirm you're not a bot. Please try the check again.") - -(defn register [{:keys [json-params db conn remote-addr] :as request}] - (let [{:keys [username email password send-updates?]} json-params - username (when username (s/trim username)) - email (user-email/email-key email) - password (when password (s/trim password)) - validation (registration/validate-registration - json-params - (seq (d/q email-query db email)) - (seq (d/q username-query db username))) - now (java.util.Date.) - ;; Checked only once the form is otherwise valid: no reason to ask a third - ;; party about a password attached to a malformed signup. - validation (if (seq validation) - validation - (or (breach-errors password) validation)) - ;; Before the host allowance, so a bot that fails the challenge does not use up the - ;; host's signups. After validation and the breach check, so a form that was going to - ;; be rejected anyway never costs a verification. :unreachable is a pass (fail open). - ;; :general for the same reason as the throttle below. - validation (if (and (empty? validation) - (security/turnstile-enabled?) - (= :fail (security/turnstile-verify (:turnstile-token json-params) remote-addr))) - (assoc validation :general [turnstile-failed-message]) - validation) - ;; Checked last, so a form that was going to be rejected anyway is not - ;; counted against the host. :general rather than a field key: nobody - ;; can edit their way past a rate limit, so it must not sit in the map - ;; that disables the button. - validation (if (or (seq validation) (security/registration-allowed? remote-addr)) - validation - (assoc validation :general [registration-throttled-message]))] - (if (seq validation) - {:status 400 - :body validation} - (let [response (do-verification - request - json-params - conn - (merge - {:orcpub.user/username username - :orcpub.user/password (hashers/encrypt password) - :orcpub.user/send-updates? send-updates? - :orcpub.user/created now} - (user-email/email-attrs email) - (when auth/record-last-login-at-registration? - {:orcpub.user/last-login now}) - (user-data/registration-defaults)))] - (when (= 200 (:status response)) (security/audit! :registered request username)) - response)))) - -(def user-for-verification-key-query - '[:find ?e - :in $ ?key - :where [?e :orcpub.user/verification-key ?key]]) - -(def user-for-email-query - '[:find ?e - :in $ ?email - :where [?e :orcpub.user/email ?email]]) - -(defn user-for-verification-key [db key] - (first-user-by db user-for-verification-key-query key)) - (defn user-id-for-username [db username] (d/q '[:find ?e . @@ -671,81 +239,6 @@ db username)) -(defn- link-artist-on-confirm! - "A confirmed account just confirmed a new address. If it is an artist's configured - account, link it. Never lets a failure here fail the confirmation itself." - [conn id] - (try (artist-accounts/on-email-confirmed! conn id (artist-accounts/configured) artist-accounts/notify) - (catch Exception e - (println "artist-accounts: link on confirmation failed -" (.getMessage e))))) - -(defn verify [{:keys [query-params db conn] :as request}] - (if-let [key (:key query-params)] - (let [{:keys [:orcpub.user/verification-sent - :orcpub.user/verified? - :orcpub.user/username - :orcpub.user/pending-email - :db/id] :as user} (user-for-verification-key (d/db conn) key)] - (if username - (cond - (and verified? (nil? pending-email)) - (redirect route-map/verify-success-route) - - (or (nil? verification-sent) - (verification-expired? verification-sent)) - ;; Clean up stale pending state so user can request a fresh change - (do (let [retractions (cond-> [[:db/retract id :orcpub.user/verification-key key] - [:db/retract id :orcpub.user/verification-sent verification-sent]] - pending-email - (conj [:db/retract id :orcpub.user/pending-email pending-email]))] - @(d/transact conn retractions)) - (redirect route-map/verify-failed-route)) - - pending-email - ;; Guard: re-check that the target email hasn't been claimed since request. - ;; All paths retract verification-key and verification-sent to prevent - ;; link reuse and avoid stale rate-limit data. - (if (seq (d/q email-query (d/db conn) (user-email/email-key pending-email))) - (do @(d/transact conn [[:db/retract id :orcpub.user/pending-email pending-email] - [:db/retract id :orcpub.user/verification-key key] - [:db/retract id :orcpub.user/verification-sent verification-sent]]) - (redirect route-map/verify-failed-route)) - (do @(d/transact conn [(assoc (user-email/email-attrs pending-email) :db/id id) - [:db/retract id :orcpub.user/pending-email pending-email] - [:db/retract id :orcpub.user/verification-key key] - [:db/retract id :orcpub.user/verification-sent verification-sent]]) - (link-artist-on-confirm! conn id) - (security/audit! :email-change-confirmed request username) - (redirect route-map/verify-success-route))) - - ;; No artist link here: whoever registered chose the password, and confirming - ;; proves only the address (artist-accounts claims such accounts instead). - :else - (do @(d/transact conn [{:db/id id - :orcpub.user/verified? true}]) - (redirect route-map/verify-success-route))) - {:status 400})) - {:status 400})) - -(defn re-verify [{:keys [query-params db conn remote-addr] :as request}] - (let [email (:email query-params) - {:keys [:orcpub.user/verification-sent - :orcpub.user/verified? - :db/id] :as user} (user-for-email db email)] - (cond - verified? (redirect route-map/verify-success-route) - ;; No account for this address: answer like a resend and create nothing. Passing - ;; {:db/id nil} on would register a key-only record and email a link to any address typed. - (nil? id) {:status 200} - ;; Over the limit: the same answer as an unknown address, so the limit is not a membership oracle. - (not (security/reverify-email-allowed? email remote-addr)) {:status 200} - :else - (do-verification request - (merge query-params - {:first-and-last-name (preferred-name-of user)}) - conn - {:db/id id})))) - ;; ─── Email Preferences ───────────────────────────────────────────── (defn unsubscribe-token @@ -753,7 +246,7 @@ Stateless — no DB storage needed. Verified by checking JWT signature." [email] (jwt/sign {:email (common/ascii-lower-case email) :action "unsubscribe"} - (signature-or-throw))) + (auth/signature-or-throw))) (defn unsubscribe "GET handler for /unsubscribe?token=. @@ -764,13 +257,13 @@ (if (s/blank? token) {:status 400 :body "Missing token"} (try - (let [{:keys [email action]} (jwt/unsign token (signature-or-throw))] + (let [{:keys [email action]} (jwt/unsign token (auth/signature-or-throw))] (if (not= "unsubscribe" action) {:status 400 :body "Invalid token"} - (let [{:keys [:db/id]} (user-for-email (d/db conn) email)] + (let [{:keys [:db/id]} (auth/user-for-email (d/db conn) email)] (if id (do @(d/transact conn [{:db/id id :orcpub.user/send-updates? false}]) - (redirect route-map/unsubscribe-success-route)) + (auth/redirect route-map/unsubscribe-success-route)) {:status 400 :body "Unknown email"})))) (catch Exception _ {:status 400 :body "Invalid or tampered token"}))))) @@ -781,7 +274,7 @@ Re-reads from DB after transact to return authoritative state." [{:keys [transit-params db conn identity]}] (let [username (:user identity) - {:keys [:db/id]} (find-user-by-username db username)] + {:keys [:db/id]} (auth/find-user-by-username db username)] (if id (let [pn (when (contains? transit-params :preferred-name) (some-> (:preferred-name transit-params) str s/trim (s/replace #"\s+" " ")))] @@ -822,7 +315,7 @@ account has saved artist-credit/save-cap changes in the hour. A notice that cannot be recorded is logged and the saved change still answers 200." [{:keys [transit-params db conn identity]}] - (let [user (find-user-by-username db (:user identity)) + (let [user (auth/find-user-by-username db (:user identity)) id (:db/id user)] (if-not id {:status 400 :body {:error "User not found"}} @@ -835,191 +328,12 @@ :body {:error (let [m (max 1 (quot (+ wait 59) 60))] (str "That's a lot of changes for one hour. Try again in " m (if (= 1 m) " minute." " minutes.")))}} - unchanged {:status 200 :body (artist-credit-body (d/db conn) id)} + unchanged {:status 200 :body (auth/artist-credit-body (d/db conn) id)} :else (do (try (credit-notices/saved! conn {:artist-id artist-id :user user :before before :after saved}) (catch Exception e (println "ERROR: artist credit saved, but its notice could not be recorded:" (.getMessage e)))) - {:status 200 :body (artist-credit-body (d/db conn) id)})))))) - -(defn hash-reset-key - "What goes in the database for a reset key: see orcpub.reset-key, shared with - the artist welcome link." - [key] - (reset-key/digest key)) - -;; Two hours. One is the usual choice and is a one-line change here; two leaves -;; room for mail that takes a while to arrive and for somebody who reads it on -;; the way home, on a site whose worst case is a character sheet. -(def password-reset-valid-hours 2) - -(defn- notice-tx - "Transaction data queuing the email `build` returns (a function of no arguments) as `kind`, or - nil when building it fails, which is logged. For notices that must never cost the change they - report on." - [kind build] - (try (outbox/email-tx kind (build)) - (catch Exception e - (println "ERROR: could not build a" (name kind) "email; the change goes ahead without it:" - (.getMessage e)) - nil))) - -(defn do-send-password-reset [user-id email conn request] - (let [key (str (java.util.UUID/randomUUID))] - (try - @(d/transact - conn - (cond-> [{:db/id user-id - :orcpub.user/password-reset-key (hash-reset-key key) - :orcpub.user/password-reset-sent (java.util.Date.)} - (outbox/email-tx :password-reset - (email/reset-message - (base-url request) - {:first-and-last-name (preferred-name-of (d/entity (d/db conn) user-id)) - :email email} - key))] - ;; a fresh ordinary reset replaces a week-long welcome link, so it - ;; must not inherit that link's expiry - (:orcpub.user/password-reset-expires (d/entity (d/db conn) user-id)) - (conj [:db/retract user-id :orcpub.user/password-reset-expires - (:orcpub.user/password-reset-expires (d/entity (d/db conn) user-id))]))) - (outbox/sent!) - {:status 200} - (catch Exception e - (println "ERROR: Failed to initiate password reset for user" user-id ":" (.getMessage e)) - (throw (ex-info "Unable to initiate password reset. Please try again or contact support." - {:error :password-reset-failed - :user-id user-id} - e)))))) - -(defn password-reset-expired? [password-reset-sent] - (and password-reset-sent - (before? (instant password-reset-sent) (-> password-reset-valid-hours hours ago)))) - -(defn reset-link-expired? - "Whether a reset link is past its expiry: its own expiry when it has one - (the artist welcome link lasts a week), otherwise the usual two hours." - [{:keys [:orcpub.user/password-reset-sent :orcpub.user/password-reset-expires]}] - (if password-reset-expires - (.after (java.util.Date.) password-reset-expires) - (password-reset-expired? password-reset-sent))) - -(defn password-already-reset? [password-reset password-reset-sent] - (and password-reset (before? (instant password-reset-sent) (instant password-reset)))) - -(defn send-password-reset [{:keys [query-params db conn remote-addr] :as request}] - (let [email (:email query-params) - {:keys [:db/id]} (user-for-email db email)] - ;; The answer is identical whether or not that address has an account: - ;; confirmed-valid addresses are precisely what a stuffing run needs. - ;; The per-address limit is checked AFTER the lookup but never changes the - ;; response -- a limit that visibly altered it would itself be a membership oracle, which the uniform 200 closes. - (when (and id (security/reset-email-allowed? email remote-addr)) - (try - (do-send-password-reset id email conn request) - (security/audit! :password-reset-requested request - (:orcpub.user/username (d/entity db id))) - (catch Exception e - ;; Swallowed on purpose. Letting this escape would restore the oracle - ;; in a subtler form -- only a real account can fail to be emailed, - ;; so an error response would mark the address as registered. - (println "ERROR: password reset for a known address could not be sent:" - (.getMessage e))))) - {:status 200})) - -(def reset-link-spent-message - "This reset link has expired or has already been used. Request a new one from the login page.") - -(defn do-password-reset [conn user-id password & [request user]] - (try - @(d/transact - conn - (cond-> [{:db/id user-id - :orcpub.user/password (hashers/encrypt (s/trim password)) - :orcpub.user/verified? true} - ;; Conditional on the reset this request read (nil: none yet), so of two submits of - ;; one link racing, the second fails instead of also setting a password. - [:db/cas user-id :orcpub.user/password-reset - (:orcpub.user/password-reset user) (java.util.Date.)]] - ;; The link is spent with the password it set, in the same transaction. - (:orcpub.user/password-reset-key user) - (conj [:db/retract user-id :orcpub.user/password-reset-key - (:orcpub.user/password-reset-key user)]) - ;; The notice goes with the change: it is the only sign an unauthorised reset leaves. - (and request (:orcpub.user/email user)) - (conj (notice-tx :password-changed - #(email/password-changed-message - (base-url request) - {:email (:orcpub.user/email user) - :first-and-last-name (:orcpub.user/first-and-last-name user) - :user-agent (get (:headers request) "user-agent")}))) - true (->> (remove nil?)))) - (outbox/sent!) - ;; Before anything else that can fail: every token minted before now is no - ;; longer good for this account, including the one this very request is - ;; using. That is the point -- a reset is how somebody takes their account - ;; back, and leaving the intruder's session alive would defeat it. - (when-let [username (:orcpub.user/username user)] - (security/note-password-changed! username) - (when request (security/audit! :password-reset request username))) - {:status 200} - (catch Exception e - (if (odb/cas-failed? e) - {:status 400 :body {:general [reset-link-spent-message]}} - (do (println "ERROR: Failed to reset password for user" user-id ":" (.getMessage e)) - (throw (ex-info "Unable to reset password. Please try again or contact support." - {:error :password-update-failed - :user-id user-id} - e))))))) - -(declare user-by-password-reset-key-query) - -(defn reset-password - "Set a new password with the key from a reset link. The key is the only authority: opening - the link grants no session, and the key is checked here, at submit, then retired." - [{:keys [json-params db conn] :as request}] - (try - (let [{:keys [password verify-password]} json-params - ;; Trimmed before anything judges it, because do-password-reset stores it - ;; trimmed and the corpus lookup hashes it: an untrimmed check asks about - ;; a different string from the one saved. - password (some-> password s/trim) - verify-password (some-> verify-password s/trim) - reset-key (:key json-params) - {:keys [:db/id :orcpub.user/username :orcpub.user/email - :orcpub.user/password-reset-sent :orcpub.user/password-reset] :as user} - (when-not (s/blank? reset-key) - (first-user-by db user-by-password-reset-key-query (hash-reset-key reset-key))) - usable? (and id - ;; a welcome link carries its own, longer expiry - (not (reset-link-expired? user)) - (not (password-already-reset? password-reset password-reset-sent))) - ;; The username is known here, even though this page never shows it, - ;; so a password that IS the username can be refused the way - ;; registration already refuses one. Without the context this was the - ;; one rule the two paths did not share. - context {:username username :email email} - rule-errors (registration/validate-password password context) - ;; Asked once. Only reached when the password is otherwise acceptable, - ;; so a rejected reset never costs a call. - breached (when (and usable? (= password verify-password) (empty? rule-errors)) - (first (:password-common (breach-errors password))))] - ;; Field-keyed, in :body, the same shape registration answers with. - ;; :message is not a Pedestal response key: these came back as a 400 with - ;; an EMPTY body, so the reasons never left the server and the page had - ;; nothing to show but a generic apology. - (cond - ;; Missing, unknown, expired and used are one answer: this link no longer works. - (not usable?) - {:status 400 :body {:general [reset-link-spent-message]}} - - (not= password verify-password) - {:status 400 :body {:verify-password ["Passwords do not match"]}} - - (seq rule-errors) {:status 400 :body rule-errors} - breached {:status 400 :body {:password-common [breached]}} - :else (do-password-reset conn id password request user))) - (catch Throwable t (prn t) (throw t)))) + {:status 200 :body (auth/artist-credit-body (d/db conn) id)})))))) (def font-sizes (merge @@ -1769,11 +1083,6 @@ :headers {"Content-Type" "text/html"}})] merged)) -(def user-by-password-reset-key-query - '[:find ?e - :in $ ?key - :where [?e :orcpub.user/password-reset-key ?key]]) - (def default-title branding/default-page-title) (def default-description branding/app-tagline) @@ -1817,38 +1126,25 @@ :orcpub.user/password-reset] :as user} ;; The link carries the key; the table holds only its digest. (when-not (s/blank? key) - (first-user-by db user-by-password-reset-key-query (hash-reset-key key))) - expired? (reset-link-expired? user) - already-reset? (password-already-reset? password-reset password-reset-sent)] + (auth/first-user-by db auth/user-by-password-reset-key-query (auth/hash-reset-key key))) + expired? (auth/reset-link-expired? user) + already-reset? (auth/password-already-reset? password-reset password-reset-sent)] (cond ;; Covers both no key at all and a key matching nobody, so neither bare-strings ;; a "Key is required" error nor falls through to :else and signs a token for ;; a nil username. A mangled link and an expired one are the same event to the ;; reader -- it doesn't work -- so both land on the page offering to send a new one. - (nil? id) (redirect route-map/password-reset-expired-route) - expired? (redirect route-map/password-reset-expired-route) - already-reset? (redirect route-map/password-reset-used-route) + (nil? id) (auth/redirect route-map/password-reset-expired-route) + expired? (auth/redirect route-map/password-reset-expired-route) + already-reset? (auth/redirect route-map/password-reset-used-route) ;; No session: the key in the URL is what the form submits. The username cookie grants ;; nothing; it lets the meter flag a password equal to it. no-referrer keeps the key out of ;; the Referer of anything this page loads. :else (index req {:headers {"Referrer-Policy" "no-referrer"} :cookies {"reset-username" {:value username :path "/" - :max-age (* password-reset-valid-hours 3600) + :max-age (* auth/password-reset-valid-hours 3600) :same-site :strict}}})))) -(defn check-field [query value db] - {:status 200 - :body (-> (d/q query db value) - seq - boolean - str)}) - -(defn check-username [{:keys [db query-params]}] - (check-field username-query (:username query-params) db)) - -(defn check-email [{:keys [db query-params]}] - (check-field email-query (user-email/email-key (:email query-params)) db)) - (defn character-for-id [db id] (d/pull db '[*] id)) @@ -1926,7 +1222,7 @@ (create-entity conn username without-empty-fields owner-prop)))) (defn owns-entity? [db username entity-id] - (let [user (find-user-by-username db username) + (let [user (auth/find-user-by-username db username) username (:orcpub.user/username user) email (:orcpub.user/email user) entity (d/pull db '[:orcpub.entity.strict/owner] entity-id) @@ -2112,7 +1408,7 @@ (defn character-list [{:keys [db identity] :as request}] (let [username (:user identity) - user (find-user-by-username-or-email db username) + user (auth/find-user-by-username-or-email db username) ids (d/q '[:find ?e :in $ [?idents ...] :where @@ -2125,9 +1421,9 @@ (defn character-summary-list [{:keys [db body conn identity] :as request}] (let [username (:user identity) - user (find-user-by-username-or-email db username) + user (auth/find-user-by-username-or-email db username) following-ids (map :db/id (:orcpub.user/following user)) - following-usernames (following-usernames db following-ids) + following-usernames (auth/following-usernames db following-ids) results (d/q '[:find (pull ?e [:db/id ::se/summary ::se/owner]) @@ -2205,7 +1501,7 @@ login token carried whatever the user typed (e3cdf5f to cf170fc), so characters saved then name their owner by email address; this read needs no login, so the address must not go out." [db owner] - (if-let [user (find-user-by-username-or-email db owner)] + (if-let [user (auth/find-user-by-username-or-email db owner)] (:orcpub.user/username user) (when-not (s/includes? owner "@") owner))) @@ -2263,7 +1559,7 @@ {:sent? .. :reason ..} so the client can fall back to the copyable report." [{:keys [db transit-params identity]}] (let [username (:user identity) - user (find-user-by-username-or-email db username) + user (auth/find-user-by-username-or-email db username) user-email (:orcpub.user/email user) {:keys [char-id error raw]} transit-params] {:status 200 @@ -2272,8 +1568,8 @@ (defn get-user [{:keys [db identity]}] (let [username (:user identity) - user (find-user-by-username-or-email db username)] - {:status 200 :body (user-body db user)})) + user (auth/find-user-by-username-or-email db username)] + {:status 200 :body (auth/user-body db user)})) (defn delete-user "Deletes the authenticated user's account and logs it. Returns 200. @@ -2292,117 +1588,6 @@ (security/audit! :account-deleted request username) {:status 200}))) -(defn rate-limit-remaining-secs - "Seconds until the user can act again. In the 0–1 min zone (email in transit) - returns time until the 1-min resend window opens. In the 1–5 min zone (for a - different email) returns time until the 5-min cooldown expires." - [verification-sent new-email pending-email] - (when verification-sent - (let [elapsed-ms (- (System/currentTimeMillis) (.getTime ^java.util.Date verification-sent)) - ;; If same email, they're waiting for the 1-min resend window to open. - ;; If different email, they're waiting for the full 5-min cooldown. - target-ms (if (= new-email pending-email) - (* 1 60 1000) - (* 5 60 1000)) - remaining-ms (- target-ms elapsed-ms)] - (when (pos? remaining-ms) - (int (Math/ceil (/ remaining-ms 1000.0))))))) - -(defn email-change-rate-limited? [verification-sent pending-email new-email] - ;; Only rate-limits a pending email change, not registration verification. - ;; From verification-sent: 0–1 min always blocked (email in transit); 1–5 min only a - ;; resend to the same email is allowed; 5+ min open. - (and pending-email - verification-sent - (let [elapsed-ms (- (System/currentTimeMillis) (.getTime ^java.util.Date verification-sent)) - same-email? (= new-email pending-email)] - (cond - (>= elapsed-ms (* 5 60 1000)) false ;; past cooldown - (< elapsed-ms (* 1 60 1000)) true ;; too soon - :else (not same-email?)))) ;; 1-5 min: resend ok, new email blocked - ) - -(defn request-email-change [{:keys [transit-params db conn identity] :as request}] - (try - ;; Client sends {:new-email "..."} (confirm-email is validated client-side only) - (let [new-email (or (user-email/email-key (:new-email transit-params)) "") - current-password (:current-password transit-params) - username (:user identity)] - (if (nil? username) - {:status 400 :body {:error :user-not-found}} - (let [{:keys [:db/id - :orcpub.user/email - :orcpub.user/pending-email - :orcpub.user/verification-sent] :as user} (find-user-by-username db username)] - (cond - (nil? id) - {:status 400 :body {:error :user-not-found}} - - ;; Re-authentication: moving an account to another address takes it away - ;; from whoever holds this one, requiring more than just a session -- a - ;; borrowed or forgotten session alone must not be enough to walk off with - ;; the account. The password is compared, never read: lookup-user does the hash check. - (nil? (:db/id (lookup-user db username (str current-password)))) - {:status 400 :body {:error :bad-credentials}} - - (registration/bad-email? new-email) - {:status 400 :body {:error :invalid-email}} - - (= new-email (user-email/email-key email)) - {:status 400 :body {:error :same-as-current}} - - (email-change-rate-limited? verification-sent pending-email new-email) - {:status 429 :body {:error :too-many-requests - :retry-after-secs (rate-limit-remaining-secs verification-sent new-email pending-email)}} - - ;; Check no other account already owns this email - (seq (d/q email-query db new-email)) - {:status 400 :body {:error :email-taken}} - - ;; Free resend: same email, 1–5 min after original send. Re-send with - ;; existing key and don't update verification-sent (no rolling window). - (and (= new-email pending-email) - verification-sent - (let [elapsed (- (System/currentTimeMillis) (.getTime ^java.util.Date verification-sent))] - (and (>= elapsed (* 1 60 1000)) - (< elapsed (* 5 60 1000))))) - (try - (outbox/enqueue! conn :email-change-verification - (email/email-change-verification-message - (base-url request) - {:email new-email :username username - :preferred-name (preferred-name-of user)} - (:orcpub.user/verification-key user))) - {:status 200 :body {:pending-email new-email}} - (catch Throwable e - (prn "Email resend could not be queued:" (.getMessage e)) - {:status 500 :body {:error :email-send-failed}})) - - :else - (let [verification-key (str (java.util.UUID/randomUUID)) - now (java.util.Date.)] - ;; The verification goes to the NEW address, unreachable by the owner if this - ;; wasn't them, so the notice to the current address goes in the same transaction. - @(d/transact conn (remove nil? [{:db/id id - :orcpub.user/pending-email new-email - :orcpub.user/verification-key verification-key - :orcpub.user/verification-sent now} - (outbox/email-tx :email-change-verification - (email/email-change-verification-message - (base-url request) - {:email new-email :username username - :preferred-name (preferred-name-of user)} - verification-key)) - (notice-tx :email-change-notice - #(email/email-change-notice-message - {:email email - :first-and-last-name (:orcpub.user/first-and-last-name user) - :new-email new-email}))])) - (outbox/sent!) - (security/audit! :email-change-requested request username) - {:status 200 :body {:pending-email new-email}}))))) - (catch Throwable e (prn e) (throw e)))) - (defn character-summary-description [{:keys [::char5e/race-name ::char5e/subrace-name ::char5e/classes]}] (str race-name " " @@ -2810,13 +1995,13 @@ ["/image/*" {:get `get-image}] ["/favicon/*" {:get `get-favicon}] [(route-map/path-for route-map/register-route) - {:post `register}] + {:post `auth/register}] [(route-map/path-for route-map/user-route) ^:interceptors [check-auth] {:get `get-user :put `update-user-preferences :delete `delete-user}] [(route-map/path-for route-map/user-email-route) ^:interceptors [check-auth] - {:put `request-email-change}] + {:put `auth/request-email-change}] [(route-map/path-for route-map/user-artist-credit-route) ^:interceptors [check-auth] {:put `update-artist-credit}] [(route-map/path-for route-map/user-sessions-route) ^:interceptors [check-auth] @@ -2890,23 +2075,23 @@ [(route-map/path-for route-map/dnd-e5-char-folder-character-route :id ":id" :character-id ":character-id") ^:interceptors [check-auth parse-id check-folder-owner] {:delete `folder/remove-character}] [(route-map/path-for route-map/login-route) - {:post `login}] + {:post `auth/login}] [(route-map/path-for route-map/character-pdf-route) {:post `character-pdf-2}] [(route-map/path-for route-map/image-probe-route) {:post `image-probe}] [(route-map/path-for route-map/verify-route) - {:get `verify}] + {:get `auth/verify}] [(route-map/path-for route-map/re-verify-route) - {:get `re-verify}] + {:get `auth/re-verify}] [(route-map/path-for route-map/unsubscribe-route) {:get `unsubscribe}] [(route-map/path-for route-map/reset-password-route) ^:interceptors [ring/cookies] - {:post `reset-password}] + {:post `auth/reset-password}] [(route-map/path-for route-map/reset-password-page-route) ^:interceptors [ring/cookies] {:get `reset-password-page}] [(route-map/path-for route-map/send-password-reset-route) - {:get `send-password-reset}] + {:get `auth/send-password-reset}] [(route-map/path-for route-map/privacy-policy-route) {:get `privacy-policy-page}] [(route-map/path-for route-map/terms-of-use-route) @@ -2916,9 +2101,9 @@ [(route-map/path-for route-map/cookies-policy-route) {:get `cookie-policy-page}] [(route-map/path-for route-map/check-email-route) - {:get `check-email}] + {:get `auth/check-email}] [(route-map/path-for route-map/check-username-route) - {:get `check-username}] + {:get `auth/check-username}] ["/health" {:get `health-check}]]]]) expanded-index-routes)) diff --git a/src/clj/orcpub/routes/auth.clj b/src/clj/orcpub/routes/auth.clj new file mode 100644 index 000000000..f88e6fee0 --- /dev/null +++ b/src/clj/orcpub/routes/auth.clj @@ -0,0 +1,830 @@ +(ns orcpub.routes.auth + "HTTP handlers for accounts: sign-up, verification, login, password reset, email change and the + user lookups, queries and messages they share. Moved out of orcpub.routes, which requires this + namespace; this one never requires it." + (:require [buddy.hashers :as hashers] + [buddy.sign.jwt :as jwt] + [clojure.string :as s] + [datomic.api :as d] + [orcpub.artist-accounts :as artist-accounts] + [orcpub.artist-credit :as artist-credit] + [orcpub.config :as config] + [orcpub.crypto :as crypto] + [orcpub.datomic :as odb] + [orcpub.email :as email] + [orcpub.errors :as errors] + [orcpub.fork.auth :as fork-auth] + [orcpub.fork.user-data :as user-data] + [orcpub.outbox :as outbox] + [orcpub.pwned :as pwned] + [orcpub.registration :as registration] + [orcpub.reset-key :as reset-key] + [orcpub.route-map :as route-map] + [orcpub.security :as security] + [orcpub.time :as time :refer [hours ago from-now instant before?]] + [orcpub.user-email :as user-email] + [ring.util.response :as ring-resp])) + +(def jwt-secret + "JWT signing secret: /run/secrets/signature, else SIGNATURE (config/signature), nil when unset + or blank. Never read the environment directly here, or a Docker-secrets deployment gets nil. + Blank must be nil: buddy signs and verifies with \"\", so an empty SIGNATURE= accepted forged + tokens. docs/kb/blank-env-values.md." + (config/signature)) + +(when-not jwt-secret + (println (str "WARNING: " config/signature-missing-message))) + +(defn signature-or-throw + "The JWT secret, or an error that says how to fix it. + + The token-minting paths used to read the env var straight into jwt/sign, which fails deep + inside the library with nothing an operator can act on. check-auth already answered a + clear 500; these did not." + [] + (or jwt-secret + (throw (ex-info config/signature-missing-message {:error :signature-not-set})))) + +(defn first-user-by [db query value] + (let [result (d/q query + db + value) + user-id (ffirst result)] + (d/pull db '[*] user-id))) + +(def username-query + '[:find ?e + :in $ ?username + :where [?e :orcpub.user/username ?username]]) + +;; Email lookup by the indexed key, or the stored address when it equals the key: registration has +;; long stored addresses lowercased, so those match while the start-up backfill has yet to reach +;; them (orcpub.user-email). Callers pass (user-email/email-key address). +(def email-query + '[:find ?e + :in $ ?email + :where (or-join [?e ?email] + [?e :orcpub.user/email-key ?email] + [?e :orcpub.user/email ?email])]) + +(defn find-user-by-username-or-email + "The account, pulled whole, whose username is `username-or-email` or whose email matches it in + any casing; nil when none does." + [db username-or-email] + (d/q + '[:find (pull ?e [*]) . + :in $ ?name ?key + :where (or-join [?e ?name ?key] + [?e :orcpub.user/username ?name] + [?e :orcpub.user/email-key ?key] + [?e :orcpub.user/email ?key])] + db + username-or-email + (or (user-email/email-key username-or-email) ""))) + +(defn find-user-by-username [db username] + (d/q '[:find (pull ?e [*]) . + :in $ ?username + :where [?e :orcpub.user/username ?username]] + db + username)) + +(defn lookup-user-by-username [db username password] + (let [user (d/q '[:find (pull ?e [*]) . + :in $ [?username ?password] + :where + [?e :orcpub.user/username ?username] + [?e :orcpub.user/password ?enc] + [(buddy.hashers/check ?password ?enc)]] + db + [username password])] + user)) + +(defn lookup-user-by-email + "The account, pulled whole, whose email matches `email` in any casing and whose password is + `password`; without a :db/id when none does." + [db email password] + (first-user-by db + '{:find [?e] + :in [$ [?email ?password]] + :where [(or-join [?e ?email] + [?e :orcpub.user/email-key ?email] + [?e :orcpub.user/email ?email]) + [?e :orcpub.user/password ?enc] + [(buddy.hashers/check ?password ?enc)]]} + [(user-email/email-key email) password])) + +(defn lookup-user [db username password] + (if (re-matches registration/email-format username) + (lookup-user-by-email db username password) + (lookup-user-by-username db username password))) + +(defn redirect [route-key] + (ring-resp/redirect (route-map/path-for route-key))) + +(defn verification-expired? [verification-sent] + (before? (instant verification-sent) (-> 24 hours ago))) + +(defn login-error [error-key & [data]] + {:status 401 :body (merge + data + {:error error-key})}) + +(defn create-token [username exp] + ;; :minted, not :iat. buddy validates the registered claims it recognises, and + ;; a standard iat is seconds where this is millis -- naming it apart keeps the + ;; library out of it entirely. + (jwt/sign {:user username + :minted (System/currentTimeMillis) + :exp exp} + (signature-or-throw))) + +(defn following-usernames [db ids] + (map :orcpub.user/username + (d/pull-many db '[:orcpub.user/username] ids))) + +(defn artist-credit-body + "What the account page needs to show an artist their credit." + [db user-id] + (when-let [{:keys [artist-id default current own locked]} (artist-credit/credit-for-account db user-id)] + {:artist-id (name artist-id) + :default default + :current (select-keys current (into [:artist/id :artist/name :artist/link :artist/links] + (vals artist-credit/page-switches))) + :own own + :locked locked + ;; so the page can show which icon a link will get as it's typed + :services (for [[icon {:keys [label color hosts]}] artist-credit/services] + {:icon icon :label label :color color :hosts (vec hosts)}) + :max-links artist-credit/max-links})) + +(defn user-body + "Build the user API response. Core fields are inline; fork-specific + fields (e.g. tier data) are added by user-data/enrich-response." + [db user] + (cond-> (user-data/enrich-response + {:username (:orcpub.user/username user) + :email (:orcpub.user/email user) + :send-updates? (boolean (:orcpub.user/send-updates? user)) + :following (following-usernames db (map :db/id (:orcpub.user/following user)))} + user) + (:orcpub.user/pending-email user) + (assoc :pending-email (:orcpub.user/pending-email user)) + + ;; whether this deployment can store one at all (it needs a key) + true + (assoc :preferred-name-enabled? (crypto/enabled?)) + + (:orcpub.user/preferred-name user) + (assoc :preferred-name (crypto/decrypt crypto/preferred-name-purpose + (:orcpub.user/preferred-name user))) + + (:orcpub.user/artist user) + (assoc :artist-credit (artist-credit-body db (:db/id user))) + + (some? (:orcpub.user/dark-button-text? user)) + (assoc :dark-button-text? (:orcpub.user/dark-button-text? user)))) + +(defn base-url [{:keys [scheme headers]}] + (str (or (headers "x-forwarded-proto") (name scheme)) "://" (headers "host"))) + +(defn bad-credentials-response [db username ip request] + (security/add-failed-login-attempt! username ip) + (if (security/too-many-attempts-for-username? username) + (do (security/note-refusal! :login-username) + (login-error errors/too-many-attempts)) + (let [user-for-username (find-user-by-username-or-email db username)] + ;; A name with no account is not logged: it is sometimes a password typed in the wrong box. + (security/audit! :sign-in-failed request (:orcpub.user/username user-for-username)) + ;; Several addresses failing against ONE account inside a minute is also what + ;; a person with a phone, a laptop and a tablet looks like -- so it notifies + ;; the owner rather than locking them out. Runs on another thread, and its + ;; outcome never reaches the response: failing logins must not learn a thing. + (when (and (:db/id user-for-username) + (security/multiple-ip-attempts-to-same-account? username) + (security/claim-sign-in-notice! username)) + (future + (try + (outbox/enqueue! (:conn request) :sign-in-attempts + (email/sign-in-attempts-message + (base-url request) + {:email (:orcpub.user/email user-for-username) + :first-and-last-name (:orcpub.user/first-and-last-name user-for-username) + :user-agent (get (:headers request) "user-agent")})) + (catch Exception e + (println "ERROR: could not queue a sign-in attempts notice:" (.getMessage e)))))) + ;; One answer for both. Telling somebody the username does not exist made + ;; the login form the same membership test the reset endpoint was, and a + ;; cheaper one, since it needs no mail to be sent. + (login-error errors/bad-credentials)))) + +(defn create-login-response [db conn user id & [headers]] + (let [token (create-token (:orcpub.user/username user) + (-> fork-auth/token-lifetime-hours hours from-now)) + now (java.util.Date.)] + (when fork-auth/track-last-login? + (d/transact conn [{:db/id id + :orcpub.user/last-login now}])) + {:status 200 + :headers headers + :body {:user-data (user-body db user) + :token token}})) + +(defn login-response + [{:keys [json-params db conn remote-addr] :as request}] + (let [{raw-username :username raw-password :password} json-params] + (cond + (s/blank? raw-username) (login-error errors/username-required) + (s/blank? raw-password) (login-error errors/password-required) + + ;; Checked before the credentials, not on the failure path: stuffing ends on + ;; the one account it guesses right, so a check that only runs after a failed + ;; lookup would never see that attempt. Trips on five DISTINCT usernames + ;; failing from this address inside a minute -- one person on several devices can't, a spray across accounts can. + (security/multiple-account-access? remote-addr) + (do (security/note-refusal! :login-spray) + (login-error errors/too-many-attempts)) + + :else (let [username (s/trim raw-username) + password (s/trim raw-password) + {:keys [:orcpub.user/verified? + :orcpub.user/verification-sent + :orcpub.user/email + :db/id] :as user} (lookup-user db username password) + unverified? (not verified?) + expired? (and verification-sent (verification-expired? verification-sent))] + (cond + (nil? id) (bad-credentials-response db username remote-addr request) + (and unverified? expired?) (login-error errors/unverified-expired) + unverified? (login-error errors/unverified {:email email}) + :else + (do (security/audit! :sign-in request (:orcpub.user/username user)) + (create-login-response db conn user id))))))) + +(defn login [request] + (login-response request)) + +(defn user-for-email + "The account, pulled whole, whose email matches `email` in any casing; without a :db/id when none + does." + [db email] + (first-user-by db + '{:find [?e] + :in [$ ?email] + :where [(or-join [?e ?email] + [?e :orcpub.user/email-key ?email] + [?e :orcpub.user/email ?email])]} + (user-email/email-key email))) + +(defn preferred-name-of + "The name an email greets the account by: its preferred name, decrypted, else the fork's + fallback, else its username." + [user] + (or (crypto/decrypt crypto/preferred-name-purpose (:orcpub.user/preferred-name user)) + fork-auth/verification-display-name + (:orcpub.user/username user))) + +(defn do-verification + "Creates or refreshes a pending verification and queues its email in the same transaction + (orcpub.outbox), so the account and the email are saved together or not at all; the outbox + sends it and retries while the mail server is down. `params` is the user map, `tx-data` the + account attributes (an existing {:db/id} for a resend). Returns the response map. + Tests: registration_email_test.clj. docs/email-system.md mirrors this flow; change both." + [request params conn & [tx-data]] + (cond + ;; No SMTP and no ALLOW_UNVERIFIED_REGISTRATION: fail closed. A typo'd or empty mount must + ;; not quietly turn the site into open registration. + (and (not (email/configured?)) + (not (email/unverified-registration-allowed?))) + (do + (println "ERROR: registration unavailable — EMAIL_SERVER_URL is unset, so no" + "verification email can be sent. Set it, or set" + "ALLOW_UNVERIFIED_REGISTRATION=true to accept accounts without" + "verifying the address.") + ;; A response, not a throw. A throw reaches the client as a bare 500 it + ;; cannot tell apart from any other failure, so the form showed nothing. + {:status 503 :body {:error :email-not-configured}}) + + ;; Deliberately running without email: verify on the spot rather than + ;; promising a mail that cannot be sent. The operator of a mail-less + ;; instance is handing out the accounts themselves, so address ownership is + ;; not being proved by anyone anyway. + (not (email/configured?)) + (do + (println "INFO: EMAIL_SERVER_URL is unset — verifying" (:username params) + "on creation instead of sending a verification email.") + (try + @(d/transact conn [(merge tx-data {:orcpub.user/verified? true})]) + ;; The client branches on this to show "registration complete, you can + ;; log in" rather than "check your email". + {:status 200 :body {:verified? true}} + (catch Exception e + (println "ERROR: Failed to create account:" (.getMessage e)) + (throw (ex-info "Unable to complete registration. Please try again or contact support." + {:error :verification-failed} + e))))) + :else + (let [verification-key (str (java.util.UUID/randomUUID)) + existing-id (:db/id tx-data)] + (try + @(d/transact + conn + [(merge + tx-data + {:db/id (or existing-id "verification-subject") + :orcpub.user/verified? false + :orcpub.user/verification-key verification-key + :orcpub.user/verification-sent (java.util.Date.)}) + (outbox/email-tx :verification + (email/verification-message (base-url request) params verification-key))]) + (catch Exception e + (println "ERROR: Failed to create verification record:" (.getMessage e)) + (throw (ex-info "Unable to complete registration. Please try again or contact support." + {:error :verification-failed} + e)))) + (outbox/sent!) + {:status 200}))) + +(defn- breach-message + "Why this reads as a strength verdict, not a security warning: the corpus + measures commonness, not a breach or an attacker targeting this person. + GOTCHA: speaks like the strength meter under the \"Too common\" badge, so it + must not repeat what the badge already said. See account-flows.md." + [_n] + "A few words strung together are harder to guess and easier to remember.") + +(def ^:private breach-refusal-threshold + "How many corpus appearances make a password common enough to refuse. + GOTCHA: below this line it's advisory only, surfaced by the strength meter + while typing; at or above, refusal at submit is reserved for the egregious + case -- one appearance is an old leak, four figures ships in every cracking + wordlist. See account-flows.md." + 1000) + +(defn- breach-errors + "A validation map for an egregiously common password, or nil. + + Only a positive answer counts, and only one at or above the threshold: an + unreachable service must read as no objection, and nor must a handful of + appearances." + [password] + (let [result (pwned/check password)] + (when (and (number? result) (>= result breach-refusal-threshold)) + ;; Its OWN key, not :password: a strength verdict, not a rule fault, so it + ;; belongs to the meter -- the only thing on the page judging password quality. + ;; Keyed with the rule faults instead, it would render as a red field error + ;; sitting right above a meter reporting UNCOMMON in green: two disagreeing verdicts. + {:password-common [(breach-message result)]}))) + +(def ^:private registration-throttled-message + (str "Too many accounts have been created from this connection in the last hour. " + "Try again a little later, or email us if you are stuck.")) + +(def ^:private turnstile-failed-message + "We couldn't confirm you're not a bot. Please try the check again.") + +(defn register [{:keys [json-params db conn remote-addr] :as request}] + (let [{:keys [username email password send-updates?]} json-params + username (when username (s/trim username)) + email (user-email/email-key email) + password (when password (s/trim password)) + validation (registration/validate-registration + json-params + (seq (d/q email-query db email)) + (seq (d/q username-query db username))) + now (java.util.Date.) + ;; Checked only once the form is otherwise valid: no reason to ask a third + ;; party about a password attached to a malformed signup. + validation (if (seq validation) + validation + (or (breach-errors password) validation)) + ;; Before the host allowance, so a bot that fails the challenge does not use up the + ;; host's signups. After validation and the breach check, so a form that was going to + ;; be rejected anyway never costs a verification. :unreachable is a pass (fail open). + ;; :general for the same reason as the throttle below. + validation (if (and (empty? validation) + (security/turnstile-enabled?) + (= :fail (security/turnstile-verify (:turnstile-token json-params) remote-addr))) + (assoc validation :general [turnstile-failed-message]) + validation) + ;; Checked last, so a form that was going to be rejected anyway is not + ;; counted against the host. :general rather than a field key: nobody + ;; can edit their way past a rate limit, so it must not sit in the map + ;; that disables the button. + validation (if (or (seq validation) (security/registration-allowed? remote-addr)) + validation + (assoc validation :general [registration-throttled-message]))] + (if (seq validation) + {:status 400 + :body validation} + (let [response (do-verification + request + json-params + conn + (merge + {:orcpub.user/username username + :orcpub.user/password (hashers/encrypt password) + :orcpub.user/send-updates? send-updates? + :orcpub.user/created now} + (user-email/email-attrs email) + (when fork-auth/record-last-login-at-registration? + {:orcpub.user/last-login now}) + (user-data/registration-defaults)))] + (when (= 200 (:status response)) (security/audit! :registered request username)) + response)))) + +(def user-for-verification-key-query + '[:find ?e + :in $ ?key + :where [?e :orcpub.user/verification-key ?key]]) + +(def user-for-email-query + '[:find ?e + :in $ ?email + :where [?e :orcpub.user/email ?email]]) + +(defn user-for-verification-key [db key] + (first-user-by db user-for-verification-key-query key)) + +(defn- link-artist-on-confirm! + "A confirmed account just confirmed a new address. If it is an artist's configured + account, link it. Never lets a failure here fail the confirmation itself." + [conn id] + (try (artist-accounts/on-email-confirmed! conn id (artist-accounts/configured) artist-accounts/notify) + (catch Exception e + (println "artist-accounts: link on confirmation failed -" (.getMessage e))))) + +(defn verify [{:keys [query-params db conn] :as request}] + (if-let [key (:key query-params)] + (let [{:keys [:orcpub.user/verification-sent + :orcpub.user/verified? + :orcpub.user/username + :orcpub.user/pending-email + :db/id] :as user} (user-for-verification-key (d/db conn) key)] + (if username + (cond + (and verified? (nil? pending-email)) + (redirect route-map/verify-success-route) + + (or (nil? verification-sent) + (verification-expired? verification-sent)) + ;; Clean up stale pending state so user can request a fresh change + (do (let [retractions (cond-> [[:db/retract id :orcpub.user/verification-key key] + [:db/retract id :orcpub.user/verification-sent verification-sent]] + pending-email + (conj [:db/retract id :orcpub.user/pending-email pending-email]))] + @(d/transact conn retractions)) + (redirect route-map/verify-failed-route)) + + pending-email + ;; Guard: re-check that the target email hasn't been claimed since request. + ;; All paths retract verification-key and verification-sent to prevent + ;; link reuse and avoid stale rate-limit data. + (if (seq (d/q email-query (d/db conn) (user-email/email-key pending-email))) + (do @(d/transact conn [[:db/retract id :orcpub.user/pending-email pending-email] + [:db/retract id :orcpub.user/verification-key key] + [:db/retract id :orcpub.user/verification-sent verification-sent]]) + (redirect route-map/verify-failed-route)) + (do @(d/transact conn [(assoc (user-email/email-attrs pending-email) :db/id id) + [:db/retract id :orcpub.user/pending-email pending-email] + [:db/retract id :orcpub.user/verification-key key] + [:db/retract id :orcpub.user/verification-sent verification-sent]]) + (link-artist-on-confirm! conn id) + (security/audit! :email-change-confirmed request username) + (redirect route-map/verify-success-route))) + + ;; No artist link here: whoever registered chose the password, and confirming + ;; proves only the address (artist-accounts claims such accounts instead). + :else + (do @(d/transact conn [{:db/id id + :orcpub.user/verified? true}]) + (redirect route-map/verify-success-route))) + {:status 400})) + {:status 400})) + +(defn re-verify [{:keys [query-params db conn remote-addr] :as request}] + (let [email (:email query-params) + {:keys [:orcpub.user/verification-sent + :orcpub.user/verified? + :db/id] :as user} (user-for-email db email)] + (cond + verified? (redirect route-map/verify-success-route) + ;; No account for this address: answer like a resend and create nothing. Passing + ;; {:db/id nil} on would register a key-only record and email a link to any address typed. + (nil? id) {:status 200} + ;; Over the limit: the same answer as an unknown address, so the limit is not a membership oracle. + (not (security/reverify-email-allowed? email remote-addr)) {:status 200} + :else + (do-verification request + (merge query-params + {:first-and-last-name (preferred-name-of user)}) + conn + {:db/id id})))) + +(defn hash-reset-key + "What goes in the database for a reset key: see orcpub.reset-key, shared with + the artist welcome link." + [key] + (reset-key/digest key)) + +;; Two hours. One is the usual choice and is a one-line change here; two leaves +;; room for mail that takes a while to arrive and for somebody who reads it on +;; the way home, on a site whose worst case is a character sheet. +(def password-reset-valid-hours 2) + +(defn- notice-tx + "Transaction data queuing the email `build` returns (a function of no arguments) as `kind`, or + nil when building it fails, which is logged. For notices that must never cost the change they + report on." + [kind build] + (try (outbox/email-tx kind (build)) + (catch Exception e + (println "ERROR: could not build a" (name kind) "email; the change goes ahead without it:" + (.getMessage e)) + nil))) + +(defn do-send-password-reset [user-id email conn request] + (let [key (str (java.util.UUID/randomUUID))] + (try + @(d/transact + conn + (cond-> [{:db/id user-id + :orcpub.user/password-reset-key (hash-reset-key key) + :orcpub.user/password-reset-sent (java.util.Date.)} + (outbox/email-tx :password-reset + (email/reset-message + (base-url request) + {:first-and-last-name (preferred-name-of (d/entity (d/db conn) user-id)) + :email email} + key))] + ;; a fresh ordinary reset replaces a week-long welcome link, so it + ;; must not inherit that link's expiry + (:orcpub.user/password-reset-expires (d/entity (d/db conn) user-id)) + (conj [:db/retract user-id :orcpub.user/password-reset-expires + (:orcpub.user/password-reset-expires (d/entity (d/db conn) user-id))]))) + (outbox/sent!) + {:status 200} + (catch Exception e + (println "ERROR: Failed to initiate password reset for user" user-id ":" (.getMessage e)) + (throw (ex-info "Unable to initiate password reset. Please try again or contact support." + {:error :password-reset-failed + :user-id user-id} + e)))))) + +(defn password-reset-expired? [password-reset-sent] + (and password-reset-sent + (before? (instant password-reset-sent) (-> password-reset-valid-hours hours ago)))) + +(defn reset-link-expired? + "Whether a reset link is past its expiry: its own expiry when it has one + (the artist welcome link lasts a week), otherwise the usual two hours." + [{:keys [:orcpub.user/password-reset-sent :orcpub.user/password-reset-expires]}] + (if password-reset-expires + (.after (java.util.Date.) password-reset-expires) + (password-reset-expired? password-reset-sent))) + +(defn password-already-reset? [password-reset password-reset-sent] + (and password-reset (before? (instant password-reset-sent) (instant password-reset)))) + +(defn send-password-reset [{:keys [query-params db conn remote-addr] :as request}] + (let [email (:email query-params) + {:keys [:db/id]} (user-for-email db email)] + ;; The answer is identical whether or not that address has an account: + ;; confirmed-valid addresses are precisely what a stuffing run needs. + ;; The per-address limit is checked AFTER the lookup but never changes the + ;; response -- a limit that visibly altered it would itself be a membership oracle, which the uniform 200 closes. + (when (and id (security/reset-email-allowed? email remote-addr)) + (try + (do-send-password-reset id email conn request) + (security/audit! :password-reset-requested request + (:orcpub.user/username (d/entity db id))) + (catch Exception e + ;; Swallowed on purpose. Letting this escape would restore the oracle + ;; in a subtler form -- only a real account can fail to be emailed, + ;; so an error response would mark the address as registered. + (println "ERROR: password reset for a known address could not be sent:" + (.getMessage e))))) + {:status 200})) + +(def reset-link-spent-message + "This reset link has expired or has already been used. Request a new one from the login page.") + +(defn do-password-reset [conn user-id password & [request user]] + (try + @(d/transact + conn + (cond-> [{:db/id user-id + :orcpub.user/password (hashers/encrypt (s/trim password)) + :orcpub.user/verified? true} + ;; Conditional on the reset this request read (nil: none yet), so of two submits of + ;; one link racing, the second fails instead of also setting a password. + [:db/cas user-id :orcpub.user/password-reset + (:orcpub.user/password-reset user) (java.util.Date.)]] + ;; The link is spent with the password it set, in the same transaction. + (:orcpub.user/password-reset-key user) + (conj [:db/retract user-id :orcpub.user/password-reset-key + (:orcpub.user/password-reset-key user)]) + ;; The notice goes with the change: it is the only sign an unauthorised reset leaves. + (and request (:orcpub.user/email user)) + (conj (notice-tx :password-changed + #(email/password-changed-message + (base-url request) + {:email (:orcpub.user/email user) + :first-and-last-name (:orcpub.user/first-and-last-name user) + :user-agent (get (:headers request) "user-agent")}))) + true (->> (remove nil?)))) + (outbox/sent!) + ;; Before anything else that can fail: every token minted before now is no + ;; longer good for this account, including the one this very request is + ;; using. That is the point -- a reset is how somebody takes their account + ;; back, and leaving the intruder's session alive would defeat it. + (when-let [username (:orcpub.user/username user)] + (security/note-password-changed! username) + (when request (security/audit! :password-reset request username))) + {:status 200} + (catch Exception e + (if (odb/cas-failed? e) + {:status 400 :body {:general [reset-link-spent-message]}} + (do (println "ERROR: Failed to reset password for user" user-id ":" (.getMessage e)) + (throw (ex-info "Unable to reset password. Please try again or contact support." + {:error :password-update-failed + :user-id user-id} + e))))))) + +(declare user-by-password-reset-key-query) + +(defn reset-password + "Set a new password with the key from a reset link. The key is the only authority: opening + the link grants no session, and the key is checked here, at submit, then retired." + [{:keys [json-params db conn] :as request}] + (try + (let [{:keys [password verify-password]} json-params + ;; Trimmed before anything judges it, because do-password-reset stores it + ;; trimmed and the corpus lookup hashes it: an untrimmed check asks about + ;; a different string from the one saved. + password (some-> password s/trim) + verify-password (some-> verify-password s/trim) + reset-key (:key json-params) + {:keys [:db/id :orcpub.user/username :orcpub.user/email + :orcpub.user/password-reset-sent :orcpub.user/password-reset] :as user} + (when-not (s/blank? reset-key) + (first-user-by db user-by-password-reset-key-query (hash-reset-key reset-key))) + usable? (and id + ;; a welcome link carries its own, longer expiry + (not (reset-link-expired? user)) + (not (password-already-reset? password-reset password-reset-sent))) + ;; The username is known here, even though this page never shows it, + ;; so a password that IS the username can be refused the way + ;; registration already refuses one. Without the context this was the + ;; one rule the two paths did not share. + context {:username username :email email} + rule-errors (registration/validate-password password context) + ;; Asked once. Only reached when the password is otherwise acceptable, + ;; so a rejected reset never costs a call. + breached (when (and usable? (= password verify-password) (empty? rule-errors)) + (first (:password-common (breach-errors password))))] + ;; Field-keyed, in :body, the same shape registration answers with. + ;; :message is not a Pedestal response key: these came back as a 400 with + ;; an EMPTY body, so the reasons never left the server and the page had + ;; nothing to show but a generic apology. + (cond + ;; Missing, unknown, expired and used are one answer: this link no longer works. + (not usable?) + {:status 400 :body {:general [reset-link-spent-message]}} + + (not= password verify-password) + {:status 400 :body {:verify-password ["Passwords do not match"]}} + + (seq rule-errors) {:status 400 :body rule-errors} + breached {:status 400 :body {:password-common [breached]}} + :else (do-password-reset conn id password request user))) + (catch Throwable t (prn t) (throw t)))) + +(def user-by-password-reset-key-query + '[:find ?e + :in $ ?key + :where [?e :orcpub.user/password-reset-key ?key]]) + +(defn check-field [query value db] + {:status 200 + :body (-> (d/q query db value) + seq + boolean + str)}) + +(defn check-username [{:keys [db query-params]}] + (check-field username-query (:username query-params) db)) + +(defn check-email [{:keys [db query-params]}] + (check-field email-query (user-email/email-key (:email query-params)) db)) + +(defn rate-limit-remaining-secs + "Seconds until the user can act again. In the 0–1 min zone (email in transit) + returns time until the 1-min resend window opens. In the 1–5 min zone (for a + different email) returns time until the 5-min cooldown expires." + [verification-sent new-email pending-email] + (when verification-sent + (let [elapsed-ms (- (System/currentTimeMillis) (.getTime ^java.util.Date verification-sent)) + ;; If same email, they're waiting for the 1-min resend window to open. + ;; If different email, they're waiting for the full 5-min cooldown. + target-ms (if (= new-email pending-email) + (* 1 60 1000) + (* 5 60 1000)) + remaining-ms (- target-ms elapsed-ms)] + (when (pos? remaining-ms) + (int (Math/ceil (/ remaining-ms 1000.0))))))) + +(defn email-change-rate-limited? [verification-sent pending-email new-email] + ;; Only rate-limits a pending email change, not registration verification. + ;; From verification-sent: 0–1 min always blocked (email in transit); 1–5 min only a + ;; resend to the same email is allowed; 5+ min open. + (and pending-email + verification-sent + (let [elapsed-ms (- (System/currentTimeMillis) (.getTime ^java.util.Date verification-sent)) + same-email? (= new-email pending-email)] + (cond + (>= elapsed-ms (* 5 60 1000)) false ;; past cooldown + (< elapsed-ms (* 1 60 1000)) true ;; too soon + :else (not same-email?)))) ;; 1-5 min: resend ok, new email blocked + ) + +(defn request-email-change [{:keys [transit-params db conn identity] :as request}] + (try + ;; Client sends {:new-email "..."} (confirm-email is validated client-side only) + (let [new-email (or (user-email/email-key (:new-email transit-params)) "") + current-password (:current-password transit-params) + username (:user identity)] + (if (nil? username) + {:status 400 :body {:error :user-not-found}} + (let [{:keys [:db/id + :orcpub.user/email + :orcpub.user/pending-email + :orcpub.user/verification-sent] :as user} (find-user-by-username db username)] + (cond + (nil? id) + {:status 400 :body {:error :user-not-found}} + + ;; Re-authentication: moving an account to another address takes it away + ;; from whoever holds this one, requiring more than just a session -- a + ;; borrowed or forgotten session alone must not be enough to walk off with + ;; the account. The password is compared, never read: lookup-user does the hash check. + (nil? (:db/id (lookup-user db username (str current-password)))) + {:status 400 :body {:error :bad-credentials}} + + (registration/bad-email? new-email) + {:status 400 :body {:error :invalid-email}} + + (= new-email (user-email/email-key email)) + {:status 400 :body {:error :same-as-current}} + + (email-change-rate-limited? verification-sent pending-email new-email) + {:status 429 :body {:error :too-many-requests + :retry-after-secs (rate-limit-remaining-secs verification-sent new-email pending-email)}} + + ;; Check no other account already owns this email + (seq (d/q email-query db new-email)) + {:status 400 :body {:error :email-taken}} + + ;; Free resend: same email, 1–5 min after original send. Re-send with + ;; existing key and don't update verification-sent (no rolling window). + (and (= new-email pending-email) + verification-sent + (let [elapsed (- (System/currentTimeMillis) (.getTime ^java.util.Date verification-sent))] + (and (>= elapsed (* 1 60 1000)) + (< elapsed (* 5 60 1000))))) + (try + (outbox/enqueue! conn :email-change-verification + (email/email-change-verification-message + (base-url request) + {:email new-email :username username + :preferred-name (preferred-name-of user)} + (:orcpub.user/verification-key user))) + {:status 200 :body {:pending-email new-email}} + (catch Throwable e + (prn "Email resend could not be queued:" (.getMessage e)) + {:status 500 :body {:error :email-send-failed}})) + + :else + (let [verification-key (str (java.util.UUID/randomUUID)) + now (java.util.Date.)] + ;; The verification goes to the NEW address, unreachable by the owner if this + ;; wasn't them, so the notice to the current address goes in the same transaction. + @(d/transact conn (remove nil? [{:db/id id + :orcpub.user/pending-email new-email + :orcpub.user/verification-key verification-key + :orcpub.user/verification-sent now} + (outbox/email-tx :email-change-verification + (email/email-change-verification-message + (base-url request) + {:email new-email :username username + :preferred-name (preferred-name-of user)} + verification-key)) + (notice-tx :email-change-notice + #(email/email-change-notice-message + {:email email + :first-and-last-name (:orcpub.user/first-and-last-name user) + :new-email new-email}))])) + (outbox/sent!) + (security/audit! :email-change-requested request username) + {:status 200 :body {:pending-email new-email}}))))) + (catch Throwable e (prn e) (throw e)))) diff --git a/test/clj/orcpub/artist_accounts_test.clj b/test/clj/orcpub/artist_accounts_test.clj index f32cd7d16..132f928b4 100644 --- a/test/clj/orcpub/artist_accounts_test.clj +++ b/test/clj/orcpub/artist_accounts_test.clj @@ -6,6 +6,7 @@ [orcpub.crypto :as crypto] [orcpub.db.schema :as schema] [orcpub.routes :as routes] + [orcpub.routes.auth :as auth] [orcpub.user-email :as ue]) (:import [java.util UUID Base64 Date])) @@ -114,8 +115,8 @@ (is (not (hashers/check "pw123456" (:orcpub.user/password u))) "the registrant's password is gone") (is (nil? (:orcpub.user/verification-key u)) "and so is their confirmation link") (is (false? (:orcpub.user/verified? u))) - (is (= (:db/id u) (:db/id (routes/first-user-by (d/db conn) routes/user-by-password-reset-key-query - (routes/hash-reset-key (:reset-key (first @sent)))))) + (is (= (:db/id u) (:db/id (auth/first-user-by (d/db conn) auth/user-by-password-reset-key-query + (auth/hash-reset-key (:reset-key (first @sent)))))) "the welcome sent to the address is what opens it") (is (some? (:orcpub.user/artist-welcome-sent u))))) (is (= {:house-pack :already} (aa/reconcile! conn fuss notify))) @@ -133,8 +134,8 @@ (is (= {:house-pack :resent} (aa/reconcile! conn fuss notify)) "the next start tries again") (is (not= (first @tries) (second @tries)) "with a new key, since the first is not kept") (is (= (:db/id (pull-user conn "fusspot")) - (:db/id (routes/first-user-by (d/db conn) routes/user-by-password-reset-key-query - (routes/hash-reset-key (second @tries))))) + (:db/id (auth/first-user-by (d/db conn) auth/user-by-password-reset-key-query + (auth/hash-reset-key (second @tries))))) "and the new key is the one that works") (is (= {:house-pack :already} (aa/reconcile! conn fuss notify)) "once sent, never again") (is (= 2 (count @tries))) @@ -226,12 +227,12 @@ (deftest a-welcome-link-outlasts-an-ordinary-reset (testing "an ordinary reset link still expires after 24 hours" - (is (routes/reset-link-expired? {:orcpub.user/password-reset-sent (days-ago 2)}))) + (is (auth/reset-link-expired? {:orcpub.user/password-reset-sent (days-ago 2)}))) (testing "a welcome link sent two days ago is still good for the rest of its week" - (is (not (routes/reset-link-expired? {:orcpub.user/password-reset-sent (days-ago 2) + (is (not (auth/reset-link-expired? {:orcpub.user/password-reset-sent (days-ago 2) :orcpub.user/password-reset-expires (days-ahead 5)})))) (testing "and does expire at the end of it" - (is (routes/reset-link-expired? {:orcpub.user/password-reset-sent (days-ago 8) + (is (auth/reset-link-expired? {:orcpub.user/password-reset-sent (days-ago 8) :orcpub.user/password-reset-expires (days-ago 1)})))) (deftest a-first-confirmation-does-not-link-the-account @@ -242,7 +243,7 @@ :orcpub.user/verification-key "k-123" :orcpub.user/verification-sent (Date.)}]) (with-redefs [aa/configured (constantly fuss)] - (routes/verify {:query-params {:key "k-123"} :db (d/db conn) :conn conn})) + (auth/verify {:query-params {:key "k-123"} :db (d/db conn) :conn conn})) (is (true? (:orcpub.user/verified? (pull-user conn "fusspotart")))) (is (nil? (artist-of conn "fusspotart"))))))) @@ -254,7 +255,7 @@ :orcpub.user/verification-key "k-456" :orcpub.user/verification-sent (Date.)}]) (with-redefs [aa/configured (constantly fuss)] - (routes/verify {:query-params {:key "k-456"} :db (d/db conn) :conn conn})) + (auth/verify {:query-params {:key "k-456"} :db (d/db conn) :conn conn})) (is (= :house-pack (artist-of conn "fusspotart")))))) (deftest a-welcome-link-works-with-hashed-reset-keys @@ -269,13 +270,13 @@ u (pull-user conn "fusspot")] (is (string? emailed)) (is (not= emailed (:orcpub.user/password-reset-key u)) "the table holds a digest, not the emailed key") - (is (= (:db/id u) (:db/id (routes/first-user-by (d/db conn) routes/user-by-password-reset-key-query - (routes/hash-reset-key emailed)))) + (is (= (:db/id u) (:db/id (auth/first-user-by (d/db conn) auth/user-by-password-reset-key-query + (auth/hash-reset-key emailed)))) "the reset page finds the account from the key in the email") (let [three-hours-ago (Date. (- (System/currentTimeMillis) (* 3 3600 1000))) aged (assoc u :orcpub.user/password-reset-sent three-hours-ago)] - (is (not (routes/reset-link-expired? aged)) "three hours on, past an ordinary link's two, it still works") - (is (routes/reset-link-expired? (dissoc aged :orcpub.user/password-reset-expires)) + (is (not (auth/reset-link-expired? aged)) "three hours on, past an ordinary link's two, it still works") + (is (auth/reset-link-expired? (dissoc aged :orcpub.user/password-reset-expires)) "an ordinary link of the same age has expired")))))) (deftest a-username-keeps-every-letter-whatever-the-locale diff --git a/test/clj/orcpub/artist_credit_test.clj b/test/clj/orcpub/artist_credit_test.clj index a2025aff1..26768b629 100644 --- a/test/clj/orcpub/artist_credit_test.clj +++ b/test/clj/orcpub/artist_credit_test.clj @@ -9,7 +9,7 @@ [orcpub.crypto] [orcpub.artist-email] [orcpub.heartbeat] - [orcpub.routes]) + [orcpub.routes] [orcpub.routes.auth]) (:import [java.util UUID])) (defmacro with-conn [conn-binding & body] @@ -249,7 +249,7 @@ (let [r (orcpub.routes/update-user-preferences (req conn "someone" {:preferred-name " Kaylee "}))] (is (= "Kaylee" (get-in r [:body :preferred-name]))) (is (not= "Kaylee" (:orcpub.user/preferred-name (d/entity (d/db conn) id))) "not readable in the db") - (is (= "Kaylee" (:preferred-name (orcpub.routes/user-body (d/db conn) (d/pull (d/db conn) '[*] id)))))) + (is (= "Kaylee" (:preferred-name (orcpub.routes.auth/user-body (d/db conn) (d/pull (d/db conn) '[*] id)))))) (testing "blank clears it" (orcpub.routes/update-user-preferences (req conn "someone" {:preferred-name ""})) (is (nil? (:orcpub.user/preferred-name (d/entity (d/db conn) id))))) @@ -268,10 +268,10 @@ (with-redefs [orcpub.crypto/configured-keys (constantly test-keys) orcpub.email/reset-message (fn [_ user _] (reset! sent user) {:to (:email user) :subject "reset" :body []})] - (orcpub.routes/do-send-password-reset id "someone@example.test" conn {:headers {"host" "x.test"} :scheme :https}) + (orcpub.routes.auth/do-send-password-reset id "someone@example.test" conn {:headers {"host" "x.test"} :scheme :https}) (is (= "someone" (:first-and-last-name @sent)) "no preferred name yet: greeted by username") (orcpub.routes/update-user-preferences (req conn "someone" {:preferred-name "Kaylee"})) - (orcpub.routes/do-send-password-reset id "someone@example.test" conn {:headers {"host" "x.test"} :scheme :https}) + (orcpub.routes.auth/do-send-password-reset id "someone@example.test" conn {:headers {"host" "x.test"} :scheme :https}) (is (= "Kaylee" (:first-and-last-name @sent))))))) (deftest the-artist-turns-their-page-and-its-parts-off @@ -373,7 +373,7 @@ (with-conn conn (let [id (add-artist! conn "fusspot" :house-pack)] (with-redefs [branding/portrait-artists {:house-pack {:artist/show-links? false}}] - (is (false? (get-in (orcpub.routes/artist-credit-body (d/db conn) id) [:current :artist/show-links?])) + (is (false? (get-in (orcpub.routes.auth/artist-credit-body (d/db conn) id) [:current :artist/show-links?])) "what the form starts a locked switch from"))))) (deftest the-deployment-settings-can-switch-a-page-off diff --git a/test/clj/orcpub/email_change_test.clj b/test/clj/orcpub/email_change_test.clj index 4e2caf05f..c58e3f43f 100644 --- a/test/clj/orcpub/email_change_test.clj +++ b/test/clj/orcpub/email_change_test.clj @@ -8,6 +8,7 @@ [buddy.hashers :as hashers] [orcpub.errors :as errors] [orcpub.routes :as routes] + [orcpub.routes.auth :as auth] [orcpub.route-map :as route-map] [orcpub.db.schema :as schema]) (:import [java.util UUID])) @@ -90,7 +91,7 @@ (let [mocked-conn (dm/fork-conn conn)] (seed-users mocked-conn) (testing "Request email change stores pending-email and returns 200" - (let [resp (routes/request-email-change + (let [resp (auth/request-email-change (make-request mocked-conn "newalice@test.com" "alice"))] (is (= 200 (:status resp))) (let [user (find-user (d/db mocked-conn) "alice")] @@ -101,7 +102,7 @@ (testing "Verify link swaps email and clears pending-email" (let [key (:orcpub.user/verification-key user) - vresp (routes/verify {:query-params {:key key} + vresp (auth/verify {:query-params {:key key} :db (d/db mocked-conn) :conn mocked-conn})] (is (= 302 (:status vresp))) @@ -109,9 +110,9 @@ (is (= success-path (redirect-location vresp))) (let [updated (find-user (d/db mocked-conn) "alice")] (is (= "newalice@test.com" (:orcpub.user/email updated))) - (is (seq (d/q routes/email-query (d/db mocked-conn) "newalice@test.com")) + (is (seq (d/q auth/email-query (d/db mocked-conn) "newalice@test.com")) "the new address is what lookups find") - (is (empty? (d/q routes/email-query (d/db mocked-conn) "alice@test.com")) + (is (empty? (d/q auth/email-query (d/db mocked-conn) "alice@test.com")) "and the old one no longer is") (is (nil? (:orcpub.user/pending-email updated))) ;; Verification key invalidated — link can't be reused @@ -122,7 +123,7 @@ (let [mocked-conn (dm/fork-conn conn)] (seed-users mocked-conn) (testing "Changing to an already-taken email returns 400 :email-taken" - (let [resp (routes/request-email-change + (let [resp (auth/request-email-change (make-request mocked-conn "bob@test.com" "alice"))] (is (= 400 (:status resp))) (is (= :email-taken (-> resp :body :error))) @@ -136,7 +137,7 @@ (let [mocked-conn (dm/fork-conn conn)] (seed-users mocked-conn) (testing "Changing to your own current email returns 400 :same-as-current" - (let [resp (routes/request-email-change + (let [resp (auth/request-email-change (make-request mocked-conn "alice@test.com" "alice"))] (is (= 400 (:status resp))) (is (= :same-as-current (-> resp :body :error))) @@ -150,7 +151,7 @@ (let [mocked-conn (dm/fork-conn conn)] (seed-users mocked-conn) (testing "Badly formatted email returns 400 :invalid-email" - (let [resp (routes/request-email-change + (let [resp (auth/request-email-change (make-request mocked-conn "not-an-email" "alice"))] (is (= 400 (:status resp))) (is (= :invalid-email (-> resp :body :error))) @@ -164,12 +165,12 @@ (let [mocked-conn (dm/fork-conn conn)] (seed-users mocked-conn) (testing "Nil new-email returns 400 :invalid-email" - (let [resp (routes/request-email-change + (let [resp (auth/request-email-change (make-request mocked-conn nil "alice"))] (is (= 400 (:status resp))) (is (= :invalid-email (-> resp :body :error))))) (testing "Empty string new-email returns 400 :invalid-email" - (let [resp (routes/request-email-change + (let [resp (auth/request-email-change (make-request mocked-conn "" "alice"))] (is (= 400 (:status resp))) (is (= :invalid-email (-> resp :body :error)))))))) @@ -179,7 +180,7 @@ (let [mocked-conn (dm/fork-conn conn)] (seed-users mocked-conn) (testing "Request without identity returns 400 :user-not-found" - (let [resp (routes/request-email-change + (let [resp (auth/request-email-change {:transit-params {:new-email "x@test.com"} :db (d/db mocked-conn) :conn mocked-conn @@ -194,7 +195,7 @@ (let [mocked-conn (dm/fork-conn conn)] (seed-users mocked-conn) (testing "the pending change and both emails are saved together; the outbox sends them" - (let [resp (routes/request-email-change (make-request mocked-conn "newalice@test.com" "alice")) + (let [resp (auth/request-email-change (make-request mocked-conn "newalice@test.com" "alice")) user (find-user (d/db mocked-conn) "alice") emails (d/q '[:find ?kind ?to :where [?e :orcpub.outbox/kind ?kind] [?e :orcpub.outbox/to ?to]] (d/db mocked-conn))] @@ -211,7 +212,7 @@ (seed-users mocked-conn) (testing "Expired verification link clears stale pending-email" ;; Request a change so pending-email is set - (routes/request-email-change + (auth/request-email-change (make-request mocked-conn "newalice@test.com" "alice")) (let [user (find-user (d/db mocked-conn) "alice") key (:orcpub.user/verification-key user)] @@ -220,7 +221,7 @@ [{:db/id (:db/id user) :orcpub.user/verification-sent (java.util.Date. (- (System/currentTimeMillis) (* 25 60 60 1000)))}]) - (let [vresp (routes/verify {:query-params {:key key} + (let [vresp (auth/verify {:query-params {:key key} :db (d/db mocked-conn) :conn mocked-conn})] ;; Must redirect to failed, not success @@ -238,7 +239,7 @@ (seed-users mocked-conn) (testing "If target email is claimed by another user before verify, swap is rejected" ;; Alice requests change to unclaimed@test.com - (routes/request-email-change + (auth/request-email-change (make-request mocked-conn "unclaimed@test.com" "alice")) (let [user (find-user (d/db mocked-conn) "alice") key (:orcpub.user/verification-key user)] @@ -249,7 +250,7 @@ :orcpub.user/password (hashers/encrypt "pass789") :orcpub.user/verified? true}]) ;; Alice clicks verify — should be rejected - (let [vresp (routes/verify {:query-params {:key key} + (let [vresp (auth/verify {:query-params {:key key} :db (d/db mocked-conn) :conn mocked-conn})] (is (= 302 (:status vresp))) @@ -265,11 +266,11 @@ (let [mocked-conn (dm/fork-conn conn)] (seed-users mocked-conn) (testing "Immediate resend of same email is blocked (email still in transit)" - (let [resp1 (routes/request-email-change + (let [resp1 (auth/request-email-change (make-request mocked-conn "new1@test.com" "alice"))] (is (= 200 (:status resp1))) ;; Immediate resend — within 1-min transit zone, should be blocked - (let [resp2 (routes/request-email-change + (let [resp2 (auth/request-email-change (make-request mocked-conn "new1@test.com" "alice"))] (is (= 429 (:status resp2))) ;; retry-after-secs counts down to 1-min mark (resend window) @@ -277,7 +278,7 @@ (is (<= (-> resp2 :body :retry-after-secs) 60))))) (testing "Different email within 5 minutes is rate-limited" - (let [resp (routes/request-email-change + (let [resp (auth/request-email-change (make-request mocked-conn "new2@test.com" "alice"))] (is (= 429 (:status resp))) ;; retry-after-secs counts down to 5-min mark @@ -293,7 +294,7 @@ [{:db/id (:db/id user) :orcpub.user/verification-sent (java.util.Date. (- (System/currentTimeMillis) (* 2 60 1000)))}])) - (let [resp (routes/request-email-change + (let [resp (auth/request-email-change (make-request mocked-conn "new1@test.com" "alice"))] (is (= 200 (:status resp)))))))) @@ -303,7 +304,7 @@ (seed-users mocked-conn) (testing "After rate-limit window, a new request overwrites old pending-email" ;; First request - (routes/request-email-change + (auth/request-email-change (make-request mocked-conn "old-pending@test.com" "alice")) (let [user (find-user (d/db mocked-conn) "alice") old-key (:orcpub.user/verification-key user)] @@ -313,7 +314,7 @@ :orcpub.user/verification-sent (java.util.Date. (- (System/currentTimeMillis) (* 6 60 1000)))}]) ;; Second request should succeed and overwrite pending-email - (let [resp (routes/request-email-change + (let [resp (auth/request-email-change (make-request mocked-conn "new-pending@test.com" "alice"))] (is (= 200 (:status resp))) (let [updated (find-user (d/db mocked-conn) "alice")] @@ -329,20 +330,20 @@ (with-conn conn (seed-users conn) (testing "the wrong password moves nothing" - (let [resp (routes/request-email-change + (let [resp (auth/request-email-change (make-request conn "elsewhere@test.com" "alice" "not-her-password"))] (is (= 400 (:status resp))) (is (= :bad-credentials (-> resp :body :error))) (is (nil? (:orcpub.user/pending-email (find-user (d/db conn) "alice"))) "and leaves no pending change behind"))) (testing "no password at all is the same answer" - (let [resp (routes/request-email-change + (let [resp (auth/request-email-change (make-request conn "elsewhere@test.com" "alice" nil))] (is (= 400 (:status resp))) (is (= :bad-credentials (-> resp :body :error))))) (testing "checked BEFORE the address is even looked at, so an unauthenticated caller learns nothing about which addresses are taken" - (let [resp (routes/request-email-change + (let [resp (auth/request-email-change (make-request conn "bob@test.com" "alice" "not-her-password"))] (is (= :bad-credentials (-> resp :body :error)) "not :email-taken, which would answer a question nobody proved they may ask"))))) diff --git a/test/clj/orcpub/registration_email_test.clj b/test/clj/orcpub/registration_email_test.clj index a9826b6a4..95835af9a 100644 --- a/test/clj/orcpub/registration_email_test.clj +++ b/test/clj/orcpub/registration_email_test.clj @@ -13,6 +13,7 @@ [orcpub.errors :as errors] [orcpub.outbox :as outbox] [orcpub.routes :as routes] + [orcpub.routes.auth :as auth] [orcpub.security :as security] [orcpub.db.schema :as schema]) (:import [java.util Date UUID])) @@ -70,7 +71,7 @@ (deftest sign-up-saves-the-account-and-its-email-together (let [conn (fresh-conn) - resp (routes/register (register-request conn)) + resp (auth/register (register-request conn)) user (find-user (d/db conn) "newcomer") [email & more] (queued conn)] (is (= 200 (:status resp))) @@ -83,7 +84,7 @@ (deftest sign-up-works-while-the-mail-server-is-down (let [conn (fresh-conn) down (fn [_] (throw (javax.mail.MessagingException. "Connection refused")))] - (is (= 200 (:status (routes/register (register-request conn)))) "the person is not turned away") + (is (= 200 (:status (auth/register (register-request conn)))) "the person is not turned away") (outbox/send-due! conn down #(Date.)) (is (some? (find-user (d/db conn) "newcomer")) "the account stays") (is (= :pending (:status (first (queued conn)))) "and its email waits for another try") @@ -95,10 +96,10 @@ (deftest a-resend-replaces-the-key-and-queues-a-new-email (let [conn (fresh-conn)] - (routes/register (register-request conn)) + (auth/register (register-request conn)) (outbox/send-due! conn (constantly true) #(Date.)) (let [before (find-user (d/db conn) "newcomer") - resp (routes/re-verify (re-verify-request conn "newcomer@test.com")) + resp (auth/re-verify (re-verify-request conn "newcomer@test.com")) after (find-user (d/db conn) "newcomer") [email] (queued conn)] (is (= 200 (:status resp))) @@ -111,7 +112,7 @@ (deftest a-resend-to-an-unknown-address-creates-nothing ;; re-verify is unauthenticated, so it answers like a resend and reveals nothing. (let [conn (fresh-conn) - resp (routes/re-verify (re-verify-request conn "nobody@test.com"))] + resp (auth/re-verify (re-verify-request conn "nobody@test.com"))] (is (= 200 (:status resp)) "answers like any resend") (is (nil? (d/q '[:find (count ?e) . :where [?e :orcpub.user/verification-key]] (d/db conn))) "no record was created for an unknown address") diff --git a/test/clj/orcpub/registration_no_email_test.clj b/test/clj/orcpub/registration_no_email_test.clj index 1e62c77c0..3cf744ec4 100644 --- a/test/clj/orcpub/registration_no_email_test.clj +++ b/test/clj/orcpub/registration_no_email_test.clj @@ -22,6 +22,7 @@ [orcpub.email :as email] [orcpub.errors :as errors] [orcpub.routes :as routes] + [orcpub.routes.auth :as auth] [orcpub.security :as security] [orcpub.db.schema :as schema]) (:import [java.util UUID])) @@ -66,7 +67,7 @@ (testing "registration succeeds and the account is already verified" (with-redefs [email/configured? (constantly false) email/unverified-registration-allowed? (constantly true)] - (let [resp (routes/register (register-request conn)) + (let [resp (auth/register (register-request conn)) user (find-user (d/db conn))] (is (zero? (queued-emails (d/db conn))) "no email is queued with no mail server to send it") (is (= 200 (:status resp))) @@ -82,9 +83,9 @@ (let [conn (fresh-conn)] (with-redefs [email/configured? (constantly false) email/unverified-registration-allowed? (constantly true)] - (routes/register (register-request conn))) + (auth/register (register-request conn))) (testing "the account registered without SMTP can sign in" - (let [resp (routes/login-response + (let [resp (auth/login-response {:conn conn :db (d/db conn) :remote-addr "127.0.0.1" @@ -98,7 +99,7 @@ (testing "the normal flow still creates an unverified account and queues a link" (with-redefs [email/configured? (constantly true) email/unverified-registration-allowed? (constantly false)] - (let [resp (routes/register (register-request conn)) + (let [resp (auth/register (register-request conn)) user (find-user (d/db conn))] (is (= 200 (:status resp))) (is (nil? (get-in resp [:body :verified?])) @@ -121,7 +122,7 @@ (testing "no SMTP and no explicit opt-in refuses to register anyone" (with-redefs [email/configured? (constantly false) email/unverified-registration-allowed? (constantly false)] - (let [resp (routes/register (register-request conn))] + (let [resp (auth/register (register-request conn))] (is (zero? (queued-emails (d/db conn))) "no email is queued") (is (= 503 (:status resp)) "registration must be REFUSED when email config is missing and nothing opted out") diff --git a/test/clj/orcpub/routes_test.clj b/test/clj/orcpub/routes_test.clj index 72c81c1d8..6e20c8020 100644 --- a/test/clj/orcpub/routes_test.clj +++ b/test/clj/orcpub/routes_test.clj @@ -8,6 +8,7 @@ [buddy.sign.jwt :as jwt] [environ.core :as environ] [orcpub.routes :as routes] + [orcpub.routes.auth :as auth] [orcpub.env :as env] [orcpub.dnd.e5.magic-items :as mi] [orcpub.dnd.e5.character :as char5e] @@ -291,7 +292,7 @@ :conn mocked-conn})] (is (= 302 (:status resp)) "Should redirect to success page") - (let [user (routes/user-for-email (d/db mocked-conn) "test@test.com")] + (let [user (auth/user-for-email (d/db mocked-conn) "test@test.com")] (is (false? (:orcpub.user/send-updates? user)) "send-updates? should be false after unsubscribe")))) @@ -336,7 +337,7 @@ :conn mocked-conn :identity {:user "testy"}})] (is (= 200 (:status resp))) - (let [user (routes/user-for-email (d/db mocked-conn) "test@test.com")] + (let [user (auth/user-for-email (d/db mocked-conn) "test@test.com")] (is (true? (:orcpub.user/send-updates? user)))))) (testing "Toggle send-updates back to false" @@ -346,7 +347,7 @@ :conn mocked-conn :identity {:user "testy"}})] (is (= 200 (:status resp))) - (let [user (routes/user-for-email (d/db mocked-conn) "test@test.com")] + (let [user (auth/user-for-email (d/db mocked-conn) "test@test.com")] (is (false? (:orcpub.user/send-updates? user)))))) (testing "Unknown user returns 400" @@ -365,8 +366,8 @@ :orcpub.user/email "test@test.com" :orcpub.user/email-key "test@test.com" :orcpub.user/send-updates? true}]) (let [db (d/db mocked-conn) - user (routes/user-for-email db "test@test.com") - body (routes/user-body db user)] + user (auth/user-for-email db "test@test.com") + body (auth/user-body db user)] (is (true? (:send-updates? body)) "user-body should include send-updates? field"))))) @@ -381,7 +382,7 @@ {:transit-params params :db (d/db mocked-conn) :conn mocked-conn :identity {:user "testy"}})) body (fn [] (let [db (d/db mocked-conn)] - (routes/user-body db (routes/user-for-email db "test@test.com"))))] + (auth/user-body db (auth/user-for-email db "test@test.com"))))] (testing "never chosen: absent, so the browser's own choice is not overwritten at login" (is (not (contains? (body) :dark-button-text?)))) (testing "turning it on saves it and returns it" @@ -406,17 +407,17 @@ :remote-addr "1.2.3.4"}] (testing "an address that sprayed five accounts is turned away" (with-redefs [security/multiple-account-access? (constantly true)] - (let [{:keys [status body]} (routes/login-response request)] + (let [{:keys [status body]} (auth/login-response request)] (is (= 401 status)) (is (= errors/too-many-attempts (:error body)))))) (testing "an ordinary address still reaches the credential check" (with-redefs [security/multiple-account-access? (constantly false)] - (is (thrown? Exception (routes/login-response request))))) + (is (thrown? Exception (auth/login-response request))))) (testing "a blank field is still answered before the address is consulted" (with-redefs [security/multiple-account-access? (fn [_] (throw (AssertionError. "consulted too early")))] (is (= errors/username-required - (-> (routes/login-response (assoc-in request [:json-params :username] "")) + (-> (auth/login-response (assoc-in request [:json-params :username] "")) :body :error))))))) @@ -425,21 +426,21 @@ ;; account, which turned it into a membership test anyone could run. (let [sent (atom []) request {:query-params {:email "someone@example.com"} :db nil :conn nil}] - (with-redefs [routes/do-send-password-reset + (with-redefs [auth/do-send-password-reset (fn [id email _ _] (swap! sent conj [id email]) {:status 200})] (testing "an address with no account" - (with-redefs [routes/user-for-email (constantly nil)] - (is (= {:status 200} (routes/send-password-reset request))) + (with-redefs [auth/user-for-email (constantly nil)] + (is (= {:status 200} (auth/send-password-reset request))) (is (empty? @sent) "no mail for an address we do not know"))) (testing "an address with an account gets the identical answer" - (with-redefs [routes/user-for-email (constantly {:db/id 17})] - (is (= {:status 200} (routes/send-password-reset request))) + (with-redefs [auth/user-for-email (constantly {:db/id 17})] + (is (= {:status 200} (auth/send-password-reset request))) (is (= [[17 "someone@example.com"]] @sent))))) (testing "a send that fails does not mark the address as registered" - (with-redefs [routes/user-for-email (constantly {:db/id 17}) - routes/do-send-password-reset + (with-redefs [auth/user-for-email (constantly {:db/id 17}) + auth/do-send-password-reset (fn [& _] (throw (ex-info "smtp is down" {})))] - (is (= {:status 200} (routes/send-password-reset request))))))) + (is (= {:status 200} (auth/send-password-reset request))))))) (defn- clear-limits! [] @@ -448,11 +449,11 @@ (deftest resend-verification-is-limited-per-address-and-answers-the-same (let [sent (atom 0) resend (fn [email ip] - (routes/re-verify {:query-params {:email email} :db nil :conn nil + (auth/re-verify {:query-params {:email email} :db nil :conn nil :remote-addr ip}))] (clear-limits!) - (with-redefs [routes/user-for-email (constantly {:db/id 17}) - routes/do-verification (fn [& _] (swap! sent inc) {:status 200})] + (with-redefs [auth/user-for-email (constantly {:db/id 17}) + auth/do-verification (fn [& _] (swap! sent inc) {:status 200})] (testing "within the per-address limit, mail goes out" (dotimes [_ 3] (is (= {:status 200} (resend "someone@example.com" "1.2.3.4")))) @@ -464,11 +465,11 @@ (deftest resend-verification-is-limited-per-host-and-answers-the-same (let [sent (atom 0) - resend (fn [n] (routes/re-verify {:query-params {:email (str "user" n "@example.com")} + resend (fn [n] (auth/re-verify {:query-params {:email (str "user" n "@example.com")} :db nil :conn nil :remote-addr "5.6.7.8"}))] (clear-limits!) - (with-redefs [routes/user-for-email (constantly {:db/id 17}) - routes/do-verification (fn [& _] (swap! sent inc) {:status 200})] + (with-redefs [auth/user-for-email (constantly {:db/id 17}) + auth/do-verification (fn [& _] (swap! sent inc) {:status 200})] (testing "ten different addresses from one host get mail" (dotimes [n 10] (is (= {:status 200} (resend n)))) @@ -481,11 +482,11 @@ (deftest password-reset-is-limited-per-address-and-answers-the-same (let [sent (atom 0) reset (fn [email ip] - (routes/send-password-reset {:query-params {:email email} :db nil :conn nil + (auth/send-password-reset {:query-params {:email email} :db nil :conn nil :remote-addr ip}))] (clear-limits!) - (with-redefs [routes/user-for-email (constantly {:db/id 17}) - routes/do-send-password-reset (fn [& _] (swap! sent inc) {:status 200})] + (with-redefs [auth/user-for-email (constantly {:db/id 17}) + auth/do-send-password-reset (fn [& _] (swap! sent inc) {:status 200})] (let [first-response (reset "someone@example.com" "1.2.3.4")] (testing "within the per-address limit, mail goes out" (dotimes [_ 2] @@ -498,11 +499,11 @@ (deftest password-reset-is-limited-per-host-and-answers-the-same (let [sent (atom 0) - reset (fn [n] (routes/send-password-reset {:query-params {:email (str "user" n "@example.com")} + reset (fn [n] (auth/send-password-reset {:query-params {:email (str "user" n "@example.com")} :db nil :conn nil :remote-addr "5.6.7.8"}))] (clear-limits!) - (with-redefs [routes/user-for-email (constantly {:db/id 17}) - routes/do-send-password-reset (fn [& _] (swap! sent inc) {:status 200})] + (with-redefs [auth/user-for-email (constantly {:db/id 17}) + auth/do-send-password-reset (fn [& _] (swap! sent inc) {:status 200})] (let [first-response (reset 0)] (testing "ten different addresses from one host get mail" (dotimes [n 9] @@ -515,14 +516,14 @@ (deftest password-reset-for-an-unknown-address-sends-nothing-and-answers-the-same (let [sent (atom 0) - reset (fn [email] (routes/send-password-reset {:query-params {:email email} :db nil :conn nil + reset (fn [email] (auth/send-password-reset {:query-params {:email email} :db nil :conn nil :remote-addr "9.9.9.9"}))] (clear-limits!) - (with-redefs [routes/do-send-password-reset (fn [& _] (swap! sent inc) {:status 200})] - (let [known (with-redefs [routes/user-for-email (constantly {:db/id 17})] + (with-redefs [auth/do-send-password-reset (fn [& _] (swap! sent inc) {:status 200})] + (let [known (with-redefs [auth/user-for-email (constantly {:db/id 17})] (reset "known@example.com")) sent-for-known @sent - unknown (with-redefs [routes/user-for-email (constantly {})] + unknown (with-redefs [auth/user-for-email (constantly {})] (reset "nobody@example.com"))] (is (= 1 sent-for-known)) (is (= known unknown)) @@ -533,8 +534,8 @@ (deftest the-owner-is-told-when-one-account-is-tried-from-several-places (let [posted (promise) request {:scheme :https :headers {"host" "example.test"}} - call #(routes/bad-credentials-response nil "kaylee" "1.2.3.4" request)] - (with-redefs [routes/find-user-by-username-or-email + call #(auth/bad-credentials-response nil "kaylee" "1.2.3.4" request)] + (with-redefs [auth/find-user-by-username-or-email (constantly {:db/id 17 :orcpub.user/email "kaylee@serenity.example" :orcpub.user/email-key "kaylee@serenity.example" :orcpub.user/first-and-last-name "Kaylee"}) @@ -553,19 +554,19 @@ (testing "a spread of addresses that never happened sends nothing" (let [posted (atom [])] - (with-redefs [routes/find-user-by-username-or-email (constantly {:db/id 17}) + (with-redefs [auth/find-user-by-username-or-email (constantly {:db/id 17}) security/multiple-ip-attempts-to-same-account? (constantly false) outbox/enqueue! (fn [& a] (swap! posted conj a))] - (routes/bad-credentials-response nil "kaylee" "1.2.3.4" {}) + (auth/bad-credentials-response nil "kaylee" "1.2.3.4" {}) (Thread/sleep 60) (is (empty? @posted))))) (testing "an address with no account here is told nothing at all" (let [posted (atom [])] - (with-redefs [routes/find-user-by-username-or-email (constantly nil) + (with-redefs [auth/find-user-by-username-or-email (constantly nil) security/multiple-ip-attempts-to-same-account? (constantly true) outbox/enqueue! (fn [& a] (swap! posted conj a))] - (routes/bad-credentials-response nil "nobody" "1.2.3.4" {}) + (auth/bad-credentials-response nil "nobody" "1.2.3.4" {}) (Thread/sleep 60) (is (empty? @posted)))))) @@ -595,12 +596,12 @@ (deftest the-reset-key-is-stored-as-a-digest (let [key "0a5f8e2c-1111-2222-3333-444455556666" - digest (routes/hash-reset-key key)] + digest (auth/hash-reset-key key)] (is (= 64 (count digest)) "SHA-256 as hex") (is (re-matches #"[0-9a-f]{64}" digest)) (is (not= key digest) "the emailed secret is not what the table holds") - (is (= digest (routes/hash-reset-key key)) "and the lookup can reproduce it") - (is (not= digest (routes/hash-reset-key (str key "x")))))) + (is (= digest (auth/hash-reset-key key)) "and the lookup can reproduce it") + (is (not= digest (auth/hash-reset-key (str key "x")))))) (deftest the-corpus-refuses-only-the-egregious @@ -610,14 +611,14 @@ ;; first is the strength meter's to argue with while someone is still typing. (doseq [[n refused?] {0 false, 1 false, 297 false, 999 false, 1000 true, 52372427 true}] (with-redefs [pwned/check (constantly n)] - (is (= refused? (some? (#'routes/breach-errors "irrelevant"))) + (is (= refused? (some? (#'auth/breach-errors "irrelevant"))) (str n " appearances")))) (testing "a service that could not answer is not an objection" (with-redefs [pwned/check (constantly :unknown)] - (is (nil? (#'routes/breach-errors "irrelevant"))))) + (is (nil? (#'auth/breach-errors "irrelevant"))))) (testing "the verdict is keyed for the METER, not as a field fault" (with-redefs [pwned/check (constantly 52372427)] - (let [answer (#'routes/breach-errors "irrelevant")] + (let [answer (#'auth/breach-errors "irrelevant")] ;; :password would render it as a red error above the input, directly ;; over a meter reporting UNCOMMON in green about the same password. (is (nil? (:password answer)) "not keyed with the rule faults") @@ -669,9 +670,9 @@ :orcpub.user/email "resetter@test.com" :orcpub.user/email-key "resetter@test.com" :orcpub.user/password "old-hash" :orcpub.user/verified? true - :orcpub.user/password-reset-key (routes/hash-reset-key reset-key) + :orcpub.user/password-reset-key (auth/hash-reset-key reset-key) :orcpub.user/password-reset-sent sent}]) - (with-redefs-fn {#'routes/breach-errors (constantly nil)} + (with-redefs-fn {#'auth/breach-errors (constantly nil)} (fn [] (testing "opening the link grants no session" (let [resp (routes/reset-password-page {:query-params {:key reset-key} :db (d/db c) @@ -684,23 +685,23 @@ "the key in the URL must not leak through the Referer of anything the page loads"))) (testing "a submit without the key, or with a wrong one, changes nothing" (doseq [k [nil "" "not-the-key"]] - (let [resp (routes/reset-password (request {:password "a fresh long passphrase" + (let [resp (auth/reset-password (request {:password "a fresh long passphrase" :verify-password "a fresh long passphrase" :key k}))] (is (= 400 (:status resp)) (str "key " (pr-str k))) (is (seq (get-in resp [:body :general]))))) - (is (= "old-hash" (:orcpub.user/password (routes/first-user-by (d/db c) routes/username-query "resetter"))))) + (is (= "old-hash" (:orcpub.user/password (auth/first-user-by (d/db c) auth/username-query "resetter"))))) (testing "the key sets the password once, and is then spent" - (is (= 200 (:status (routes/reset-password (request {:password "a fresh long passphrase" + (is (= 200 (:status (auth/reset-password (request {:password "a fresh long passphrase" :verify-password "a fresh long passphrase" :key reset-key}))))) - (let [user (routes/first-user-by (d/db c) routes/username-query "resetter")] + (let [user (auth/first-user-by (d/db c) auth/username-query "resetter")] (is (not= "old-hash" (:orcpub.user/password user))) (is (nil? (:orcpub.user/password-reset-key user)) "the key was not retired")) (is (= #{[:password-changed "resetter@test.com"]} (d/q '[:find ?k ?to :where [?e :orcpub.outbox/kind ?k] [?e :orcpub.outbox/to ?to]] (d/db c))) "the password-changed notice is queued with the change") - (is (= 400 (:status (routes/reset-password (request {:password "another long passphrase" + (is (= 400 (:status (auth/reset-password (request {:password "another long passphrase" :verify-password "another long passphrase" :key reset-key})))) "a used link worked twice"))))))) @@ -713,12 +714,12 @@ @(d/transact c schema/all-schemas) @(d/transact c [{:orcpub.user/username "racer" :orcpub.user/email "racer@test.com" :orcpub.user/email-key "racer@test.com" :orcpub.user/password "old-hash" - :orcpub.user/password-reset-key (routes/hash-reset-key reset-key) + :orcpub.user/password-reset-key (auth/hash-reset-key reset-key) :orcpub.user/password-reset-sent (java.util.Date.)}]) - (with-redefs-fn {#'routes/breach-errors (constantly nil)} + (with-redefs-fn {#'auth/breach-errors (constantly nil)} (fn [] (let [before (d/db c) - submit (fn [pw] (routes/reset-password {:json-params {:password pw :verify-password pw :key reset-key} + submit (fn [pw] (auth/reset-password {:json-params {:password pw :verify-password pw :key reset-key} :db before :conn c :headers {"host" "example.test"}})) first-resp (submit "the first long passphrase") second-resp (submit "the second long passphrase")] @@ -733,15 +734,15 @@ @(d/transact c [{:orcpub.user/username "late" :orcpub.user/email "late@test.com" :orcpub.user/email-key "late@test.com" :orcpub.user/password "old-hash" - :orcpub.user/password-reset-key (routes/hash-reset-key reset-key) + :orcpub.user/password-reset-key (auth/hash-reset-key reset-key) :orcpub.user/password-reset-sent (java.util.Date. (- (System/currentTimeMillis) (* 3 3600 1000)))}]) - (with-redefs-fn {#'routes/breach-errors (constantly nil)} + (with-redefs-fn {#'auth/breach-errors (constantly nil)} (fn [] - (let [resp (routes/reset-password {:json-params {:password "a fresh long passphrase" + (let [resp (auth/reset-password {:json-params {:password "a fresh long passphrase" :verify-password "a fresh long passphrase" :key reset-key} :db (d/db c) :conn c :headers {"host" "example.test"}})] (is (= 400 (:status resp))) (is (= "old-hash" (:orcpub.user/password - (routes/first-user-by (d/db c) routes/username-query "late")))))))))) + (auth/first-user-by (d/db c) auth/username-query "late")))))))))) diff --git a/test/clj/orcpub/security_audit_test.clj b/test/clj/orcpub/security_audit_test.clj index 5ed2173a8..81208f9ca 100644 --- a/test/clj/orcpub/security_audit_test.clj +++ b/test/clj/orcpub/security_audit_test.clj @@ -8,6 +8,7 @@ [orcpub.db.schema :as schema] [orcpub.email :as email] [orcpub.routes :as routes] + [orcpub.routes.auth :as auth] [orcpub.security :as security]) (:import [java.util UUID])) @@ -42,7 +43,7 @@ (defn- sign-up! "Registers newcomer / newcomer@test.com in `conn` and marks the account verified." [conn] - (routes/register (request conn {:json-params {:username "newcomer" :email "newcomer@test.com" + (auth/register (request conn {:json-params {:username "newcomer" :email "newcomer@test.com" :verify-email "newcomer@test.com" :password "hunter2hunter2" :send-updates? false}})) (let [id (d/q '[:find ?e . :where [?e :orcpub.user/username "newcomer"]] (d/db conn))] @@ -58,16 +59,16 @@ (let [conn (fresh-conn)] (sign-up! conn) (testing "a good sign-in" - (let [lines (security-lines #(routes/login-response + (let [lines (security-lines #(auth/login-response (request conn {:json-params {:username "newcomer" :password "hunter2hunter2"}})))] (is (= ["security: sign-in user=newcomer ip=10.0.0.9 fwd=203.0.113.7, 10.0.0.9"] lines)))) (testing "a wrong password on a real account names the account" - (let [lines (security-lines #(routes/login-response + (let [lines (security-lines #(auth/login-response (request conn {:json-params {:username "newcomer" :password "wrong-one"}})))] (is (= ["security: sign-in-failed user=newcomer ip=10.0.0.9 fwd=203.0.113.7, 10.0.0.9"] lines)) (is (not-any? #(s/includes? % "wrong-one") lines) "never the password"))) (testing "a name with no account is not written down: it may be a password in the wrong box" - (let [lines (security-lines #(routes/login-response + (let [lines (security-lines #(auth/login-response (request conn {:json-params {:username "MySecretPass1" :password "x"}})))] (is (= ["security: sign-in-failed ip=10.0.0.9 fwd=203.0.113.7, 10.0.0.9"] lines)))))) diff --git a/test/clj/orcpub/security_test.clj b/test/clj/orcpub/security_test.clj index 4fbfd7ab3..68943979e 100644 --- a/test/clj/orcpub/security_test.clj +++ b/test/clj/orcpub/security_test.clj @@ -8,6 +8,7 @@ [orcpub.pedestal :as pedestal] [orcpub.pwned :as pwned] [orcpub.routes :as routes] + [orcpub.routes.auth :as auth] [orcpub.time :as time :refer [seconds minutes hours millis ago now]] [orcpub.security :as s] [orcpub.db.schema :as schema] @@ -350,7 +351,7 @@ (with-redefs [s/turnstile-enabled? (constantly false) s/turnstile-verify (fn [& _] (swap! calls inc) :fail) s/post-siteverify (fn [& _] (swap! calls inc) (throw (ex-info "no" {})))] - (is (= 200 (:status (routes/register (request conn nil))))) + (is (= 200 (:status (auth/register (request conn nil))))) (is (user-exists? conn)) (is (zero? @calls) "siteverify is never called")))) @@ -358,14 +359,14 @@ (let [conn (fresh-conn)] (with-redefs [s/turnstile-enabled? (constantly true) s/post-siteverify (fn [& _] {:success true})] - (is (= 200 (:status (routes/register (request conn "good-token"))))) + (is (= 200 (:status (auth/register (request conn "good-token"))))) (is (user-exists? conn))))) (deftest enabled-and-failing-refuses-without-using-the-host-allowance (let [conn (fresh-conn)] (with-redefs [s/turnstile-enabled? (constantly true) s/post-siteverify (fn [& _] {:success false})] - (let [resp (routes/register (request conn "bad-token"))] + (let [resp (auth/register (request conn "bad-token"))] (is (= 400 (:status resp))) (is (= 1 (count (get-in resp [:body :general]))) "a :general error") (is (str/includes? (first (get-in resp [:body :general])) "not a bot")) @@ -377,7 +378,7 @@ (let [conn (fresh-conn)] (with-redefs [s/turnstile-enabled? (constantly true) s/post-siteverify (fn [& _] (throw (java.net.SocketTimeoutException. "slow")))] - (is (= 200 (:status (routes/register (request conn "any-token"))))) + (is (= 200 (:status (auth/register (request conn "any-token"))))) (is (user-exists? conn))))) (deftest a-blank-token-fails-without-calling-cloudflare @@ -390,7 +391,7 @@ (let [conn (fresh-conn)] (with-redefs [s/turnstile-enabled? (constantly true) s/post-siteverify (fn [& _] (swap! calls inc) {:success true})] - (is (= 400 (:status (routes/register (request conn nil))))) + (is (= 400 (:status (auth/register (request conn nil))))) (is (zero? @calls))))))) (deftest verify-maps-cloudflare-answers diff --git a/test/clj/orcpub/user_email_test.clj b/test/clj/orcpub/user_email_test.clj index e2cfcba91..c38c66766 100644 --- a/test/clj/orcpub/user_email_test.clj +++ b/test/clj/orcpub/user_email_test.clj @@ -10,6 +10,7 @@ [orcpub.db.schema :as schema] [orcpub.email :as email] [orcpub.routes :as routes] + [orcpub.routes.auth :as auth] [orcpub.security :as security] [orcpub.user-email :as ue]) (:import [java.util Locale UUID])) @@ -43,12 +44,12 @@ (is (zero? (ue/backfill! conn 500)) "a second run finds nothing to do") (let [db (d/db conn)] (is (= "Kaylee@Example.Test" (:orcpub.user/email (account conn "kaylee"))) "the address as typed is kept") - (is (= "kaylee" (:orcpub.user/username (routes/lookup-user db "KAYLEE@example.test" "shiny-hunter2"))) + (is (= "kaylee" (:orcpub.user/username (auth/lookup-user db "KAYLEE@example.test" "shiny-hunter2"))) "sign-in by email") - (is (some? (:db/id (routes/user-for-email db "kaylee@EXAMPLE.test"))) "password reset") - (is (seq (d/q routes/email-query db (ue/email-key "kaylee@example.TEST"))) + (is (some? (:db/id (auth/user-for-email db "kaylee@EXAMPLE.test"))) "password reset") + (is (seq (d/q auth/email-query db (ue/email-key "kaylee@example.TEST"))) "sign-up and email change see the address as taken") - (is (= "kaylee" (:orcpub.user/username (routes/find-user-by-username-or-email db "kaylee@example.test"))) + (is (= "kaylee" (:orcpub.user/username (auth/find-user-by-username-or-email db "kaylee@example.test"))) "an account named by its email")))) (deftest an-account-with-a-blank-email-does-not-stop-the-backfill @@ -66,9 +67,9 @@ @(d/transact conn [{:orcpub.user/username "simon" :orcpub.user/email "simon@example.test" :orcpub.user/password (hashers/encrypt "shiny-hunter2")}]) (let [db (d/db conn)] - (is (seq (d/q routes/email-query db "simon@example.test")) "sign-up sees the address as taken") - (is (some? (:db/id (routes/user-for-email db "Simon@Example.test"))) "password reset") - (is (= "simon" (:orcpub.user/username (routes/lookup-user db "SIMON@example.test" "shiny-hunter2")))))))) + (is (seq (d/q auth/email-query db "simon@example.test")) "sign-up sees the address as taken") + (is (some? (:db/id (auth/user-for-email db "Simon@Example.test"))) "password reset") + (is (= "simon" (:orcpub.user/username (auth/lookup-user db "SIMON@example.test" "shiny-hunter2")))))))) (deftest the-backfill-reads-the-accounts-once (let [conn (fresh-conn) reads (atom 0) real-q d/q] @@ -97,7 +98,7 @@ (with-redefs [security/registration-allowed? (constantly true) email/configured? (constantly false) email/unverified-registration-allowed? (constantly true)] - (is (= 200 (:status (routes/register {:conn conn :db (d/db conn) :scheme :https :headers {"host" "example.test"} + (is (= 200 (:status (auth/register {:conn conn :db (d/db conn) :scheme :https :headers {"host" "example.test"} :json-params {:username "newcomer" :email "NewComer@Test.com" :verify-email "NewComer@Test.com" :password "hunter2hunter2" :send-updates? false}}))))) From 5368b96b83d63eb1b0e7f4362b6c8256463bd03c Mon Sep 17 00:00:00 2001 From: codeGlaze Date: Wed, 4 Nov 2026 04:03:10 +0000 Subject: [PATCH 06/27] Move the shared form helpers from views into components --- src/cljc/orcpub/components.cljc | 84 +++++++++++++++++- src/cljs/orcpub/dnd/e5/views.cljs | 86 +------------------ .../orcpub/dnd/e5/views/builder_fields.cljs | 3 + 3 files changed, 88 insertions(+), 85 deletions(-) diff --git a/src/cljc/orcpub/components.cljc b/src/cljc/orcpub/components.cljc index 5f72bdf65..d2c145f55 100644 --- a/src/cljc/orcpub/components.cljc +++ b/src/cljc/orcpub/components.cljc @@ -1,6 +1,7 @@ (ns orcpub.components (:require [clojure.string :as s] - #?(:cljs [reagent.core :refer [atom]]))) + #?(:cljs [re-frame.core :refer [dispatch]]) + #?(:cljs [reagent.core :as r :refer [atom]]))) (defn- press-to-click "A keydown handler that turns Space or Enter into a click on the element, so whatever handles @@ -114,3 +115,84 @@ (js/parseInt str-v))] (on-change v)))) (assoc attrs :type :number)]) + +(def orange "#f0a100") + +(defn base-input + "One auth field: a notched-outline label, an optional reveal button, and the + notice slot `messages`/`hint` render into. + GOTCHA: both label positions are always rendered and the stylesheet picks + via :placeholder-shown / .is-wrong, so a live check and a submit lay out + the same. :messages, :hint, :reveal? are optional; other keys pass to . + See account-flows.md." + [{:keys [title messages hint action reveal? revealed? on-reveal] :as attrs}] + (let [id (str "f-" (name (or (:name attrs) (:key attrs) (gensym "x")))) + message-id (str id "-message") + wrong? (boolean (seq messages)) + input-attrs (-> attrs + (dissoc :title :messages :hint :action :reveal? :revealed? :on-reveal :key) + (assoc :id id + ;; the selector the notch is driven by + :placeholder " " + :aria-describedby message-id) + (cond-> wrong? (assoc :aria-invalid true)))] + [:div.field {:class (when wrong? "is-wrong")} + [:label.lift {:for id} title] + [:div.field-notice.is-error {:id message-id} + (when wrong? [:span.field-notice-what (first messages)])] + [:div.field-box + [:input input-attrs] + [:label.notch {:for id} title] + (when reveal? + [:button.peek {:type "button" + :aria-controls id + :aria-pressed (boolean revealed?) + :on-click on-reveal} + (if revealed? "Hide" "Show")])] + (when (or hint action) + [:div.field-notice.is-note + (when hint [:span.field-notice-what hint]) + (when-let [{:keys [label on-choose]} action] + ;; on-mouse-down, NOT on-click: blur re-renders this notice and the + ;; button is gone before mouseup, so a click handler here never fires. + ;; preventDefault stops focus moving at all. + [:button.field-notice-action + {:type "button" + :on-mouse-down (fn [e] (.preventDefault e) (on-choose))} + label])])])) + +#?(:cljs +(defn form-input [] + (let [blurred? (r/atom false) + revealed? (r/atom false)] + ;; show-errors? is how a submit reveals faults in fields nobody has visited. + ;; Without it, pressing the button on a form with an untouched empty field + ;; had nothing to say, which is why the button used to dim instead. + (fn [{:keys [title key value messages type on-change show-errors? hint action reveal?] + reveal-state :revealed? on-reveal :on-reveal}] + ;; The reveal is usually this field's own business. A password and its + ;; confirmation have to share one, so the caller can own it instead. + (let [shown (when (or @blurred? show-errors?) messages) + shown-as-text? (if (some? reveal-state) reveal-state @revealed?) + flip (or on-reveal #(swap! revealed? not))] + [base-input + {:name key + ;; A revealed password is a text field. The type is the reveal. + :type (if (and reveal? shown-as-text?) :text type) + :value value + :title title + :messages shown + :hint hint + :action action + :reveal? reveal? + :revealed? shown-as-text? + :on-reveal flip + :on-focus (fn [_] (reset! blurred? false)) + :on-change on-change + :on-blur (fn [_] (reset! blurred? true))}]))))) + +#?(:cljs +(def make-event-handler + (memoize + (fn [event-kw & args] + #(dispatch (vec (cons event-kw args))))))) diff --git a/src/cljs/orcpub/dnd/e5/views.cljs b/src/cljs/orcpub/dnd/e5/views.cljs index 36dd9a611..f3bd3b206 100644 --- a/src/cljs/orcpub/dnd/e5/views.cljs +++ b/src/cljs/orcpub/dnd/e5/views.cljs @@ -4,7 +4,7 @@ [orcpub.route-map :as routes] [orcpub.common :as common] [orcpub.entity :as entity] - [orcpub.components :as comps] + [orcpub.components :as comps :refer [orange base-input form-input make-event-handler]] [orcpub.entity-spec :as es] [orcpub.pdf-spec :as pdf-spec] [orcpub.dnd.e5.spell-packing :as packing] @@ -51,7 +51,7 @@ [orcpub.dnd.e5.views-2 :as views-2] [orcpub.dnd.e5.views.notifications :as notifications] [orcpub.dnd.e5.views.whats-new :as whats-new-view] - [orcpub.dnd.e5.views.builder-fields :refer [event-value dropdown labeled-dropdown + [orcpub.dnd.e5.views.builder-fields :refer [event-value set-value dropdown labeled-dropdown base-builder-field builder-field input-builder-field textarea-field number-field]] @@ -84,8 +84,6 @@ (def text-color "#484848") -(def orange "#f0a100") - (def input-style {:height "38px" :border-style "solid" @@ -100,9 +98,6 @@ input-style {:border-color "rgba(72,72,72,0.37)"})) -(defn set-value [atom key e] - (swap! atom assoc key (event-value e))) - (defn validation-messages [messages] (when messages [:ul.t-a-l.p-l-20.p-r-20.m-b-10 @@ -113,78 +108,6 @@ [:li.red (str common/dot-char " " msg)]) messages))])) -(defn base-input - "One auth field: a notched-outline label, an optional reveal button, and the - notice slot `messages`/`hint` render into. - GOTCHA: both label positions are always rendered and the stylesheet picks - via :placeholder-shown / .is-wrong, so a live check and a submit lay out - the same. :messages, :hint, :reveal? are optional; other keys pass to . - See account-flows.md." - [{:keys [title messages hint action reveal? revealed? on-reveal] :as attrs}] - (let [id (str "f-" (name (or (:name attrs) (:key attrs) (gensym "x")))) - message-id (str id "-message") - wrong? (boolean (seq messages)) - input-attrs (-> attrs - (dissoc :title :messages :hint :action :reveal? :revealed? :on-reveal :key) - (assoc :id id - ;; the selector the notch is driven by - :placeholder " " - :aria-describedby message-id) - (cond-> wrong? (assoc :aria-invalid true)))] - [:div.field {:class (when wrong? "is-wrong")} - [:label.lift {:for id} title] - [:div.field-notice.is-error {:id message-id} - (when wrong? [:span.field-notice-what (first messages)])] - [:div.field-box - [:input input-attrs] - [:label.notch {:for id} title] - (when reveal? - [:button.peek {:type "button" - :aria-controls id - :aria-pressed (boolean revealed?) - :on-click on-reveal} - (if revealed? "Hide" "Show")])] - (when (or hint action) - [:div.field-notice.is-note - (when hint [:span.field-notice-what hint]) - (when-let [{:keys [label on-choose]} action] - ;; on-mouse-down, NOT on-click: blur re-renders this notice and the - ;; button is gone before mouseup, so a click handler here never fires. - ;; preventDefault stops focus moving at all. - [:button.field-notice-action - {:type "button" - :on-mouse-down (fn [e] (.preventDefault e) (on-choose))} - label])])])) - -(defn form-input [] - (let [blurred? (r/atom false) - revealed? (r/atom false)] - ;; show-errors? is how a submit reveals faults in fields nobody has visited. - ;; Without it, pressing the button on a form with an untouched empty field - ;; had nothing to say, which is why the button used to dim instead. - (fn [{:keys [title key value messages type on-change show-errors? hint action reveal?] - reveal-state :revealed? on-reveal :on-reveal}] - ;; The reveal is usually this field's own business. A password and its - ;; confirmation have to share one, so the caller can own it instead. - (let [shown (when (or @blurred? show-errors?) messages) - shown-as-text? (if (some? reveal-state) reveal-state @revealed?) - flip (or on-reveal #(swap! revealed? not))] - [base-input - {:name key - ;; A revealed password is a text field. The type is the reveal. - :type (if (and reveal? shown-as-text?) :text type) - :value value - :title title - :messages shown - :hint hint - :action action - :reveal? reveal? - :revealed? shown-as-text? - :on-reveal flip - :on-focus (fn [_] (reset! blurred? false)) - :on-change on-change - :on-blur (fn [_] (reset! blurred? true))}])))) - (def ^:private password-rule-chips "One chip per rule: which rule it is, and whether `password` satisfies it. GOTCHA: the \"not your name\" chip only renders where `ctx` has identifying @@ -933,11 +856,6 @@ (when tail [:div.m-t-10.auth-tail tail])] {:legal-links? legal-links?})) -(def make-event-handler - (memoize - (fn [event-kw & args] - #(dispatch (vec (cons event-kw args)))))) - (def make-stop-prop-event-handler (memoize (fn [event-kw & args] diff --git a/src/cljs/orcpub/dnd/e5/views/builder_fields.cljs b/src/cljs/orcpub/dnd/e5/views/builder_fields.cljs index 06365a4bd..a14b0e346 100644 --- a/src/cljs/orcpub/dnd/e5/views/builder_fields.cljs +++ b/src/cljs/orcpub/dnd/e5/views/builder_fields.cljs @@ -9,6 +9,9 @@ [e] (.. e -target -value)) +(defn set-value [atom key e] + (swap! atom assoc key (event-value e))) + (defn dropdown "A select of `items` ([{:value :title :disabled?}]) showing `value`. `on-change` gets the picked value as a string, or with :typed? the item's own :value of any type. :class-name styles it." From 1514cdd8d5916147806397b67a784d1a6a99bda5 Mon Sep 17 00:00:00 2001 From: codeGlaze Date: Wed, 4 Nov 2026 04:14:31 +0000 Subject: [PATCH 07/27] Move the account screens and the Turnstile widget into views/auth --- src/cljc/orcpub/components.cljc | 2 + src/cljs/orcpub/dnd/e5/events.cljs | 10 +- src/cljs/orcpub/dnd/e5/views.cljs | 655 +--------------------- src/cljs/orcpub/dnd/e5/views/auth.cljs | 744 +++++++++++++++++++++++++ src/cljs/orcpub/turnstile.cljs | 79 --- web/cljs/orcpub/core.cljs | 25 +- 6 files changed, 764 insertions(+), 751 deletions(-) create mode 100644 src/cljs/orcpub/dnd/e5/views/auth.cljs delete mode 100644 src/cljs/orcpub/turnstile.cljs diff --git a/src/cljc/orcpub/components.cljc b/src/cljc/orcpub/components.cljc index d2c145f55..b12afc6c9 100644 --- a/src/cljc/orcpub/components.cljc +++ b/src/cljc/orcpub/components.cljc @@ -196,3 +196,5 @@ (memoize (fn [event-kw & args] #(dispatch (vec (cons event-kw args))))))) + +(def text-color "#484848") diff --git a/src/cljs/orcpub/dnd/e5/events.cljs b/src/cljs/orcpub/dnd/e5/events.cljs index 045d5b341..d2c29a805 100644 --- a/src/cljs/orcpub/dnd/e5/events.cljs +++ b/src/cljs/orcpub/dnd/e5/events.cljs @@ -124,7 +124,7 @@ [orcpub.errors :as errors] [orcpub.fork.integrations :as integrations] [orcpub.fork.branding :as branding] - [orcpub.turnstile :as turnstile] + [orcpub.dnd.e5.views.auth :as views-auth] [clojure.set :as sets] [cljsjs.filesaverjs] [clojure.pprint :as pprint]) @@ -3673,12 +3673,6 @@ ::entity/value] name))) -(defn cookies [] - (let [cookie js/document.cookie] - (into {} - (map #(s/split % "=")) - (s/split cookie "; ")))) - (def show-generic-error event-utils/show-generic-error) (reg-fx @@ -3822,7 +3816,7 @@ (reg-event-fx :turnstile-reset (fn [_ _] - (turnstile/reset-widget!) + (views-auth/reset-widget!) nil)) #_ ;; dead stub — real impl is orcpub.registration/validate-registration diff --git a/src/cljs/orcpub/dnd/e5/views.cljs b/src/cljs/orcpub/dnd/e5/views.cljs index f3bd3b206..6ba5acfa8 100644 --- a/src/cljs/orcpub/dnd/e5/views.cljs +++ b/src/cljs/orcpub/dnd/e5/views.cljs @@ -4,7 +4,7 @@ [orcpub.route-map :as routes] [orcpub.common :as common] [orcpub.entity :as entity] - [orcpub.components :as comps :refer [orange base-input form-input make-event-handler]] + [orcpub.components :as comps :refer [orange text-color make-event-handler]] [orcpub.entity-spec :as es] [orcpub.pdf-spec :as pdf-spec] [orcpub.dnd.e5.spell-packing :as packing] @@ -48,10 +48,9 @@ [orcpub.dnd.e5.weapon-damage :as weapon-damage] [orcpub.dnd.e5.weapon-rolls :as weapon-rolls] [orcpub.dnd.e5.template :as t] - [orcpub.dnd.e5.views-2 :as views-2] [orcpub.dnd.e5.views.notifications :as notifications] [orcpub.dnd.e5.views.whats-new :as whats-new-view] - [orcpub.dnd.e5.views.builder-fields :refer [event-value set-value dropdown labeled-dropdown + [orcpub.dnd.e5.views.builder-fields :refer [event-value dropdown labeled-dropdown base-builder-field builder-field input-builder-field textarea-field number-field]] @@ -65,7 +64,7 @@ [orcpub.dnd.e5.orcbrew-validation :as orcbrew-val] [orcpub.fork.integrations :as integrations] [orcpub.fork.branding :as branding] - [orcpub.turnstile :as turnstile] + [orcpub.dnd.e5.views.auth :refer [dispatch-route-to-login]] [orcpub.fork.splash :as splash] [orcpub.fork.user-tier] [orcpub.ver :as v] @@ -82,8 +81,6 @@ ;; using a dropdown instead of a list of checkboxes (def actions-amount-many 5) -(def text-color "#484848") - (def input-style {:height "38px" :border-style "solid" @@ -108,147 +105,6 @@ [:li.red (str common/dot-char " " msg)]) messages))])) -(def ^:private password-rule-chips - "One chip per rule: which rule it is, and whether `password` satisfies it. - GOTCHA: the \"not your name\" chip only renders where `ctx` has identifying - info -- the reset page passes none, so a context chip there would always - pass. See account-flows.md." - [{:label "12 or more" - :ok? (fn [p _] (>= (count (or p "")) registration/min-password-length))} - {:label "no triples" - :ok? (fn [p _] (not (registration/repeated-run? p)))} - {:label "no key runs" - :ok? (fn [p _] (not (registration/sequential-run? p)))} - {:label "some variety" - :ok? (fn [p _] (not (registration/too-few-distinct? p)))} - {:label "not your name" - :needs-context? true - :ok? (fn [p ctx] (not (registration/contains-identifier? p ctx)))}]) - -(def ^:private password-tips - "Per-rung lines to show once the password passes that rung, several per rung. - GOTCHA: `password-tip` picks among a rung's lines by text length, not - randomly, so the line holds still while typing instead of flickering on - every keystroke. See account-flows.md." - [["Two words that have no business together beat one clever one." - "Another word buys more than another symbol." - "Swapping o for 0 fools nobody. That is the first thing tried."] - ["Spaces are allowed. A short sentence types faster than it looks." - "One more word is the cheapest upgrade here." - "Nonsense is fine. It does not have to mean anything."] - ["Try something your character would say." - "One more word and this is as good as it gets." - "If you can picture it, you will remember it."] - ["Nothing left to prove. Write it down somewhere safe." - "About as good as it gets. Go make a character." - "Just do not use this one anywhere else."]]) - -(defn- password-tip - "The tip for this rung, held still by picking it from the length." - [rung length] - (when (and rung (not (neg? rung))) - (let [set (nth password-tips rung)] - (nth set (mod length (count set)))))) - -(defn password-meter - "The password-strength meter, shared by the register and reset forms. - `context` is identifying info the password must not contain, empty on the - reset page, which is also what the server judges it against. `refused` - shows \"too common\" once the server has rejected the password. - GOTCHA: only this meter checks live; the server enforces the same rules - silently otherwise. See account-flows.md." - ([password] (password-meter password nil nil)) - ([password context] (password-meter password context nil)) - ([password context refused] - (let [{:keys [rung fills]} (registration/password-strength password context) - tier-names ["Uncommon" "Rare" "Very Rare" "Legendary"] - ;; The corpus outranks the ladder. Only the server can reach it, so it - ;; arrives late and separately -- but a password it refuses is not a - ;; Rare one, and showing both is how the page ended up holding two - ;; verdicts that disagreed. - refused? (boolean (seq refused)) - reached? (and (not refused?) rung (not (neg? rung))) - suffix (cond refused? "fail" (nil? rung) nil (neg? rung) "fail" :else rung) - remaining (when (and reached? (< rung 3)) - (- (nth registration/strength-rungs (inc rung)) - (count (or password ""))))] - [:div.p-r-10.p-l-10.p-t-5 - [:div.pw-slots - (doall - (for [[i percent] (map-indexed vector fills)] - ^{:key i} - [:div.pw-slot - ;; The only inline style on this widget. The width IS the - ;; measurement, so it cannot be a named class. - [:div.pw-fill {:class (when suffix (str "pw-fill-" suffix)) - :style {:width (str percent "%")}}]]))] - [:div.pw-verdict - [:span.pw-tier-name {:class (when suffix (str "pw-name-" suffix))} - (cond refused? "Too common" - reached? (nth tier-names rung))] - [:span.pw-next - (cond - refused? nil - remaining (str (nth tier-names (inc rung)) " in " remaining) - (seq password) (str (count password) " characters"))]] - ;; Every rule, each as its own chip. Before this the five rules spoke only - ;; through whichever one happened to fail first, so nobody could see what - ;; was being asked of them until they had broken it. - (when (seq password) - [:div.pw-chips - (doall - (for [{:keys [label ok? needs-context?]} password-rule-chips - :when (or (not needs-context?) (seq (vals context)))] - ^{:key label} - [:span.pw-chip {:class (if (ok? password context) "is-ok" "is-bad")} - label])) - ;; Only the server can reach the corpus, so this appears once it has - ;; answered and never guesses in the meantime. - (when refused? [:span.pw-chip.is-bad "too common"])]) - ;; The line under the bar: what is wrong when something is, and what to do - ;; next when nothing is. It sits with the bar it is about rather than in - ;; the field's error slot, because both readings are advice on writing a - ;; better password, which is what the whole widget is. - (cond - refused? [:div.pw-note refused] - :else (when-let [tip (password-tip rung (count (or password "")))] - [:div.pw-note.is-tip tip]))]))) - -(defn password-pair - "A password field and its confirmation; revealing the password retires the - confirmation field entirely. - GOTCHA: the confirm field is REMOVED, not faded, on reveal -- faded would - stay in the accessibility tree and a submit could fail pointing at a field - nobody can see. `revealed?`/`on-toggle` are the caller's, since submit-gating - has to know confirmation isn't being asked for. See account-flows.md." - [{:keys [password confirm messages confirm-messages show-errors? revealed? - on-toggle on-password on-confirm]}] - [:div - [form-input {:title "Password" - :key :password - :value password - :type :password - :messages messages - :show-errors? show-errors? - :reveal? true - :revealed? revealed? - :on-reveal on-toggle - :on-change on-password}] - (when-not revealed? - [form-input {:title "Confirm password" - :key :verify-password - :value confirm - :type :password - ;; The caller may have more to say about this field than a - ;; mismatch -- the server answers per field too -- so its - ;; messages win when it passes any. - :messages (or (seq confirm-messages) - (when (and (seq password) (seq confirm) - (not= password confirm)) - ["Passwords do not match"])) - :show-errors? show-errors? - :on-change on-confirm}])]) - (defn- portrait-fields "The spec's portrait fields for baked `png-b64`: the pixels and the credit, which travels with them because the server has no layer selection. Fitted to the PDF metadata's 78 characters, @@ -338,10 +194,6 @@ (defn dispatch-logout [] (dispatch [:logout])) -(defn dispatch-route-to-login [e] - (.stopPropagation e) - (dispatch [:route-to-login])) - (defn dispatch-route-to-my-account [e] (dispatch [:route :my-account])) @@ -764,98 +616,6 @@ {:name "Selection Builder" :route routes/dnd-e5-selection-builder-page-route}]]]]]])) -(def registration-content-style - {:background-color :white - :border "1px solid white" - :color text-color}) - -(def registration-left-column-style - {:flex-direction :column - :width "435px"}) - -(def registration-header-style - {:height "65px" - :background-color "#1a2532" - :border-right "1px solid white"}) - -(defn route-to-default-page [] - (dispatch [:route :default])) - -(defn registration-page - "The shell every auth page renders through. `legal-links?` false suppresses the - footer's two links for a page that already carries them in its own consent copy." - ([content] (registration-page content true)) - ([content legal-links?] - [:div.sans.h-full.flex.flex-column - [:div.flex.justify-cont-s-a.align-items-c.flex-grow-1.h-100-p - [:div.registration-content - {:style registration-content-style} - [:div.flex.h-100-p - [:div.flex {:style registration-left-column-style} - [:div.flex.justify-cont-s-a.align-items-c - {:style registration-header-style} - [:img.pointer - {:class branding/registration-logo-class - :src branding/logo-path - :on-click route-to-default-page}]] - [:div.flex-grow-1 content] - [views-2/legal-footer legal-links?]] - [:div.registration-image]]]]])) - -(defn auth-page - "The shared auth shell: heading, rule, optional `lede` line, then `content`. - `lede` is the line under the rule and is optional. - See account-flows.md." - ([heading content] (auth-page heading nil content nil)) - ([heading lede content] (auth-page heading lede content nil)) - ([heading lede content {:keys [legal-links?] :or {legal-links? true}}] - (registration-page - [:div - [:h1.auth-heading.m-t-20 heading] - [:div.auth-rule] - (when lede [:div.auth-lede lede]) - content] - legal-links?))) - -(defn- reset-username - "The username of the account a reset link is for, from the plain cookie the reset page sets. - Grants nothing; used only to flag \"password equals username\" while typing. The server - re-derives it from the link's key on submit. See account-flows.md." - [] - (some-> (get (events/cookies) "reset-username") js/decodeURIComponent)) - -(defn password-fields - "The password pair plus the strength meter under it, as one unit. - GOTCHA: state stays with the caller -- register keeps it in app-db, reset in - a local atom, since a reset form exists for ninety seconds behind a one-use - link. See account-flows.md." - [{:keys [password confirm revealed? context messages confirm-messages - show-errors? refused on-password on-confirm on-toggle]}] - [:div - [password-pair - {:password password - :confirm confirm - :messages messages - :confirm-messages confirm-messages - :show-errors? show-errors? - :revealed? revealed? - :on-toggle on-toggle - :on-password on-password - :on-confirm on-confirm}] - [password-meter password context refused]]) - -(defn auth-form-page - "An auth-page shell for a form: `fields` in a column, then `tail` (submit and - any links or fineprint) below them. - See account-flows.md." - [{:keys [heading lede fields tail legal-links?] - :or {legal-links? true}}] - (auth-page heading lede - [:div - [:div.m-t-10.auth-form fields] - (when tail [:div.m-t-10.auth-tail tail])] - {:legal-links? legal-links?})) - (def make-stop-prop-event-handler (memoize (fn [event-kw & args] @@ -874,415 +634,6 @@ (handler e)))) (nil? handler) (assoc :aria-disabled "true"))) -(defn verify-failed [] - (let [params (r/atom {})] - (fn [] - (auth-form-page - {:heading "Your key has expired" - :lede (str "You must verify your email within 24 hours of registering. " - "Send another verification email by submitting your address here.") - :fields [base-input - {:name :email - :value (:email @params) - :type :email - :title "Email address" - :on-change (partial set-value params :email)}] - :tail [:button.form-button.form-submit-btn - {:on-click (make-event-handler :re-verify @params)} - "RESEND"]})))) - - -(defn hide-login-message [] - (dispatch [:hide-login-message])) - -(defn send-password-reset-page [] - (let [params (r/atom {})] - (fn [error-message] - (let [email (:email @params) - bad-email? (registration/bad-email? email)] - (auth-form-page - {:heading "Reset your password" - :lede "Submit your email address and we will send you a link to reset your password." - :fields - [:div - (when error-message [:div.red.m-b-20 error-message]) - [form-input - {:title "Email" - :key :email - :messages (if bad-email? - ["Not a valid email address"] - []) - :type :email - :value email - :on-change (partial set-value params :email)}] - (when @(subscribe [:login-message-shown?]) - [:div.m-t-5.p-r-5.p-l-5 - [notifications/message - :error - @(subscribe [:login-message]) - hide-login-message]]) - ] - :tail - [:div - [:button.form-button.form-submit-btn - {:class (when bad-email? "disabled opacity-5 hover-no-shadow") - :on-click (when (not bad-email?) (make-event-handler :send-password-reset @params))} - "SUBMIT"] - ;; The link text is the whole phrase, not the one word "whitelist" in - ;; the middle of it: a single word is a small target, and it is what a - ;; screen reader announces on its own, where it names no destination. - [:div.auth-help - [:span "Didn't receive the reset email? Check your spam folder, or "] - [:a.orange {:href "/help/im-not-getting-my-signup-password-reset-email/" :target "_blank"} - "read how to let our email through"] - [:span ", then try again."]]]}))))) - -(defn password-reset-expired-page [] - ;; Reached by an expired link AND by one that is mangled or unrecognised, so - ;; the wording cannot claim to know which. It also no longer says 24 hours, - ;; which stopped being true when the window became two. - [send-password-reset-page - (str "That reset link no longer works. Links last " - "two hours, and each one can only be used once. " - "Send yourself a new one below.")]) - -(defn password-reset-used-page [] - [send-password-reset-page "Your reset link has already been used. Please use the form below to send another reset email."]) - -(defn password-validation-messages [password] - (-> password - registration/validate-password - :password)) - -(defn password-reset-page [] - (let [params (r/atom {})] - (fn [] - (let [password (:password @params) - verify-password (:verify-password @params) - ;; Merged per field, so a server objection -- a common password, the - ;; one rule only the server can apply -- sits alongside whatever the - ;; form already found rather than replacing it. - server-errors @(subscribe [:password-reset-server-errors]) - ;; GOTCHA: context carries only the username, never email, to avoid a disclosure - ;; via cookie; the server checks email separately on submit. See account-flows.md. - context {:username (reset-username)} - ;; Reading the password back is what the confirm box stands in for, - ;; so revealing it retires the box -- and the check that decides - ;; whether this can be submitted has to know that, which is why the - ;; flag is out here rather than inside password-pair. - revealed? (:password-revealed? @params) - faults (registration/password-pair-faults password verify-password - revealed? context) - password-messages (vec (distinct (concat (:password faults) - (:password server-errors)))) - confirm-messages (vec (distinct (concat (:verify-password faults) - (:verify-password server-errors)))) - invalid? (or (seq password-messages) (seq confirm-messages)) - ;; Local to this page's own atom on purpose. The register form keeps - ;; the same flag in app-db, and reaching for that from here is what - ;; split the reveal state between a db read and a component atom - ;; last time. - attempted? (:attempted? @params)] - (auth-form-page - {:heading "Choose a new password" - :lede "This replaces the password on your account." - :fields - [:div - ;; The same pair and meter the register form uses. - ;; GOTCHA: this is account RECOVERY, the last door somebody has -- a - ;; silently dimmed button with no message is worse here than anywhere - ;; else. See account-flows.md. - [password-fields - {:password password - :confirm verify-password - :context context - :messages password-messages - :confirm-messages confirm-messages - :show-errors? attempted? - :revealed? revealed? - :refused (first (:password-common server-errors)) - :on-toggle #(swap! params update :password-revealed? not) - :on-password (fn [e] - (dispatch [:password-reset-clear-errors]) - (swap! params assoc :password (event-value e))) - :on-confirm (fn [e] - (dispatch [:password-reset-clear-errors]) - (swap! params assoc :verify-password (event-value e)))}] - (when @(subscribe [:login-message-shown?]) - [:div.m-t-5.p-r-5.p-l-5 [notifications/message - :error - @(subscribe [:login-message]) - hide-login-message]]) - ] - ;; Never dimmed, the same call the register form makes: a button that - ;; looks dead reads as a broken site and cannot say why it will not - ;; go. Pressing it always does something, and when the form is not - ;; ready that something is showing the faults it has been sitting on. - :tail [:button.form-button.form-submit-btn - {:on-click #(if invalid? - (swap! params assoc :attempted? true) - ((make-event-handler :password-reset @params)))} - "SUBMIT"]}))))) - -(defn login-link [] - [:span.underline.f-w-b.m-l-10.pointer.orange - {:on-click dispatch-route-to-login} - "LOGIN"]) - -(defn auth-outcome - "A page with nothing to ask for: a statement, and at most one `onward` action. - GOTCHA: `onward` is a button, not the inline link the register form uses -- - the one thing to do should look like it. See account-flows.md." - ([heading message] (auth-outcome heading message nil)) - ([heading message onward] - (auth-page heading - [:div.auth-outcome - [:div.auth-outcome-line message] - (when onward [:div.auth-outcome-onward onward])]))) - -(defn- login-button [] - [:button.form-button.form-submit-btn - {:on-click dispatch-route-to-login} - "LOGIN"]) - -(defn verify-success [] - (auth-outcome - "Success! Registration is complete" - "Your account is ready." - [login-button])) - -(defn password-reset-success [] - (auth-outcome - "Password changed" - "Use the new one from now on." - [login-button])) - -(defn unsubscribe-success [] - (auth-outcome - "Unsubscribed" - [:div - [:div "You will not get email updates from us any more."] - [:div.m-t-10 "You can turn them back on whenever you like, from your account settings."]])) - -(defn email-sent [text] - (auth-outcome "Check your email" text)) - -(defn verify-sent [] - (email-sent - [:div - [:span "We sent a verification email to "] - ;; Ink, not .red. Red is what a fault looks like on every one of these - ;; pages, and this is the address somebody just typed correctly. - [:span.auth-emphasis @(subscribe [:temp-email])] - [:span ". You must verify to complete registration and the link we sent will only be valid for 24 hours."] - [:span " "] - [:span "Remember to check your spam folder."]])) - -(defn password-reset-sent [] - ;; Conditional on purpose. The endpoint now answers identically for an address - ;; with no account, so this page is no longer in a position to claim that an - ;; email went out -- and claiming it would hand back the membership test the - ;; server stopped answering. - (email-sent - (str "If " - @(subscribe [:temp-email]) - " has an account, a link to reset your password is on its way."))) - -(def ^:private field-order - "The order the summary lists faults in, which is the order they appear on the - form. Sorting by map key would list them however the keywords happen to hash." - [[:username "Username"] [:email "Email address"] [:verify-email "Confirm email address"] - [:password "Password"] [:verify-password "Confirm password"] - [:first-and-last-name "Name"]]) - -(defn error-summary - "A list of faults above the form, each a link to its field, after a submit - that could not go through. Renders nothing until a submit has been attempted. - GOTCHA: counts FIELDS, not messages (two faults on one field count as one), - and each link's text is the fault message, not the field name -- prefixing - the field name would say it twice, and the link text is what a screen - reader reads on its own. See account-flows.md." - [validation] - (let [faults (for [[k label] field-order - :let [messages (seq (get validation k))] - :when messages] - [k label (first messages)])] - (when (seq faults) - [:div.auth-summary {:role "alert"} - [:div.auth-summary-title - (str (count faults) (if (= 1 (count faults)) - " thing needs fixing" - " things need fixing"))] - [:ul.auth-summary-list - (for [[k label message] faults] - ^{:key k} - [:li - [:a {:href (str "#f-" (name k)) - :on-click (fn [_] - (when-let [el (.getElementById js/document (str "f-" (name k)))] - (.focus el)))} - message]])]]))) - -(defn register-form [] - (let [base-validation @(subscribe [:registration-validation]) - registration-form @(subscribe [:registration-form]) - show-errors? @(subscribe [:registration-attempted?]) - ;; The confirmation is checked HERE, not in the shared validator, which - ;; runs on the server too and has no idea whether the field is currently - ;; revealed -- and a revealed password has no confirmation to differ from. - confirm-needed? (not (:password-revealed? registration-form)) - mismatch? (and confirm-needed? - (seq (:password registration-form)) - (not= (:password registration-form) - (:verify-password registration-form))) - registration-validation (cond-> base-validation - mismatch? - (update :verify-password conj "Passwords do not match")) - send-updates? (not= false (:send-updates? registration-form)) - ] - (auth-form-page - {:heading "Join for free" - :lede "Save your characters, share them, and pick up where you left off." - :legal-links? false - :fields - [:div - (when show-errors? [error-summary registration-validation]) - [form-input {:title "Username" - :key :username - :value (:username registration-form) - :messages (:username registration-validation) - :show-errors? show-errors? - :type :username - :on-change (fn [e] (dispatch [:registration-username (event-value e)]))}] - (let [suggestion (registration/suggest-email-domain (:email registration-form))] - [form-input {:title "Email" - :key :email - :value (:email registration-form) - :messages (:email registration-validation) - :show-errors? show-errors? - :type :email - :hint (when suggestion "That domain looks like a typo.") - :action (when suggestion - {:label (str "Use " suggestion) - :on-choose #(dispatch [:registration-email suggestion])}) - :on-change (fn [e] (dispatch [:registration-email (event-value e)]))}]) - [form-input {:title "Verify Email" - :key :verify-email - :value (:verify-email registration-form) - :messages (:verify-email registration-validation) - :show-errors? show-errors? - :type :email - :on-change (fn [e] (dispatch [:registration-verify-email (event-value e)]))}] - [password-fields - {:password (:password registration-form) - :confirm (:verify-password registration-form) - :context {:username (:username registration-form) - :email (:email registration-form)} - :messages (:password registration-validation) - :confirm-messages (:verify-password registration-validation) - :show-errors? show-errors? - :revealed? (boolean (:password-revealed? registration-form)) - :refused @(subscribe [:registration-password-common]) - :on-toggle #(dispatch [:registration-password-revealed? - (not (:password-revealed? registration-form))]) - :on-password (fn [e] (dispatch [:registration-password (event-value e)])) - :on-confirm (fn [e] (dispatch [:registration-verify-password (event-value e)]))}] - [:div.m-t-20.t-a-l.m-l-15 - [comps/labeled-checkbox (str "Yes! Send me updates about " branding/app-name) send-updates? false - #(dispatch [:registration-send-updates? (not send-updates?)])]] - [turnstile/widget] - ] - :tail - [:div - (when-let [notice @(subscribe [:registration-notice])] - [:div.m-t-10.registration-notice - (for [line notice] ^{:key line} [:div line])]) - ;; Not .m-b-10: that margin utility is bundled into a rule that sets - ;; font-weight bold across the whole app (styles/core.clj, .modal-container - ;; group). Using it here quietly emboldened this sentence. - [:div.m-t-10.m-b-5 - [:span "We will send a confirmation link to the address above."]] - ;; Never dimmed. A submit button that looks dead reads as a broken site - ;; rather than an unfinished form, and it cannot tell anyone WHY it will - ;; not go -- so pressing it always does something, and when the form is - ;; not ready that something is showing the faults it has been sitting on. - [:button.form-button.join-button - {:on-click #(if (empty? registration-validation) - (dispatch [:register]) - (dispatch [:registration-attempted]))} - "JOIN"] - [:div.m-t-20.auth-alt - [:span "Already have an account?"] - (login-link)] - ;; This page links both documents in its consent line, so the shell's - ;; footer keeps the copyright and drops its copies of the same two links. - [:div.auth-fineprint - "By joining you agree to our " - [:a {:href "/terms-of-use" :target :_blank} "Terms of Use"] - " and confirm you have read our " - [:a {:href "/privacy-policy" :target :_blank} "Privacy Policy"] - "."]]}))) - -(defn route-to-register-page [] - (dispatch [:route routes/register-page-route {:secure true :no-return? true}])) - -(defn route-to-reset-password-page [] - (dispatch [:route routes/send-password-reset-page-route {:secure? true :no-return? true}])) - -(defn login-page [] - (let [params (r/atom {})] - (fn [] - (let [login-message-shown? @(subscribe [:login-message-shown?]) - login-message @(subscribe [:login-message])] - ;; .login-form-inputs was this page's own container, so its fields were - ;; 350px where every other page's are the column's width, and the tail - ;; nested inside it came out narrower than the fields above it. It is on - ;; the same shape as the rest now. - (auth-form-page - {:heading "Welcome back" - :fields - [:div - [form-input {:title "Username or Email" - :key :username - :value (:username @params) - :type :username - :on-change #(swap! params assoc :username (event-value %))}] - [form-input {:title "Password" - :key :password - :value (:password @params) - :type :password - :on-change #(swap! params assoc :password (event-value %))}] - (when login-message-shown? - [:div.m-t-5 [notifications/message - :error - login-message - hide-login-message]])] - :tail - [:div - [:button.form-button.join-button - {:on-click #(dispatch [:login @params true])} - "LOGIN"] - ;; One group, one rhythm: each question and its answer share a line, - ;; the way the register page already asks its one. - [:div.m-t-20.auth-alts - [:div.auth-alt - [:span "Don't have a login?"] - [:span.orange.underline.pointer - {:on-click route-to-register-page} - "REGISTER NOW"]] - [:div.auth-alt - [:span "Forgot your password?"] - [:span.orange.underline.pointer - {:on-click route-to-reset-password-page} - "RESET PASSWORD"]]] - ;; Kept apart from the pair above: it is not another way in, it is - ;; what to do when the way in never arrived. - [:div.auth-help - [:span "Didn't receive the validation email? Check your spam folder, or "] - [:a.orange {:href "/help/im-not-getting-my-signup-password-reset-email/" :target "_blank"} - "read how to let our email through"] - [:span "."]]]}))))) - (def loading-style {:position :fixed :height "100%" diff --git a/src/cljs/orcpub/dnd/e5/views/auth.cljs b/src/cljs/orcpub/dnd/e5/views/auth.cljs new file mode 100644 index 000000000..3c20c0de2 --- /dev/null +++ b/src/cljs/orcpub/dnd/e5/views/auth.cljs @@ -0,0 +1,744 @@ +(ns orcpub.dnd.e5.views.auth + "The account screens: sign-up, login, verification and password reset pages, the outcome pages, + and the Cloudflare Turnstile widget the sign-up form carries. + The Turnstile widget (moved from orcpub.turnstile) loads only when the server put a site key on + the page (window.__TURNSTILE_SITE_KEY__), and only when the form mounts, so no other page + fetches anything from Cloudflare. Fails open on the client: if the script never loads, nothing + is blocked; the server decides." + (:require [re-frame.core :refer [subscribe dispatch]] + [reagent.core :as r] + [orcpub.route-map :as routes] + [orcpub.components :as comps :refer [text-color base-input form-input make-event-handler]] + [orcpub.registration :as registration] + [orcpub.fork.branding :as branding] + [orcpub.dnd.e5.views-2 :as views-2] + [orcpub.dnd.e5.views.notifications :as notifications] + [orcpub.dnd.e5.views.builder-fields :refer [event-value set-value]] + [clojure.string :as s])) + +;; ---- Cloudflare Turnstile widget (sign-up form, managed mode) ---- + +(def ^:private script-id "cf-turnstile-api") +(def ^:private script-src "https://challenges.cloudflare.com/turnstile/v0/api.js?render=explicit") + +(defn site-key + "The public site key, or nil when Turnstile is not configured." + [] + (let [k (aget js/window "__TURNSTILE_SITE_KEY__")] + (when (and (string? k) (seq k)) k))) + +(defonce ^:private widget-id (atom nil)) + +(defn- api [] (aget js/window "turnstile")) + +(defn- call-api + "Calls window.turnstile[method] by string name, so advanced compilation cannot rename it." + [method & args] + (let [t (api)] + (.apply (aget t method) t (to-array args)))) + +(defn- with-api + "Calls `f` once the Turnstile API is available, loading its script once. Never throws." + [f] + (if (api) + (f) + (if-let [existing (.getElementById js/document script-id)] + (.addEventListener existing "load" f) + (let [el (.createElement js/document "script")] + (set! (.-id el) script-id) + (set! (.-src el) script-src) + (set! (.-async el) true) + (set! (.-defer el) true) + (.addEventListener el "load" f) + ;; Script failed to load: leave the form as it is; the server fails open. + (.addEventListener el "error" (fn [_] (dispatch [:turnstile-token nil]))) + (.appendChild (.-head js/document) el))))) + +(defn reset-widget! + "Tokens are single use: asks the widget for a fresh one. No-op without a widget." + [] + (dispatch [:turnstile-token nil]) + (when-let [id @widget-id] + (try (call-api "reset" id) (catch :default _ nil)))) + +(defn- render! [el key] + (when (and (api) (nil? @widget-id) (.-isConnected el)) + (reset! widget-id + (try + (call-api "render" el + #js {:sitekey key + :callback (fn [token] (dispatch [:turnstile-token token])) + :expired-callback (fn [] (dispatch [:turnstile-token nil])) + :error-callback (fn [] (dispatch [:turnstile-token nil]))}) + (catch :default _ nil))))) + +(defn widget + "The challenge container. Renders nothing when no site key is configured." + [] + (when-let [key (site-key)] + (let [el (atom nil)] + (r/create-class + {:display-name "turnstile-widget" + :component-did-mount + (fn [_] (with-api #(when @el (render! @el key)))) + :component-will-unmount + (fn [_] + (when-let [id @widget-id] + (try (call-api "remove" id) (catch :default _ nil))) + (reset! widget-id nil) + (dispatch [:turnstile-token nil])) + :reagent-render + (fn [] [:div.m-t-10 {:ref #(reset! el %)}])})))) + +;; ---- Account screens ---- + +(def ^:private password-rule-chips + "One chip per rule: which rule it is, and whether `password` satisfies it. + GOTCHA: the \"not your name\" chip only renders where `ctx` has identifying + info -- the reset page passes none, so a context chip there would always + pass. See account-flows.md." + [{:label "12 or more" + :ok? (fn [p _] (>= (count (or p "")) registration/min-password-length))} + {:label "no triples" + :ok? (fn [p _] (not (registration/repeated-run? p)))} + {:label "no key runs" + :ok? (fn [p _] (not (registration/sequential-run? p)))} + {:label "some variety" + :ok? (fn [p _] (not (registration/too-few-distinct? p)))} + {:label "not your name" + :needs-context? true + :ok? (fn [p ctx] (not (registration/contains-identifier? p ctx)))}]) + +(def ^:private password-tips + "Per-rung lines to show once the password passes that rung, several per rung. + GOTCHA: `password-tip` picks among a rung's lines by text length, not + randomly, so the line holds still while typing instead of flickering on + every keystroke. See account-flows.md." + [["Two words that have no business together beat one clever one." + "Another word buys more than another symbol." + "Swapping o for 0 fools nobody. That is the first thing tried."] + ["Spaces are allowed. A short sentence types faster than it looks." + "One more word is the cheapest upgrade here." + "Nonsense is fine. It does not have to mean anything."] + ["Try something your character would say." + "One more word and this is as good as it gets." + "If you can picture it, you will remember it."] + ["Nothing left to prove. Write it down somewhere safe." + "About as good as it gets. Go make a character." + "Just do not use this one anywhere else."]]) + +(defn- password-tip + "The tip for this rung, held still by picking it from the length." + [rung length] + (when (and rung (not (neg? rung))) + (let [set (nth password-tips rung)] + (nth set (mod length (count set)))))) + +(defn password-meter + "The password-strength meter, shared by the register and reset forms. + `context` is identifying info the password must not contain, empty on the + reset page, which is also what the server judges it against. `refused` + shows \"too common\" once the server has rejected the password. + GOTCHA: only this meter checks live; the server enforces the same rules + silently otherwise. See account-flows.md." + ([password] (password-meter password nil nil)) + ([password context] (password-meter password context nil)) + ([password context refused] + (let [{:keys [rung fills]} (registration/password-strength password context) + tier-names ["Uncommon" "Rare" "Very Rare" "Legendary"] + ;; The corpus outranks the ladder. Only the server can reach it, so it + ;; arrives late and separately -- but a password it refuses is not a + ;; Rare one, and showing both is how the page ended up holding two + ;; verdicts that disagreed. + refused? (boolean (seq refused)) + reached? (and (not refused?) rung (not (neg? rung))) + suffix (cond refused? "fail" (nil? rung) nil (neg? rung) "fail" :else rung) + remaining (when (and reached? (< rung 3)) + (- (nth registration/strength-rungs (inc rung)) + (count (or password ""))))] + [:div.p-r-10.p-l-10.p-t-5 + [:div.pw-slots + (doall + (for [[i percent] (map-indexed vector fills)] + ^{:key i} + [:div.pw-slot + ;; The only inline style on this widget. The width IS the + ;; measurement, so it cannot be a named class. + [:div.pw-fill {:class (when suffix (str "pw-fill-" suffix)) + :style {:width (str percent "%")}}]]))] + [:div.pw-verdict + [:span.pw-tier-name {:class (when suffix (str "pw-name-" suffix))} + (cond refused? "Too common" + reached? (nth tier-names rung))] + [:span.pw-next + (cond + refused? nil + remaining (str (nth tier-names (inc rung)) " in " remaining) + (seq password) (str (count password) " characters"))]] + ;; Every rule, each as its own chip. Before this the five rules spoke only + ;; through whichever one happened to fail first, so nobody could see what + ;; was being asked of them until they had broken it. + (when (seq password) + [:div.pw-chips + (doall + (for [{:keys [label ok? needs-context?]} password-rule-chips + :when (or (not needs-context?) (seq (vals context)))] + ^{:key label} + [:span.pw-chip {:class (if (ok? password context) "is-ok" "is-bad")} + label])) + ;; Only the server can reach the corpus, so this appears once it has + ;; answered and never guesses in the meantime. + (when refused? [:span.pw-chip.is-bad "too common"])]) + ;; The line under the bar: what is wrong when something is, and what to do + ;; next when nothing is. It sits with the bar it is about rather than in + ;; the field's error slot, because both readings are advice on writing a + ;; better password, which is what the whole widget is. + (cond + refused? [:div.pw-note refused] + :else (when-let [tip (password-tip rung (count (or password "")))] + [:div.pw-note.is-tip tip]))]))) + +(defn password-pair + "A password field and its confirmation; revealing the password retires the + confirmation field entirely. + GOTCHA: the confirm field is REMOVED, not faded, on reveal -- faded would + stay in the accessibility tree and a submit could fail pointing at a field + nobody can see. `revealed?`/`on-toggle` are the caller's, since submit-gating + has to know confirmation isn't being asked for. See account-flows.md." + [{:keys [password confirm messages confirm-messages show-errors? revealed? + on-toggle on-password on-confirm]}] + [:div + [form-input {:title "Password" + :key :password + :value password + :type :password + :messages messages + :show-errors? show-errors? + :reveal? true + :revealed? revealed? + :on-reveal on-toggle + :on-change on-password}] + (when-not revealed? + [form-input {:title "Confirm password" + :key :verify-password + :value confirm + :type :password + ;; The caller may have more to say about this field than a + ;; mismatch -- the server answers per field too -- so its + ;; messages win when it passes any. + :messages (or (seq confirm-messages) + (when (and (seq password) (seq confirm) + (not= password confirm)) + ["Passwords do not match"])) + :show-errors? show-errors? + :on-change on-confirm}])]) + +(defn dispatch-route-to-login [e] + (.stopPropagation e) + (dispatch [:route-to-login])) + +(def registration-content-style + {:background-color :white + :border "1px solid white" + :color text-color}) + +(def registration-left-column-style + {:flex-direction :column + :width "435px"}) + +(def registration-header-style + {:height "65px" + :background-color "#1a2532" + :border-right "1px solid white"}) + +(defn route-to-default-page [] + (dispatch [:route :default])) + +(defn registration-page + "The shell every auth page renders through. `legal-links?` false suppresses the + footer's two links for a page that already carries them in its own consent copy." + ([content] (registration-page content true)) + ([content legal-links?] + [:div.sans.h-full.flex.flex-column + [:div.flex.justify-cont-s-a.align-items-c.flex-grow-1.h-100-p + [:div.registration-content + {:style registration-content-style} + [:div.flex.h-100-p + [:div.flex {:style registration-left-column-style} + [:div.flex.justify-cont-s-a.align-items-c + {:style registration-header-style} + [:img.pointer + {:class branding/registration-logo-class + :src branding/logo-path + :on-click route-to-default-page}]] + [:div.flex-grow-1 content] + [views-2/legal-footer legal-links?]] + [:div.registration-image]]]]])) + +(defn auth-page + "The shared auth shell: heading, rule, optional `lede` line, then `content`. + `lede` is the line under the rule and is optional. + See account-flows.md." + ([heading content] (auth-page heading nil content nil)) + ([heading lede content] (auth-page heading lede content nil)) + ([heading lede content {:keys [legal-links?] :or {legal-links? true}}] + (registration-page + [:div + [:h1.auth-heading.m-t-20 heading] + [:div.auth-rule] + (when lede [:div.auth-lede lede]) + content] + legal-links?))) + +(defn cookies [] + (let [cookie js/document.cookie] + (into {} + (map #(s/split % "=")) + (s/split cookie "; ")))) + +(defn- reset-username + "The username of the account a reset link is for, from the plain cookie the reset page sets. + Grants nothing; used only to flag \"password equals username\" while typing. The server + re-derives it from the link's key on submit. See account-flows.md." + [] + (some-> (get (cookies) "reset-username") js/decodeURIComponent)) + +(defn password-fields + "The password pair plus the strength meter under it, as one unit. + GOTCHA: state stays with the caller -- register keeps it in app-db, reset in + a local atom, since a reset form exists for ninety seconds behind a one-use + link. See account-flows.md." + [{:keys [password confirm revealed? context messages confirm-messages + show-errors? refused on-password on-confirm on-toggle]}] + [:div + [password-pair + {:password password + :confirm confirm + :messages messages + :confirm-messages confirm-messages + :show-errors? show-errors? + :revealed? revealed? + :on-toggle on-toggle + :on-password on-password + :on-confirm on-confirm}] + [password-meter password context refused]]) + +(defn auth-form-page + "An auth-page shell for a form: `fields` in a column, then `tail` (submit and + any links or fineprint) below them. + See account-flows.md." + [{:keys [heading lede fields tail legal-links?] + :or {legal-links? true}}] + (auth-page heading lede + [:div + [:div.m-t-10.auth-form fields] + (when tail [:div.m-t-10.auth-tail tail])] + {:legal-links? legal-links?})) + +(defn verify-failed [] + (let [params (r/atom {})] + (fn [] + (auth-form-page + {:heading "Your key has expired" + :lede (str "You must verify your email within 24 hours of registering. " + "Send another verification email by submitting your address here.") + :fields [base-input + {:name :email + :value (:email @params) + :type :email + :title "Email address" + :on-change (partial set-value params :email)}] + :tail [:button.form-button.form-submit-btn + {:on-click (make-event-handler :re-verify @params)} + "RESEND"]})))) + +(defn hide-login-message [] + (dispatch [:hide-login-message])) + +(defn send-password-reset-page [] + (let [params (r/atom {})] + (fn [error-message] + (let [email (:email @params) + bad-email? (registration/bad-email? email)] + (auth-form-page + {:heading "Reset your password" + :lede "Submit your email address and we will send you a link to reset your password." + :fields + [:div + (when error-message [:div.red.m-b-20 error-message]) + [form-input + {:title "Email" + :key :email + :messages (if bad-email? + ["Not a valid email address"] + []) + :type :email + :value email + :on-change (partial set-value params :email)}] + (when @(subscribe [:login-message-shown?]) + [:div.m-t-5.p-r-5.p-l-5 + [notifications/message + :error + @(subscribe [:login-message]) + hide-login-message]]) + ] + :tail + [:div + [:button.form-button.form-submit-btn + {:class (when bad-email? "disabled opacity-5 hover-no-shadow") + :on-click (when (not bad-email?) (make-event-handler :send-password-reset @params))} + "SUBMIT"] + ;; The link text is the whole phrase, not the one word "whitelist" in + ;; the middle of it: a single word is a small target, and it is what a + ;; screen reader announces on its own, where it names no destination. + [:div.auth-help + [:span "Didn't receive the reset email? Check your spam folder, or "] + [:a.orange {:href "/help/im-not-getting-my-signup-password-reset-email/" :target "_blank"} + "read how to let our email through"] + [:span ", then try again."]]]}))))) + +(defn password-reset-expired-page [] + ;; Reached by an expired link AND by one that is mangled or unrecognised, so + ;; the wording cannot claim to know which. It also no longer says 24 hours, + ;; which stopped being true when the window became two. + [send-password-reset-page + (str "That reset link no longer works. Links last " + "two hours, and each one can only be used once. " + "Send yourself a new one below.")]) + +(defn password-reset-used-page [] + [send-password-reset-page "Your reset link has already been used. Please use the form below to send another reset email."]) + +(defn password-validation-messages [password] + (-> password + registration/validate-password + :password)) + +(defn password-reset-page [] + (let [params (r/atom {})] + (fn [] + (let [password (:password @params) + verify-password (:verify-password @params) + ;; Merged per field, so a server objection -- a common password, the + ;; one rule only the server can apply -- sits alongside whatever the + ;; form already found rather than replacing it. + server-errors @(subscribe [:password-reset-server-errors]) + ;; GOTCHA: context carries only the username, never email, to avoid a disclosure + ;; via cookie; the server checks email separately on submit. See account-flows.md. + context {:username (reset-username)} + ;; Reading the password back is what the confirm box stands in for, + ;; so revealing it retires the box -- and the check that decides + ;; whether this can be submitted has to know that, which is why the + ;; flag is out here rather than inside password-pair. + revealed? (:password-revealed? @params) + faults (registration/password-pair-faults password verify-password + revealed? context) + password-messages (vec (distinct (concat (:password faults) + (:password server-errors)))) + confirm-messages (vec (distinct (concat (:verify-password faults) + (:verify-password server-errors)))) + invalid? (or (seq password-messages) (seq confirm-messages)) + ;; Local to this page's own atom on purpose. The register form keeps + ;; the same flag in app-db, and reaching for that from here is what + ;; split the reveal state between a db read and a component atom + ;; last time. + attempted? (:attempted? @params)] + (auth-form-page + {:heading "Choose a new password" + :lede "This replaces the password on your account." + :fields + [:div + ;; The same pair and meter the register form uses. + ;; GOTCHA: this is account RECOVERY, the last door somebody has -- a + ;; silently dimmed button with no message is worse here than anywhere + ;; else. See account-flows.md. + [password-fields + {:password password + :confirm verify-password + :context context + :messages password-messages + :confirm-messages confirm-messages + :show-errors? attempted? + :revealed? revealed? + :refused (first (:password-common server-errors)) + :on-toggle #(swap! params update :password-revealed? not) + :on-password (fn [e] + (dispatch [:password-reset-clear-errors]) + (swap! params assoc :password (event-value e))) + :on-confirm (fn [e] + (dispatch [:password-reset-clear-errors]) + (swap! params assoc :verify-password (event-value e)))}] + (when @(subscribe [:login-message-shown?]) + [:div.m-t-5.p-r-5.p-l-5 [notifications/message + :error + @(subscribe [:login-message]) + hide-login-message]]) + ] + ;; Never dimmed, the same call the register form makes: a button that + ;; looks dead reads as a broken site and cannot say why it will not + ;; go. Pressing it always does something, and when the form is not + ;; ready that something is showing the faults it has been sitting on. + :tail [:button.form-button.form-submit-btn + {:on-click #(if invalid? + (swap! params assoc :attempted? true) + ((make-event-handler :password-reset @params)))} + "SUBMIT"]}))))) + +(defn login-link [] + [:span.underline.f-w-b.m-l-10.pointer.orange + {:on-click dispatch-route-to-login} + "LOGIN"]) + +(defn auth-outcome + "A page with nothing to ask for: a statement, and at most one `onward` action. + GOTCHA: `onward` is a button, not the inline link the register form uses -- + the one thing to do should look like it. See account-flows.md." + ([heading message] (auth-outcome heading message nil)) + ([heading message onward] + (auth-page heading + [:div.auth-outcome + [:div.auth-outcome-line message] + (when onward [:div.auth-outcome-onward onward])]))) + +(defn- login-button [] + [:button.form-button.form-submit-btn + {:on-click dispatch-route-to-login} + "LOGIN"]) + +(defn verify-success [] + (auth-outcome + "Success! Registration is complete" + "Your account is ready." + [login-button])) + +(defn password-reset-success [] + (auth-outcome + "Password changed" + "Use the new one from now on." + [login-button])) + +(defn unsubscribe-success [] + (auth-outcome + "Unsubscribed" + [:div + [:div "You will not get email updates from us any more."] + [:div.m-t-10 "You can turn them back on whenever you like, from your account settings."]])) + +(defn email-sent [text] + (auth-outcome "Check your email" text)) + +(defn verify-sent [] + (email-sent + [:div + [:span "We sent a verification email to "] + ;; Ink, not .red. Red is what a fault looks like on every one of these + ;; pages, and this is the address somebody just typed correctly. + [:span.auth-emphasis @(subscribe [:temp-email])] + [:span ". You must verify to complete registration and the link we sent will only be valid for 24 hours."] + [:span " "] + [:span "Remember to check your spam folder."]])) + +(defn password-reset-sent [] + ;; Conditional on purpose. The endpoint now answers identically for an address + ;; with no account, so this page is no longer in a position to claim that an + ;; email went out -- and claiming it would hand back the membership test the + ;; server stopped answering. + (email-sent + (str "If " + @(subscribe [:temp-email]) + " has an account, a link to reset your password is on its way."))) + +(def ^:private field-order + "The order the summary lists faults in, which is the order they appear on the + form. Sorting by map key would list them however the keywords happen to hash." + [[:username "Username"] [:email "Email address"] [:verify-email "Confirm email address"] + [:password "Password"] [:verify-password "Confirm password"] + [:first-and-last-name "Name"]]) + +(defn error-summary + "A list of faults above the form, each a link to its field, after a submit + that could not go through. Renders nothing until a submit has been attempted. + GOTCHA: counts FIELDS, not messages (two faults on one field count as one), + and each link's text is the fault message, not the field name -- prefixing + the field name would say it twice, and the link text is what a screen + reader reads on its own. See account-flows.md." + [validation] + (let [faults (for [[k label] field-order + :let [messages (seq (get validation k))] + :when messages] + [k label (first messages)])] + (when (seq faults) + [:div.auth-summary {:role "alert"} + [:div.auth-summary-title + (str (count faults) (if (= 1 (count faults)) + " thing needs fixing" + " things need fixing"))] + [:ul.auth-summary-list + (for [[k label message] faults] + ^{:key k} + [:li + [:a {:href (str "#f-" (name k)) + :on-click (fn [_] + (when-let [el (.getElementById js/document (str "f-" (name k)))] + (.focus el)))} + message]])]]))) + +(defn register-form [] + (let [base-validation @(subscribe [:registration-validation]) + registration-form @(subscribe [:registration-form]) + show-errors? @(subscribe [:registration-attempted?]) + ;; The confirmation is checked HERE, not in the shared validator, which + ;; runs on the server too and has no idea whether the field is currently + ;; revealed -- and a revealed password has no confirmation to differ from. + confirm-needed? (not (:password-revealed? registration-form)) + mismatch? (and confirm-needed? + (seq (:password registration-form)) + (not= (:password registration-form) + (:verify-password registration-form))) + registration-validation (cond-> base-validation + mismatch? + (update :verify-password conj "Passwords do not match")) + send-updates? (not= false (:send-updates? registration-form)) + ] + (auth-form-page + {:heading "Join for free" + :lede "Save your characters, share them, and pick up where you left off." + :legal-links? false + :fields + [:div + (when show-errors? [error-summary registration-validation]) + [form-input {:title "Username" + :key :username + :value (:username registration-form) + :messages (:username registration-validation) + :show-errors? show-errors? + :type :username + :on-change (fn [e] (dispatch [:registration-username (event-value e)]))}] + (let [suggestion (registration/suggest-email-domain (:email registration-form))] + [form-input {:title "Email" + :key :email + :value (:email registration-form) + :messages (:email registration-validation) + :show-errors? show-errors? + :type :email + :hint (when suggestion "That domain looks like a typo.") + :action (when suggestion + {:label (str "Use " suggestion) + :on-choose #(dispatch [:registration-email suggestion])}) + :on-change (fn [e] (dispatch [:registration-email (event-value e)]))}]) + [form-input {:title "Verify Email" + :key :verify-email + :value (:verify-email registration-form) + :messages (:verify-email registration-validation) + :show-errors? show-errors? + :type :email + :on-change (fn [e] (dispatch [:registration-verify-email (event-value e)]))}] + [password-fields + {:password (:password registration-form) + :confirm (:verify-password registration-form) + :context {:username (:username registration-form) + :email (:email registration-form)} + :messages (:password registration-validation) + :confirm-messages (:verify-password registration-validation) + :show-errors? show-errors? + :revealed? (boolean (:password-revealed? registration-form)) + :refused @(subscribe [:registration-password-common]) + :on-toggle #(dispatch [:registration-password-revealed? + (not (:password-revealed? registration-form))]) + :on-password (fn [e] (dispatch [:registration-password (event-value e)])) + :on-confirm (fn [e] (dispatch [:registration-verify-password (event-value e)]))}] + [:div.m-t-20.t-a-l.m-l-15 + [comps/labeled-checkbox (str "Yes! Send me updates about " branding/app-name) send-updates? false + #(dispatch [:registration-send-updates? (not send-updates?)])]] + [widget] + ] + :tail + [:div + (when-let [notice @(subscribe [:registration-notice])] + [:div.m-t-10.registration-notice + (for [line notice] ^{:key line} [:div line])]) + ;; Not .m-b-10: that margin utility is bundled into a rule that sets + ;; font-weight bold across the whole app (styles/core.clj, .modal-container + ;; group). Using it here quietly emboldened this sentence. + [:div.m-t-10.m-b-5 + [:span "We will send a confirmation link to the address above."]] + ;; Never dimmed. A submit button that looks dead reads as a broken site + ;; rather than an unfinished form, and it cannot tell anyone WHY it will + ;; not go -- so pressing it always does something, and when the form is + ;; not ready that something is showing the faults it has been sitting on. + [:button.form-button.join-button + {:on-click #(if (empty? registration-validation) + (dispatch [:register]) + (dispatch [:registration-attempted]))} + "JOIN"] + [:div.m-t-20.auth-alt + [:span "Already have an account?"] + (login-link)] + ;; This page links both documents in its consent line, so the shell's + ;; footer keeps the copyright and drops its copies of the same two links. + [:div.auth-fineprint + "By joining you agree to our " + [:a {:href "/terms-of-use" :target :_blank} "Terms of Use"] + " and confirm you have read our " + [:a {:href "/privacy-policy" :target :_blank} "Privacy Policy"] + "."]]}))) + +(defn route-to-register-page [] + (dispatch [:route routes/register-page-route {:secure true :no-return? true}])) + +(defn route-to-reset-password-page [] + (dispatch [:route routes/send-password-reset-page-route {:secure? true :no-return? true}])) + +(defn login-page [] + (let [params (r/atom {})] + (fn [] + (let [login-message-shown? @(subscribe [:login-message-shown?]) + login-message @(subscribe [:login-message])] + ;; .login-form-inputs was this page's own container, so its fields were + ;; 350px where every other page's are the column's width, and the tail + ;; nested inside it came out narrower than the fields above it. It is on + ;; the same shape as the rest now. + (auth-form-page + {:heading "Welcome back" + :fields + [:div + [form-input {:title "Username or Email" + :key :username + :value (:username @params) + :type :username + :on-change #(swap! params assoc :username (event-value %))}] + [form-input {:title "Password" + :key :password + :value (:password @params) + :type :password + :on-change #(swap! params assoc :password (event-value %))}] + (when login-message-shown? + [:div.m-t-5 [notifications/message + :error + login-message + hide-login-message]])] + :tail + [:div + [:button.form-button.join-button + {:on-click #(dispatch [:login @params true])} + "LOGIN"] + ;; One group, one rhythm: each question and its answer share a line, + ;; the way the register page already asks its one. + [:div.m-t-20.auth-alts + [:div.auth-alt + [:span "Don't have a login?"] + [:span.orange.underline.pointer + {:on-click route-to-register-page} + "REGISTER NOW"]] + [:div.auth-alt + [:span "Forgot your password?"] + [:span.orange.underline.pointer + {:on-click route-to-reset-password-page} + "RESET PASSWORD"]]] + ;; Kept apart from the pair above: it is not another way in, it is + ;; what to do when the way in never arrived. + [:div.auth-help + [:span "Didn't receive the validation email? Check your spam folder, or "] + [:a.orange {:href "/help/im-not-getting-my-signup-password-reset-email/" :target "_blank"} + "read how to let our email through"] + [:span "."]]]}))))) diff --git a/src/cljs/orcpub/turnstile.cljs b/src/cljs/orcpub/turnstile.cljs deleted file mode 100644 index 4fef363e6..000000000 --- a/src/cljs/orcpub/turnstile.cljs +++ /dev/null @@ -1,79 +0,0 @@ -(ns orcpub.turnstile - "Cloudflare Turnstile widget for the sign-up form (managed mode). - Loaded only when the server put a site key on the page (window.__TURNSTILE_SITE_KEY__), - and only when the form mounts, so no other page fetches anything from Cloudflare. - Fails open on the client: if the script never loads, nothing is blocked; the server decides." - (:require [reagent.core :as r] - [re-frame.core :refer [dispatch]])) - -(def ^:private script-id "cf-turnstile-api") -(def ^:private script-src "https://challenges.cloudflare.com/turnstile/v0/api.js?render=explicit") - -(defn site-key - "The public site key, or nil when Turnstile is not configured." - [] - (let [k (aget js/window "__TURNSTILE_SITE_KEY__")] - (when (and (string? k) (seq k)) k))) - -(defonce ^:private widget-id (atom nil)) - -(defn- api [] (aget js/window "turnstile")) - -(defn- call-api - "Calls window.turnstile[method] by string name, so advanced compilation cannot rename it." - [method & args] - (let [t (api)] - (.apply (aget t method) t (to-array args)))) - -(defn- with-api - "Calls `f` once the Turnstile API is available, loading its script once. Never throws." - [f] - (if (api) - (f) - (if-let [existing (.getElementById js/document script-id)] - (.addEventListener existing "load" f) - (let [el (.createElement js/document "script")] - (set! (.-id el) script-id) - (set! (.-src el) script-src) - (set! (.-async el) true) - (set! (.-defer el) true) - (.addEventListener el "load" f) - ;; Script failed to load: leave the form as it is; the server fails open. - (.addEventListener el "error" (fn [_] (dispatch [:turnstile-token nil]))) - (.appendChild (.-head js/document) el))))) - -(defn reset-widget! - "Tokens are single use: asks the widget for a fresh one. No-op without a widget." - [] - (dispatch [:turnstile-token nil]) - (when-let [id @widget-id] - (try (call-api "reset" id) (catch :default _ nil)))) - -(defn- render! [el key] - (when (and (api) (nil? @widget-id) (.-isConnected el)) - (reset! widget-id - (try - (call-api "render" el - #js {:sitekey key - :callback (fn [token] (dispatch [:turnstile-token token])) - :expired-callback (fn [] (dispatch [:turnstile-token nil])) - :error-callback (fn [] (dispatch [:turnstile-token nil]))}) - (catch :default _ nil))))) - -(defn widget - "The challenge container. Renders nothing when no site key is configured." - [] - (when-let [key (site-key)] - (let [el (atom nil)] - (r/create-class - {:display-name "turnstile-widget" - :component-did-mount - (fn [_] (with-api #(when @el (render! @el key)))) - :component-will-unmount - (fn [_] - (when-let [id @widget-id] - (try (call-api "remove" id) (catch :default _ nil))) - (reset! widget-id nil) - (dispatch [:turnstile-token nil])) - :reagent-render - (fn [] [:div.m-t-10 {:ref #(reset! el %)}])})))) diff --git a/web/cljs/orcpub/core.cljs b/web/cljs/orcpub/core.cljs index 5318bd7b5..e38438e47 100644 --- a/web/cljs/orcpub/core.cljs +++ b/web/cljs/orcpub/core.cljs @@ -6,6 +6,7 @@ [orcpub.dnd.e5.events :as events] [orcpub.dnd.e5.db :as db] [orcpub.dnd.e5.views :as views] + [orcpub.dnd.e5.views.auth :as auth-views] [orcpub.dnd.e5.views-2 :as views-2] [orcpub.dnd.e5.views.conflict-resolution :as conflict-views] [orcpub.dnd.e5.views.whats-new :as whats-new-view] @@ -112,18 +113,18 @@ routes/dnd-e5-char-parties-page-route views/parties routes/dnd-e5-my-content-route views/my-content-page routes/my-account-page-route views/my-account-page - routes/register-page-route views/register-form - routes/verify-failed-route views/verify-failed - routes/verify-success-route views/verify-success - routes/verify-sent-route views/verify-sent - routes/login-page-route views/login-page - routes/send-password-reset-page-route views/send-password-reset-page - routes/password-reset-sent-route views/password-reset-sent - routes/reset-password-page-route views/password-reset-page - routes/password-reset-success-route views/password-reset-success - routes/password-reset-expired-route views/password-reset-expired-page - routes/password-reset-used-route views/password-reset-used-page - routes/unsubscribe-success-route views/unsubscribe-success + routes/register-page-route auth-views/register-form + routes/verify-failed-route auth-views/verify-failed + routes/verify-success-route auth-views/verify-success + routes/verify-sent-route auth-views/verify-sent + routes/login-page-route auth-views/login-page + routes/send-password-reset-page-route auth-views/send-password-reset-page + routes/password-reset-sent-route auth-views/password-reset-sent + routes/reset-password-page-route auth-views/password-reset-page + routes/password-reset-success-route auth-views/password-reset-success + routes/password-reset-expired-route auth-views/password-reset-expired-page + routes/password-reset-used-route auth-views/password-reset-used-page + routes/unsubscribe-success-route auth-views/unsubscribe-success routes/artists-page-route artist-page/artists-page routes/artist-page-route artist-page/artist-page}) From 97a617363297a7cd5fc915a9abccc88f5a6304d0 Mon Sep 17 00:00:00 2001 From: codeGlaze Date: Wed, 4 Nov 2026 04:24:18 +0000 Subject: [PATCH 08/27] Move the account events into events/auth --- src/cljc/orcpub/dnd/e5/event_utils.cljc | 8 +- src/cljs/orcpub/dnd/e5/events.cljs | 382 +--------------------- src/cljs/orcpub/dnd/e5/events/auth.cljs | 387 +++++++++++++++++++++++ test/cljs/orcpub/dnd/e5/events_test.cljs | 2 + test/cljs/orcpub/dnd/e5/subs_test.cljs | 2 + web/cljs/orcpub/core.cljs | 3 +- 6 files changed, 401 insertions(+), 383 deletions(-) create mode 100644 src/cljs/orcpub/dnd/e5/events/auth.cljs diff --git a/src/cljc/orcpub/dnd/e5/event_utils.cljc b/src/cljc/orcpub/dnd/e5/event_utils.cljc index cac6185a7..76e9dfbd7 100644 --- a/src/cljc/orcpub/dnd/e5/event_utils.cljc +++ b/src/cljc/orcpub/dnd/e5/event_utils.cljc @@ -5,7 +5,8 @@ (:require [orcpub.modifiers :as mod] [orcpub.route-map :as routes] [clojure.string :as s] - #?(:cljs [re-frame.core :refer [dispatch]]))) + #?(:cljs [re-frame.core :refer [dispatch after]]) + #?(:cljs [orcpub.dnd.e5.db :refer [user->local-store]]))) ;; -- URL helpers (CLJS-only: depend on js/window.location) -- @@ -43,6 +44,11 @@ {"Authorization" (str "Token " token)} {})) +;; -- Local store -- + +#?(:cljs +(def user->local-store-interceptor (after (fn [db] (user->local-store (:user-data db)))))) + ;; -- Error helpers -- (defn show-generic-error diff --git a/src/cljs/orcpub/dnd/e5/events.cljs b/src/cljs/orcpub/dnd/e5/events.cljs index d2c29a805..a88ea8f81 100644 --- a/src/cljs/orcpub/dnd/e5/events.cljs +++ b/src/cljs/orcpub/dnd/e5/events.cljs @@ -53,7 +53,6 @@ keep-draft! unsaved-drafts draft-visible? - user->local-store magic-item->local-store spell->local-store monster->local-store @@ -109,7 +108,7 @@ [orcpub.dnd.e5.homebrew-check :as homebrew-check] [orcpub.dnd.e5.library :as library] [orcpub.dnd.e5.picks :as picks] - [orcpub.dnd.e5.event-utils :as event-utils] + [orcpub.dnd.e5.event-utils :as event-utils :refer [user->local-store-interceptor]] [orcpub.dnd.e5.compute :as compute] [re-frame.core :refer [reg-event-db reg-event-fx reg-fx reg-cofx inject-cofx path after dispatch ->interceptor reg-global-interceptor]] @@ -119,12 +118,8 @@ [cljs-time.core :as time] [cljs.reader :as reader] [clojure.string :as s] - [bidi.bidi :as bidi] [orcpub.route-map :as routes] - [orcpub.errors :as errors] [orcpub.fork.integrations :as integrations] - [orcpub.fork.branding :as branding] - [orcpub.dnd.e5.views.auth :as views-auth] [clojure.set :as sets] [cljsjs.filesaverjs] [clojure.pprint :as pprint]) @@ -162,8 +157,6 @@ (fn [character] (character->local-store character))) -(def user->local-store-interceptor (after (fn [db] (user->local-store (:user-data db))))) - (def magic-item->local-store-interceptor (after magic-item->local-store)) (def spell->local-store-interceptor (after spell->local-store)) @@ -2322,53 +2315,6 @@ :headers (authorization-headers db) :url (backend-url path)}}))) -(reg-event-fx - :change-email - (fn [{:keys [db]} [_ new-email current-password]] - {:db (dissoc db :email-change-sent? :email-change-error) - :http {:method :put - :headers (authorization-headers db) - :url (backend-url (routes/path-for routes/user-email-route)) - ;; The password is sent to be COMPARED, never stored and never read - ;; back: the server hands it to lookup-user, which checks the hash. - :transit-params {:new-email new-email - :current-password current-password} - :on-success [:change-email-success] - :on-failure [:change-email-failure]}})) - -(reg-event-db - :change-email-success - (fn [db [_ response]] - (-> db - (assoc :email-change-sent? true) - ;; Use server-canonical (lowercased/trimmed) email for display - (assoc-in [:user-data :user-data :pending-email] - (-> response :body :pending-email))))) - -(reg-event-db - :change-email-failure - (fn [db [_ response]] - (let [body (:body response) - error (:error body)] - (assoc db :email-change-error - (case error - :bad-credentials "That password is not right. The account stays on its current address." - :email-taken "That email address is already in use by another account." - :invalid-email "Please enter a valid email address." - :same-as-current "That is already your current email address." - :too-many-requests - (let [secs (:retry-after-secs body)] - (if (and secs (pos? secs)) - (if (<= secs 60) - ;; 0–1 min zone: email is in transit, show short countdown - (str "Your email is on its way. You can resend in " secs " second" (when (> secs 1) "s") ".") - ;; 1–5 min zone for a different email: show minutes - (let [mins (.ceil js/Math (/ secs 60))] - (str "Please wait " mins " minute" (when (> mins 1) "s") " before requesting another change."))) - "Please wait a few minutes before requesting another email change.")) - :email-send-failed "Verification email could not be sent. Please try again later." - "There was an error updating your email. Please try again."))))) - (reg-event-fx :withdraw-sessions (fn [{:keys [db]} _] @@ -2392,11 +2338,6 @@ (assoc db :sessions-withdraw-error "Could not sign your other sessions out. Please try again."))) -(reg-event-db - :change-email-clear - (fn [db _] - (dissoc db :email-change-sent? :email-change-error))) - ;; ─── Account Settings ────────────────────────────────────────────── ;; The account page re-reads the user on open: what the login response cached ;; can be stale -- an account made an artist account since, say. @@ -3437,18 +3378,6 @@ (fn [db [_ user-data]] (update db :user-data merge user-data))) -(reg-event-db - :clear-login - [user->local-store-interceptor] - ;; With a token: only while that is still the login, so a 401 that answers a login already - ;; replaced does not sign the new one out. - (fn [db [_ expected-token]] - (if (or (nil? expected-token) (= expected-token (event-utils/get-auth-token db))) - (-> db - (update :user-data dissoc :user-data :token) - (dissoc :user)) - db))) - ;; Startup auth check — validates stored token on app load (core.cljs) and keeps the account it ;; answers in db :user, the one GET /user of a page load. ;; Clears stale sessions before reg-sub-raw subs fire HTTP with expired tokens. @@ -3698,268 +3627,6 @@ (fn [path] (.pushState js/window.history {} nil path))) -(def login-url (backend-url "/login")) - -(reg-event-fx - :login-success - [user->local-store-interceptor] - (fn [{:keys [db]} [_ backtrack? response]] - ;; A button-text choice saved on the account wins over this browser's. - {:db (let [account-choice (-> response :body :user-data :dark-button-text?)] - (cond-> (-> db - (update :user-data merge (-> response :body)) - (assoc :user (-> response :body :user-data))) - (some? account-choice) (assoc-in [:user-data :dark-button-text?] account-choice))) - :dispatch [:route (or - (:return-route db) - routes/dnd-e5-char-builder-route)]})) - -(defn sign-in-failed-message [] - ;; Deliberately vague about which half was wrong: naming the username as unknown - ;; would make this form a membership-disclosure oracle. See account-flows.md. - [:show-login-message - [:div "That username and password do not match. Usernames and passwords are case sensitive, " - "email addresses are not. If you have not signed up yet you can " - [:a {:href (routes/path-for routes/register-page-route)} "register"] "."]]) - -(defn dispatch-login-failure [message] - {:dispatch-n [[:clear-login] - [:show-login-message message]]}) - -(reg-event-fx - :login-failure - (fn [{:keys [db]} [_ response]] - (let [error-code (-> response :body :error)] - (cond - (= error-code errors/username-required) (dispatch-login-failure "Username is required.") - (= error-code errors/too-many-attempts) (dispatch-login-failure "Too many attempts just now. Wait a minute and try again.") - (= error-code errors/password-required) (dispatch-login-failure "Password is required.") - (= error-code errors/bad-credentials) {:dispatch-n [[:clear-login] - (sign-in-failed-message)]} - (= error-code errors/unverified) {:db (assoc db :temp-email (-> response :body :email)) - :dispatch [:route routes/verify-sent-route]} - (= error-code errors/unverified-expired) {:dispatch [:route routes/verify-failed-route]} - :else (dispatch-login-failure - (if (seq branding/support-email) - [:div "An error occurred. If the problem persists please email " - [:a {:href (str "mailto:" branding/support-email) :target :blank} branding/support-email]] - [:div "An error occurred. Please try again later."])))))) - -(reg-event-fx - :logout - ;; Only the player's own Log Out: the builder starts fresh, the draft stays under its account. - ;; An expired session clears the login (:clear-login) without touching the builder. - (fn [cofx [_ response]] - {:dispatch-n [[:clear-login] [:reset-character]]})) - -(def login-routes - #{routes/login-page-route - routes/register-page-route - routes/verify-sent-route - routes/reset-password-page-route - routes/verify-failed-route - routes/verify-success-route - routes/send-password-reset-page-route - routes/password-reset-success-route - routes/password-reset-expired-route - routes/password-reset-used-route - routes/unsubscribe-success-route}) - -(reg-event-fx - :login - (fn [{:keys [db]} [_ params backtrack?]] - {:http {:method :post - :url login-url - :json-params params - :on-success [:login-success backtrack?] - :on-unauthorized [:login-failure]}})) - -(reg-event-db - :register-success - (fn [db [_ backtrack? response]] - ;; A deployment with no EMAIL_SERVER_URL verifies on creation and says so - ;; with :verified? -- sending such a user to "check your email" would point - ;; them at a mail that is never coming. - (let [verified? (get-in response [:body :verified?])] - (-> db - (update :user-data merge (:body response)) - (assoc :route (if verified? :verify-success :verify-sent)))))) - -(reg-event-db - :registration-attempted - ;; Set when JOIN is pressed on a form that is not ready. The button no longer - ;; dims -- a control that looks dead teaches people the site is broken rather - ;; than that their form is -- so pressing it has to SAY something instead. - (fn [db _] - (assoc db :registration-attempted? true))) - -(reg-event-fx - :register-failure - ;; :registration-server-errors holds what only the server can judge, shown by field; any other - ;; failure becomes a :general notice, so no server-side failure is silent. account-flows.md. - (fn [{:keys [db]} [_ response]] - (let [body (:body response)] - {:db (assoc db :registration-server-errors - (cond - (= :email-not-configured (:error body)) - {:general ["Registration is currently unavailable. Please contact the site administrator."]} - (and (map? body) (not (contains? body :error))) body - :else {:general ["Registration failed. Please try again."]})) - ;; A Turnstile token is single use: any failed attempt needs a fresh one. - :dispatch-n [[:clear-login] [:turnstile-reset]]}))) - -(reg-event-db - :turnstile-token - (fn [db [_ token]] - (assoc db :turnstile-token token))) - -(reg-event-fx - :turnstile-reset - (fn [_ _] - (views-auth/reset-widget!) - nil)) - -#_ ;; dead stub — real impl is orcpub.registration/validate-registration - (defn validate-registration []) - - -(reg-event-db - :email-taken - (fn [db [_ response]] - (assoc db :email-taken? (-> response :body (= "true"))))) - -(reg-event-db - :username-taken - (fn [db [_ response]] - (assoc db :username-taken? (-> response :body (= "true"))))) - -#_ ;; never dispatched — registration form uses :register-first-and-last-name - (reg-event-db - :registration-first-and-last-name - (fn [db [_ first-and-last-name]] - (assoc-in db [:registration-form :first-and-last-name] first-and-last-name))) - -(reg-event-fx - :registration-email - (fn [{:keys [db]} [_ email]] - {:db (assoc-in db [:registration-form :email] email) - :dispatch [:check-email email]})) - -(reg-event-fx - :registration-verify-email - (fn [{:keys [db]} [_ email]] - {:db (assoc-in db [:registration-form :verify-email] email)})) - -(reg-event-fx - :registration-username - (fn [{:keys [db]} [_ username]] - {:db (assoc-in db [:registration-form :username] username) - :dispatch [:check-username username]})) - -(reg-event-db - :registration-password - (fn [db [_ password]] - (-> db - ;; What the server said was about the password it was sent, not this one. - (dissoc :registration-server-errors) - (assoc-in [:registration-form :password] password)))) - -(reg-event-db - :registration-password-revealed? - ;; In the db rather than a local atom: whatever decides the form may be - ;; submitted has to know the confirmation is not being asked for, and a reveal - ;; hidden inside the field component is invisible to it. - (fn [db [_ revealed?]] - (assoc-in db [:registration-form :password-revealed?] revealed?))) - -(reg-event-db - :registration-verify-password - (fn [db [_ password]] - (-> db - (dissoc :registration-server-errors) - (assoc-in [:registration-form :verify-password] password)))) - -(reg-event-db - :registration-send-updates? - (fn [db [_ send-updates?]] - (assoc-in db [:registration-form :send-updates?] send-updates?))) - -#_ ;; never dispatched from UI - (reg-event-db - :register-first-and-last-name - (fn [db [_ first-and-last-name]] - (assoc-in db [:registration-form :first-and-last-name] first-and-last-name))) - -(reg-event-fx - :check-email - (fn [{:keys [db]} [_ email]] - {:http {:method :get - :url (backend-url (bidi/path-for routes/routes routes/check-email-route)) - :query-params {:email email} - :on-success [:email-taken]}})) - -(reg-event-fx - :check-username - (fn [{:keys [db]} [_ username]] - {:http {:method :get - :url (backend-url (bidi/path-for routes/routes routes/check-username-route)) - :query-params {:username username} - :on-success [:username-taken]}})) - -(reg-event-fx - :register - (fn [{:keys [db]} [_ params backtrack?]] - (let [registration-form (:registration-form db)] - {:db (assoc db :temp-email (:email registration-form)) - :http {:method :post - :url (backend-url (bidi/path-for routes/routes routes/register-route)) - :json-params (cond-> registration-form - (:turnstile-token db) (assoc :turnstile-token (:turnstile-token db))) - :on-success [:register-success backtrack?] - :on-failure [:register-failure]}}))) - -(reg-event-db - :re-verify-success - (fn [db [_ response]] - ;; With no SMTP and ALLOW_UNVERIFIED_REGISTRATION set, a resend verifies the - ;; account on the spot and says so -- "check your email" would leave the user - ;; waiting for a message that is never sent. - (assoc db :route (if (get-in response [:body :verified?]) - routes/verify-success-route - routes/verify-sent-route)))) - -(reg-event-fx - :re-verify - (fn [{:keys [db]} [_ params]] - {:db (assoc db :temp-email (:email params)) - :http {:method :get - :url (backend-url (bidi/path-for routes/routes routes/re-verify-route)) - :query-params params - :on-success [:re-verify-success]}})) - -(reg-event-db - :send-password-reset-success - (fn [db []] - (assoc db :route routes/password-reset-sent-route))) - -(reg-event-fx - :send-password-reset-failure - ;; The endpoint answers 200 for every address now, so :no-account cannot arrive - ;; here and the branch that handled it is gone. Anything reaching this handler - ;; is a network or server fault, which is what the generic error is for. - (fn [_ _] - (show-generic-error))) - -(reg-event-fx - :send-password-reset - (fn [{:keys [db]} [_ params]] - {:db (assoc db :temp-email (:email params)) - :http {:method :get - :url (backend-url (bidi/path-for routes/routes routes/send-password-reset-route)) - :query-params params - :on-success [:send-password-reset-success] - :on-failure [:send-password-reset-failure]}})) - ;; never dispatched — character loading uses :load-user-data flow #_(reg-event-db :load-characters-success @@ -3977,53 +3644,6 @@ :url (backend-url (routes/path-for routes/dnd-e5-char-list-route)) :on-success [:load-characters-success]}})) -(reg-event-db - :password-reset-success - (fn [db []] - (assoc db :route routes/password-reset-success-route))) - -(reg-event-fx - :password-reset-failure - ;; The same bug :register-failure had: the body was thrown away and replaced - ;; with one generic sentence, so a password refused for being a common one said - ;; only that something had gone wrong, and the obvious next move was to try the - ;; same password again. The server's reasons are field-keyed; keep them. - (fn [{:keys [db]} [_ response]] - (let [errors (when (map? (:body response)) (:body response))] - (cond - ;; An expired or used link: nothing in the form can fix it. - (:general errors) (dispatch-login-failure (first (:general errors))) - (seq errors) - {:db (assoc db :password-reset-server-errors errors)} - :else - ;; A failure with nothing to say -- a network drop, a 500 -- still needs - ;; to say something. - (dispatch-login-failure "There was an error resetting your password."))))) - -(reg-event-db - :password-reset-clear-errors - ;; What the server said was about the password it was sent, not this one. - (fn [db _] - (dissoc db :password-reset-server-errors))) - -(reg-event-fx - :password-reset - ;; The link's key is the only authority the server takes for a reset; there is no session. - (fn [{:keys [db]} [_ params]] - (let [reset-key (.get (js/URLSearchParams. (.. js/window -location -search)) "key")] - {:db (assoc db :temp-email (:email params)) - :http {:method :post - :url (backend-url (bidi/path-for routes/routes routes/reset-password-route)) - ;; A revealed password has no confirm box; the server still compares the two fields. - :json-params {:password (:password params) - :verify-password (if (:password-revealed? params) - (:password params) - (:verify-password params)) - :key reset-key} - :on-success [:password-reset-success] - :on-unauthorized [:password-reset-failure] - :on-failure [:password-reset-failure]}}))) - (reg-event-db ::char5e/set-characters (fn [db [_ characters]] diff --git a/src/cljs/orcpub/dnd/e5/events/auth.cljs b/src/cljs/orcpub/dnd/e5/events/auth.cljs new file mode 100644 index 000000000..5fbf19ce8 --- /dev/null +++ b/src/cljs/orcpub/dnd/e5/events/auth.cljs @@ -0,0 +1,387 @@ +(ns orcpub.dnd.e5.events.auth + "The re-frame events for accounts: sign-up and its form fields, login and logout, the + verification and password reset requests, and the email change. Moved out of + orcpub.dnd.e5.events; this namespace never requires it. Required from web/cljs/orcpub/core.cljs + so the handlers are registered before anything dispatches them." + (:require [bidi.bidi :as bidi] + [orcpub.dnd.e5.event-utils :as event-utils + :refer [backend-url show-generic-error user->local-store-interceptor + auth-headers] + :rename {auth-headers authorization-headers}] + [orcpub.dnd.e5.views.auth :as views-auth] + [orcpub.errors :as errors] + [orcpub.fork.branding :as branding] + [orcpub.route-map :as routes] + [re-frame.core :refer [reg-event-db reg-event-fx]])) + +(reg-event-fx + :change-email + (fn [{:keys [db]} [_ new-email current-password]] + {:db (dissoc db :email-change-sent? :email-change-error) + :http {:method :put + :headers (authorization-headers db) + :url (backend-url (routes/path-for routes/user-email-route)) + ;; The password is sent to be COMPARED, never stored and never read + ;; back: the server hands it to lookup-user, which checks the hash. + :transit-params {:new-email new-email + :current-password current-password} + :on-success [:change-email-success] + :on-failure [:change-email-failure]}})) + +(reg-event-db + :change-email-success + (fn [db [_ response]] + (-> db + (assoc :email-change-sent? true) + ;; Use server-canonical (lowercased/trimmed) email for display + (assoc-in [:user-data :user-data :pending-email] + (-> response :body :pending-email))))) + +(reg-event-db + :change-email-failure + (fn [db [_ response]] + (let [body (:body response) + error (:error body)] + (assoc db :email-change-error + (case error + :bad-credentials "That password is not right. The account stays on its current address." + :email-taken "That email address is already in use by another account." + :invalid-email "Please enter a valid email address." + :same-as-current "That is already your current email address." + :too-many-requests + (let [secs (:retry-after-secs body)] + (if (and secs (pos? secs)) + (if (<= secs 60) + ;; 0–1 min zone: email is in transit, show short countdown + (str "Your email is on its way. You can resend in " secs " second" (when (> secs 1) "s") ".") + ;; 1–5 min zone for a different email: show minutes + (let [mins (.ceil js/Math (/ secs 60))] + (str "Please wait " mins " minute" (when (> mins 1) "s") " before requesting another change."))) + "Please wait a few minutes before requesting another email change.")) + :email-send-failed "Verification email could not be sent. Please try again later." + "There was an error updating your email. Please try again."))))) + +(reg-event-db + :change-email-clear + (fn [db _] + (dissoc db :email-change-sent? :email-change-error))) + +(reg-event-db + :clear-login + [user->local-store-interceptor] + ;; With a token: only while that is still the login, so a 401 that answers a login already + ;; replaced does not sign the new one out. + (fn [db [_ expected-token]] + (if (or (nil? expected-token) (= expected-token (event-utils/get-auth-token db))) + (-> db + (update :user-data dissoc :user-data :token) + (dissoc :user)) + db))) + +(def login-url (backend-url "/login")) + +(reg-event-fx + :login-success + [user->local-store-interceptor] + (fn [{:keys [db]} [_ backtrack? response]] + ;; A button-text choice saved on the account wins over this browser's. + {:db (let [account-choice (-> response :body :user-data :dark-button-text?)] + (cond-> (-> db + (update :user-data merge (-> response :body)) + (assoc :user (-> response :body :user-data))) + (some? account-choice) (assoc-in [:user-data :dark-button-text?] account-choice))) + :dispatch [:route (or + (:return-route db) + routes/dnd-e5-char-builder-route)]})) + +(defn sign-in-failed-message [] + ;; Deliberately vague about which half was wrong: naming the username as unknown + ;; would make this form a membership-disclosure oracle. See account-flows.md. + [:show-login-message + [:div "That username and password do not match. Usernames and passwords are case sensitive, " + "email addresses are not. If you have not signed up yet you can " + [:a {:href (routes/path-for routes/register-page-route)} "register"] "."]]) + +(defn dispatch-login-failure [message] + {:dispatch-n [[:clear-login] + [:show-login-message message]]}) + +(reg-event-fx + :login-failure + (fn [{:keys [db]} [_ response]] + (let [error-code (-> response :body :error)] + (cond + (= error-code errors/username-required) (dispatch-login-failure "Username is required.") + (= error-code errors/too-many-attempts) (dispatch-login-failure "Too many attempts just now. Wait a minute and try again.") + (= error-code errors/password-required) (dispatch-login-failure "Password is required.") + (= error-code errors/bad-credentials) {:dispatch-n [[:clear-login] + (sign-in-failed-message)]} + (= error-code errors/unverified) {:db (assoc db :temp-email (-> response :body :email)) + :dispatch [:route routes/verify-sent-route]} + (= error-code errors/unverified-expired) {:dispatch [:route routes/verify-failed-route]} + :else (dispatch-login-failure + (if (seq branding/support-email) + [:div "An error occurred. If the problem persists please email " + [:a {:href (str "mailto:" branding/support-email) :target :blank} branding/support-email]] + [:div "An error occurred. Please try again later."])))))) + +(reg-event-fx + :logout + ;; Only the player's own Log Out: the builder starts fresh, the draft stays under its account. + ;; An expired session clears the login (:clear-login) without touching the builder. + (fn [cofx [_ response]] + {:dispatch-n [[:clear-login] [:reset-character]]})) + +(def login-routes + #{routes/login-page-route + routes/register-page-route + routes/verify-sent-route + routes/reset-password-page-route + routes/verify-failed-route + routes/verify-success-route + routes/send-password-reset-page-route + routes/password-reset-success-route + routes/password-reset-expired-route + routes/password-reset-used-route + routes/unsubscribe-success-route}) + +(reg-event-fx + :login + (fn [{:keys [db]} [_ params backtrack?]] + {:http {:method :post + :url login-url + :json-params params + :on-success [:login-success backtrack?] + :on-unauthorized [:login-failure]}})) + +(reg-event-db + :register-success + (fn [db [_ backtrack? response]] + ;; A deployment with no EMAIL_SERVER_URL verifies on creation and says so + ;; with :verified? -- sending such a user to "check your email" would point + ;; them at a mail that is never coming. + (let [verified? (get-in response [:body :verified?])] + (-> db + (update :user-data merge (:body response)) + (assoc :route (if verified? :verify-success :verify-sent)))))) + +(reg-event-db + :registration-attempted + ;; Set when JOIN is pressed on a form that is not ready. The button no longer + ;; dims -- a control that looks dead teaches people the site is broken rather + ;; than that their form is -- so pressing it has to SAY something instead. + (fn [db _] + (assoc db :registration-attempted? true))) + +(reg-event-fx + :register-failure + ;; :registration-server-errors holds what only the server can judge, shown by field; any other + ;; failure becomes a :general notice, so no server-side failure is silent. account-flows.md. + (fn [{:keys [db]} [_ response]] + (let [body (:body response)] + {:db (assoc db :registration-server-errors + (cond + (= :email-not-configured (:error body)) + {:general ["Registration is currently unavailable. Please contact the site administrator."]} + (and (map? body) (not (contains? body :error))) body + :else {:general ["Registration failed. Please try again."]})) + ;; A Turnstile token is single use: any failed attempt needs a fresh one. + :dispatch-n [[:clear-login] [:turnstile-reset]]}))) + +(reg-event-db + :turnstile-token + (fn [db [_ token]] + (assoc db :turnstile-token token))) + +(reg-event-fx + :turnstile-reset + (fn [_ _] + (views-auth/reset-widget!) + nil)) + +#_ ;; dead stub — real impl is orcpub.registration/validate-registration + (defn validate-registration []) + +(reg-event-db + :email-taken + (fn [db [_ response]] + (assoc db :email-taken? (-> response :body (= "true"))))) + +(reg-event-db + :username-taken + (fn [db [_ response]] + (assoc db :username-taken? (-> response :body (= "true"))))) + +#_ ;; never dispatched — registration form uses :register-first-and-last-name + (reg-event-db + :registration-first-and-last-name + (fn [db [_ first-and-last-name]] + (assoc-in db [:registration-form :first-and-last-name] first-and-last-name))) + +(reg-event-fx + :registration-email + (fn [{:keys [db]} [_ email]] + {:db (assoc-in db [:registration-form :email] email) + :dispatch [:check-email email]})) + +(reg-event-fx + :registration-verify-email + (fn [{:keys [db]} [_ email]] + {:db (assoc-in db [:registration-form :verify-email] email)})) + +(reg-event-fx + :registration-username + (fn [{:keys [db]} [_ username]] + {:db (assoc-in db [:registration-form :username] username) + :dispatch [:check-username username]})) + +(reg-event-db + :registration-password + (fn [db [_ password]] + (-> db + ;; What the server said was about the password it was sent, not this one. + (dissoc :registration-server-errors) + (assoc-in [:registration-form :password] password)))) + +(reg-event-db + :registration-password-revealed? + ;; In the db rather than a local atom: whatever decides the form may be + ;; submitted has to know the confirmation is not being asked for, and a reveal + ;; hidden inside the field component is invisible to it. + (fn [db [_ revealed?]] + (assoc-in db [:registration-form :password-revealed?] revealed?))) + +(reg-event-db + :registration-verify-password + (fn [db [_ password]] + (-> db + (dissoc :registration-server-errors) + (assoc-in [:registration-form :verify-password] password)))) + +(reg-event-db + :registration-send-updates? + (fn [db [_ send-updates?]] + (assoc-in db [:registration-form :send-updates?] send-updates?))) + +#_ ;; never dispatched from UI + (reg-event-db + :register-first-and-last-name + (fn [db [_ first-and-last-name]] + (assoc-in db [:registration-form :first-and-last-name] first-and-last-name))) + +(reg-event-fx + :check-email + (fn [{:keys [db]} [_ email]] + {:http {:method :get + :url (backend-url (bidi/path-for routes/routes routes/check-email-route)) + :query-params {:email email} + :on-success [:email-taken]}})) + +(reg-event-fx + :check-username + (fn [{:keys [db]} [_ username]] + {:http {:method :get + :url (backend-url (bidi/path-for routes/routes routes/check-username-route)) + :query-params {:username username} + :on-success [:username-taken]}})) + +(reg-event-fx + :register + (fn [{:keys [db]} [_ params backtrack?]] + (let [registration-form (:registration-form db)] + {:db (assoc db :temp-email (:email registration-form)) + :http {:method :post + :url (backend-url (bidi/path-for routes/routes routes/register-route)) + :json-params (cond-> registration-form + (:turnstile-token db) (assoc :turnstile-token (:turnstile-token db))) + :on-success [:register-success backtrack?] + :on-failure [:register-failure]}}))) + +(reg-event-db + :re-verify-success + (fn [db [_ response]] + ;; With no SMTP and ALLOW_UNVERIFIED_REGISTRATION set, a resend verifies the + ;; account on the spot and says so -- "check your email" would leave the user + ;; waiting for a message that is never sent. + (assoc db :route (if (get-in response [:body :verified?]) + routes/verify-success-route + routes/verify-sent-route)))) + +(reg-event-fx + :re-verify + (fn [{:keys [db]} [_ params]] + {:db (assoc db :temp-email (:email params)) + :http {:method :get + :url (backend-url (bidi/path-for routes/routes routes/re-verify-route)) + :query-params params + :on-success [:re-verify-success]}})) + +(reg-event-db + :send-password-reset-success + (fn [db []] + (assoc db :route routes/password-reset-sent-route))) + +(reg-event-fx + :send-password-reset-failure + ;; The endpoint answers 200 for every address now, so :no-account cannot arrive + ;; here and the branch that handled it is gone. Anything reaching this handler + ;; is a network or server fault, which is what the generic error is for. + (fn [_ _] + (show-generic-error))) + +(reg-event-fx + :send-password-reset + (fn [{:keys [db]} [_ params]] + {:db (assoc db :temp-email (:email params)) + :http {:method :get + :url (backend-url (bidi/path-for routes/routes routes/send-password-reset-route)) + :query-params params + :on-success [:send-password-reset-success] + :on-failure [:send-password-reset-failure]}})) + +(reg-event-db + :password-reset-success + (fn [db []] + (assoc db :route routes/password-reset-success-route))) + +(reg-event-fx + :password-reset-failure + ;; The same bug :register-failure had: the body was thrown away and replaced + ;; with one generic sentence, so a password refused for being a common one said + ;; only that something had gone wrong, and the obvious next move was to try the + ;; same password again. The server's reasons are field-keyed; keep them. + (fn [{:keys [db]} [_ response]] + (let [errors (when (map? (:body response)) (:body response))] + (cond + ;; An expired or used link: nothing in the form can fix it. + (:general errors) (dispatch-login-failure (first (:general errors))) + (seq errors) + {:db (assoc db :password-reset-server-errors errors)} + :else + ;; A failure with nothing to say -- a network drop, a 500 -- still needs + ;; to say something. + (dispatch-login-failure "There was an error resetting your password."))))) + +(reg-event-db + :password-reset-clear-errors + ;; What the server said was about the password it was sent, not this one. + (fn [db _] + (dissoc db :password-reset-server-errors))) + +(reg-event-fx + :password-reset + ;; The link's key is the only authority the server takes for a reset; there is no session. + (fn [{:keys [db]} [_ params]] + (let [reset-key (.get (js/URLSearchParams. (.. js/window -location -search)) "key")] + {:db (assoc db :temp-email (:email params)) + :http {:method :post + :url (backend-url (bidi/path-for routes/routes routes/reset-password-route)) + ;; A revealed password has no confirm box; the server still compares the two fields. + :json-params {:password (:password params) + :verify-password (if (:password-revealed? params) + (:password params) + (:verify-password params)) + :key reset-key} + :on-success [:password-reset-success] + :on-unauthorized [:password-reset-failure] + :on-failure [:password-reset-failure]}}))) diff --git a/test/cljs/orcpub/dnd/e5/events_test.cljs b/test/cljs/orcpub/dnd/e5/events_test.cljs index 4071de1bb..40db850eb 100644 --- a/test/cljs/orcpub/dnd/e5/events_test.cljs +++ b/test/cljs/orcpub/dnd/e5/events_test.cljs @@ -27,6 +27,8 @@ [orcpub.dnd.e5 :as e5] [orcpub.entity :as entity] [orcpub.dnd.e5.character :as char5e] + ;; the account events (:logout, :clear-login) are registered here + [orcpub.dnd.e5.events.auth] [orcpub.dnd.e5.magic-items :as mi] [orcpub.dnd.e5.spells :as spells] [orcpub.dnd.e5.units :as units5e] diff --git a/test/cljs/orcpub/dnd/e5/subs_test.cljs b/test/cljs/orcpub/dnd/e5/subs_test.cljs index 4a68cf59c..56765df8f 100644 --- a/test/cljs/orcpub/dnd/e5/subs_test.cljs +++ b/test/cljs/orcpub/dnd/e5/subs_test.cljs @@ -15,6 +15,8 @@ [cljs-http.client :as http] [cljs.core.async :as async] [orcpub.dnd.e5.character :as char5e] + ;; the account events (:logout, :clear-login) are registered here + [orcpub.dnd.e5.events.auth] [orcpub.dnd.e5.party :as party5e] [orcpub.dnd.e5.folder :as folder5e] [orcpub.dnd.e5.api-subs :as api-subs] diff --git a/web/cljs/orcpub/core.cljs b/web/cljs/orcpub/core.cljs index e38438e47..038dc0bd4 100644 --- a/web/cljs/orcpub/core.cljs +++ b/web/cljs/orcpub/core.cljs @@ -4,6 +4,7 @@ [orcpub.dnd.e5.subs] [orcpub.dnd.e5.equipment-subs] [orcpub.dnd.e5.events :as events] + [orcpub.dnd.e5.events.auth :as events-auth] [orcpub.dnd.e5.db :as db] [orcpub.dnd.e5.views :as views] [orcpub.dnd.e5.views.auth :as auth-views] @@ -132,7 +133,7 @@ (let [route (when js/window.location (routes/match-route js/window.location.pathname)) config {:skip-path? true}] - (dispatch [:route route (if (events/login-routes (:handler route)) + (dispatch [:route route (if (events-auth/login-routes (:handler route)) (merge config {:no-return? true}) From 1563000630df046c4ff9f695b5524abf1d06a375 Mon Sep 17 00:00:00 2001 From: codeGlaze Date: Wed, 4 Nov 2026 14:08:42 +0000 Subject: [PATCH 09/27] Move page wrappers into orcpub.index and reset-password-page into routes.auth default-title, default-description, default-image-url, index-page-response, default-index-page and index leave routes.clj for index.clj, which already holds index-page; routes.clj refers them so call sites are unchanged. reset-password-page moves to routes/auth.clj (its auth/ prefixes dropped). Tests retargeted. --- src/clj/orcpub/index.clj | 38 ++++++++++- src/clj/orcpub/routes.clj | 67 +------------------ src/clj/orcpub/routes/auth.clj | 28 ++++++++ .../orcpub/portrait_artists_endpoint_test.clj | 3 +- test/clj/orcpub/routes_test.clj | 2 +- 5 files changed, 70 insertions(+), 68 deletions(-) diff --git a/src/clj/orcpub/index.clj b/src/clj/orcpub/index.clj index 9e5a4f319..78b0a3899 100644 --- a/src/clj/orcpub/index.clj +++ b/src/clj/orcpub/index.clj @@ -8,6 +8,7 @@ [orcpub.favicon :as fi] [orcpub.fork.integrations :as integrations] [orcpub.loading-spinner :as spinner] + [orcpub.artist-credit :as artist-credit] [orcpub.env :as env] [orcpub.config :as config] [orcpub.pedestal :as pedestal])) @@ -324,4 +325,39 @@ html { }); } "))))]]))) - \ No newline at end of file + + +(def default-title branding/default-page-title) + +(def default-description branding/app-tagline) + +(defn default-image-url + "OG meta image URL. Uses https:// for social sharing compatibility." + [host] + (str "https://" host branding/og-image-filename)) + +(defn index-page-response [{:keys [headers uri csp-nonce] :as request} + {:keys [title description image-url]} + & [response]] + (let [host (headers "host")] + ;; before index-page reads the credits into __BRANDING__ + (when-let [db (:db request)] (artist-credit/refresh! db)) + (merge + response + {:status 200 + :headers (merge {"Content-Type" "text/html"} (:headers response)) + :body + (index-page + {:url (str "http://" host uri) + :title (or title default-title) + :description (or description default-description) + :image (or image-url (default-image-url host)) + :nonce csp-nonce + :spinner-kind (spinner/pick (get-in request [:query-params :spinner]))} + (= "/" uri))}))) + +(defn default-index-page [request & [response]] + (index-page-response request {} response)) + +(defn index [{:keys [headers scheme uri server-name] :as request} & [response]] + (default-index-page request response)) diff --git a/src/clj/orcpub/routes.clj b/src/clj/orcpub/routes.clj index 2105b08af..b4b8e45ad 100644 --- a/src/clj/orcpub/routes.clj +++ b/src/clj/orcpub/routes.clj @@ -42,8 +42,7 @@ [orcpub.privacy :as privacy] [orcpub.config :as config] [orcpub.email :as email] - [orcpub.loading-spinner :as spinner] - [orcpub.index :refer [index-page]] + [orcpub.index :refer [index index-page-response default-index-page]] [orcpub.pdf :as pdf] [orcpub.pdf.draw :as draw] [orcpub.pdf.cards :as cards] @@ -1083,68 +1082,6 @@ :headers {"Content-Type" "text/html"}})] merged)) -(def default-title branding/default-page-title) - -(def default-description branding/app-tagline) - -(defn default-image-url - "OG meta image URL. Uses https:// for social sharing compatibility." - [host] - (str "https://" host branding/og-image-filename)) - -(defn index-page-response [{:keys [headers uri csp-nonce] :as request} - {:keys [title description image-url]} - & [response]] - (let [host (headers "host")] - ;; before index-page reads the credits into __BRANDING__ - (when-let [db (:db request)] (artist-credit/refresh! db)) - (merge - response - {:status 200 - :headers (merge {"Content-Type" "text/html"} (:headers response)) - :body - (index-page - {:url (str "http://" host uri) - :title (or title default-title) - :description (or description default-description) - :image (or image-url (default-image-url host)) - :nonce csp-nonce - :spinner-kind (spinner/pick (get-in request [:query-params :spinner]))} - (= "/" uri))}))) - -(defn default-index-page [request & [response]] - (index-page-response request {} response)) - -(defn index [{:keys [headers scheme uri server-name] :as request} & [response]] - (default-index-page request response)) - -(defn reset-password-page [{:keys [query-params db] :as req}] - (let [key (:key query-params) - {:keys [:db/id - :orcpub.user/username - :orcpub.user/password-reset-sent - :orcpub.user/password-reset] :as user} - ;; The link carries the key; the table holds only its digest. - (when-not (s/blank? key) - (auth/first-user-by db auth/user-by-password-reset-key-query (auth/hash-reset-key key))) - expired? (auth/reset-link-expired? user) - already-reset? (auth/password-already-reset? password-reset password-reset-sent)] - (cond - ;; Covers both no key at all and a key matching nobody, so neither bare-strings - ;; a "Key is required" error nor falls through to :else and signs a token for - ;; a nil username. A mangled link and an expired one are the same event to the - ;; reader -- it doesn't work -- so both land on the page offering to send a new one. - (nil? id) (auth/redirect route-map/password-reset-expired-route) - expired? (auth/redirect route-map/password-reset-expired-route) - already-reset? (auth/redirect route-map/password-reset-used-route) - ;; No session: the key in the URL is what the form submits. The username cookie grants - ;; nothing; it lets the meter flag a password equal to it. no-referrer keeps the key out of - ;; the Referer of anything this page loads. - :else (index req {:headers {"Referrer-Policy" "no-referrer"} - :cookies {"reset-username" {:value username :path "/" - :max-age (* auth/password-reset-valid-hours 3600) - :same-site :strict}}})))) - (defn character-for-id [db id] (d/pull db '[*] id)) @@ -2089,7 +2026,7 @@ [(route-map/path-for route-map/reset-password-route) ^:interceptors [ring/cookies] {:post `auth/reset-password}] [(route-map/path-for route-map/reset-password-page-route) ^:interceptors [ring/cookies] - {:get `reset-password-page}] + {:get `auth/reset-password-page}] [(route-map/path-for route-map/send-password-reset-route) {:get `auth/send-password-reset}] [(route-map/path-for route-map/privacy-policy-route) diff --git a/src/clj/orcpub/routes/auth.clj b/src/clj/orcpub/routes/auth.clj index f88e6fee0..e10828b2c 100644 --- a/src/clj/orcpub/routes/auth.clj +++ b/src/clj/orcpub/routes/auth.clj @@ -15,6 +15,7 @@ [orcpub.errors :as errors] [orcpub.fork.auth :as fork-auth] [orcpub.fork.user-data :as user-data] + [orcpub.index :refer [index]] [orcpub.outbox :as outbox] [orcpub.pwned :as pwned] [orcpub.registration :as registration] @@ -828,3 +829,30 @@ (security/audit! :email-change-requested request username) {:status 200 :body {:pending-email new-email}}))))) (catch Throwable e (prn e) (throw e)))) + +(defn reset-password-page [{:keys [query-params db] :as req}] + (let [key (:key query-params) + {:keys [:db/id + :orcpub.user/username + :orcpub.user/password-reset-sent + :orcpub.user/password-reset] :as user} + ;; The link carries the key; the table holds only its digest. + (when-not (s/blank? key) + (first-user-by db user-by-password-reset-key-query (hash-reset-key key))) + expired? (reset-link-expired? user) + already-reset? (password-already-reset? password-reset password-reset-sent)] + (cond + ;; Covers both no key at all and a key matching nobody, so neither bare-strings + ;; a "Key is required" error nor falls through to :else and signs a token for + ;; a nil username. A mangled link and an expired one are the same event to the + ;; reader -- it doesn't work -- so both land on the page offering to send a new one. + (nil? id) (redirect route-map/password-reset-expired-route) + expired? (redirect route-map/password-reset-expired-route) + already-reset? (redirect route-map/password-reset-used-route) + ;; No session: the key in the URL is what the form submits. The username cookie grants + ;; nothing; it lets the meter flag a password equal to it. no-referrer keeps the key out of + ;; the Referer of anything this page loads. + :else (index req {:headers {"Referrer-Policy" "no-referrer"} + :cookies {"reset-username" {:value username :path "/" + :max-age (* password-reset-valid-hours 3600) + :same-site :strict}}})))) diff --git a/test/clj/orcpub/portrait_artists_endpoint_test.clj b/test/clj/orcpub/portrait_artists_endpoint_test.clj index 89b7193c6..1e82bbc8b 100644 --- a/test/clj/orcpub/portrait_artists_endpoint_test.clj +++ b/test/clj/orcpub/portrait_artists_endpoint_test.clj @@ -5,6 +5,7 @@ [orcpub.db.schema :as schema] [orcpub.dnd.e5.portrait-assets :as pa] [orcpub.routes :as routes] + [orcpub.index :as index] [orcpub.route-map] [cheshire.core]) (:import [java.util UUID])) @@ -35,7 +36,7 @@ (deftest an-artist-credit-is-never-written-into-the-page (with-conn conn (artist! conn) - (let [html (:body (routes/index-page-response {:db (d/db conn) :headers {"host" "example.test"} :uri "/"} + (let [html (:body (index/index-page-response {:db (d/db conn) :headers {"host" "example.test"} :uri "/"} {:title "t" :description "d"}))] (is (string? html)) (is (not (re-find #"MARK" html)) "artist-editable text reaches the browser as data, not page source")))) diff --git a/test/clj/orcpub/routes_test.clj b/test/clj/orcpub/routes_test.clj index 6e20c8020..58a692dce 100644 --- a/test/clj/orcpub/routes_test.clj +++ b/test/clj/orcpub/routes_test.clj @@ -675,7 +675,7 @@ (with-redefs-fn {#'auth/breach-errors (constantly nil)} (fn [] (testing "opening the link grants no session" - (let [resp (routes/reset-password-page {:query-params {:key reset-key} :db (d/db c) + (let [resp (auth/reset-password-page {:query-params {:key reset-key} :db (d/db c) :headers {"host" "example.test"} :uri "/reset-password-page"})] (is (= 200 (:status resp))) From 1f5a4b36b8336ef2cdf32d4c24bdf00ae297af44 Mon Sep 17 00:00:00 2001 From: codeGlaze Date: Wed, 4 Nov 2026 14:23:53 +0000 Subject: [PATCH 10/27] Move the auth card's inline styles into Garden registration-content-style, registration-left-column-style and registration-header-style become .registration-content (background, border, colour), the existing .registration-left-col and .registration-header. Two named colours, auth-card-ink and auth-banner-ground, replace the literals. Computed styles and screenshots at 1280x900 and 390x844 are unchanged. The password meter's fill width stays inline: it is the measurement. --- src/clj/orcpub/styles/core.clj | 9 +++++++-- src/cljs/orcpub/dnd/e5/views/auth.cljs | 22 +++------------------- 2 files changed, 10 insertions(+), 21 deletions(-) diff --git a/src/clj/orcpub/styles/core.clj b/src/clj/orcpub/styles/core.clj index 188fc77b4..aacb891af 100644 --- a/src/clj/orcpub/styles/core.clj +++ b/src/clj/orcpub/styles/core.clj @@ -25,6 +25,8 @@ ;; card, 4.52:1 as a border on its own tint -- never run as text ON that tint, which only clears 4.52:1 (AA-scrape). ;; Ink/muted on the white auth card: 8.9:1 and 4.6:1 respectively (counterparts to muted-on-dark). (def text-color-light "#4b545e") +(def auth-card-ink "#484848") ; body text on the white auth card (the old text-color in views/auth) +(def auth-banner-ground "#1a2532") ; the logo band above the auth card's form (def muted-on-light "#6b7681") (def error-red "#d4351c") (def error-tint "#fdf5f6") @@ -950,7 +952,10 @@ ;; its OWN font-size, not an inherited pixel value -- unset here, text renders ;; SOLID, descenders hitting the next line's ascenders. Set once on the card for ;; a readable default; boxes with tuned geometry pin their own below. - {:line-height "1.5"} + {:line-height "1.5" + :background-color :white + :border "1px solid white" + :color auth-card-ink} [:.red {:color red} [:a :a:visited {:color red}]] @@ -3922,7 +3927,7 @@ [:.registration-header {:height "65px" - :background-color "#1a2532" + :background-color auth-banner-ground :border-right "1px solid white"}] [:.registration-left-col diff --git a/src/cljs/orcpub/dnd/e5/views/auth.cljs b/src/cljs/orcpub/dnd/e5/views/auth.cljs index 3c20c0de2..81e0bb1b3 100644 --- a/src/cljs/orcpub/dnd/e5/views/auth.cljs +++ b/src/cljs/orcpub/dnd/e5/views/auth.cljs @@ -8,7 +8,7 @@ (:require [re-frame.core :refer [subscribe dispatch]] [reagent.core :as r] [orcpub.route-map :as routes] - [orcpub.components :as comps :refer [text-color base-input form-input make-event-handler]] + [orcpub.components :as comps :refer [base-input form-input make-event-handler]] [orcpub.registration :as registration] [orcpub.fork.branding :as branding] [orcpub.dnd.e5.views-2 :as views-2] @@ -237,20 +237,6 @@ (.stopPropagation e) (dispatch [:route-to-login])) -(def registration-content-style - {:background-color :white - :border "1px solid white" - :color text-color}) - -(def registration-left-column-style - {:flex-direction :column - :width "435px"}) - -(def registration-header-style - {:height "65px" - :background-color "#1a2532" - :border-right "1px solid white"}) - (defn route-to-default-page [] (dispatch [:route :default])) @@ -262,11 +248,9 @@ [:div.sans.h-full.flex.flex-column [:div.flex.justify-cont-s-a.align-items-c.flex-grow-1.h-100-p [:div.registration-content - {:style registration-content-style} [:div.flex.h-100-p - [:div.flex {:style registration-left-column-style} - [:div.flex.justify-cont-s-a.align-items-c - {:style registration-header-style} + [:div.flex.registration-left-col + [:div.flex.justify-cont-s-a.align-items-c.registration-header [:img.pointer {:class branding/registration-logo-class :src branding/logo-path From 7eae494a38df55aabfcb0c746b66df7561e14158 Mon Sep 17 00:00:00 2001 From: codeGlaze Date: Wed, 4 Nov 2026 14:33:48 +0000 Subject: [PATCH 11/27] Reset the Turnstile widget through an effect :turnstile-reset returns :orcpub.dnd.e5.views.auth/turnstile-reset, registered in views/auth, so events/auth no longer requires views/auth. --- src/cljs/orcpub/dnd/e5/events/auth.cljs | 5 ++--- src/cljs/orcpub/dnd/e5/views/auth.cljs | 8 +++++++- 2 files changed, 9 insertions(+), 4 deletions(-) diff --git a/src/cljs/orcpub/dnd/e5/events/auth.cljs b/src/cljs/orcpub/dnd/e5/events/auth.cljs index 5fbf19ce8..4b073e492 100644 --- a/src/cljs/orcpub/dnd/e5/events/auth.cljs +++ b/src/cljs/orcpub/dnd/e5/events/auth.cljs @@ -8,7 +8,6 @@ :refer [backend-url show-generic-error user->local-store-interceptor auth-headers] :rename {auth-headers authorization-headers}] - [orcpub.dnd.e5.views.auth :as views-auth] [orcpub.errors :as errors] [orcpub.fork.branding :as branding] [orcpub.route-map :as routes] @@ -196,8 +195,8 @@ (reg-event-fx :turnstile-reset (fn [_ _] - (views-auth/reset-widget!) - nil)) + ;; Registered in views/auth, which owns the widget. + {:orcpub.dnd.e5.views.auth/turnstile-reset true})) #_ ;; dead stub — real impl is orcpub.registration/validate-registration (defn validate-registration []) diff --git a/src/cljs/orcpub/dnd/e5/views/auth.cljs b/src/cljs/orcpub/dnd/e5/views/auth.cljs index 81e0bb1b3..f7b3e91ae 100644 --- a/src/cljs/orcpub/dnd/e5/views/auth.cljs +++ b/src/cljs/orcpub/dnd/e5/views/auth.cljs @@ -5,7 +5,7 @@ the page (window.__TURNSTILE_SITE_KEY__), and only when the form mounts, so no other page fetches anything from Cloudflare. Fails open on the client: if the script never loads, nothing is blocked; the server decides." - (:require [re-frame.core :refer [subscribe dispatch]] + (:require [re-frame.core :refer [subscribe dispatch reg-fx]] [reagent.core :as r] [orcpub.route-map :as routes] [orcpub.components :as comps :refer [base-input form-input make-event-handler]] @@ -61,6 +61,12 @@ (when-let [id @widget-id] (try (call-api "reset" id) (catch :default _ nil)))) +;; The :turnstile-reset event (events/auth) returns this effect, so it need not require this +;; namespace; core.cljs loads this one at startup, before anything dispatches. +(reg-fx + ::turnstile-reset + (fn [_] (reset-widget!))) + (defn- render! [el key] (when (and (api) (nil? @widget-id) (.-isConnected el)) (reset! widget-id From 790f3423174fee3e7fc2b35117b91720f2e9df04 Mon Sep 17 00:00:00 2001 From: codeGlaze Date: Wed, 4 Nov 2026 14:56:44 +0000 Subject: [PATCH 12/27] Add one guard table for the account endpoints and a test against the route table --- src/clj/orcpub/security.clj | 46 +++++++++++++++++++++++++++++++ test/clj/orcpub/security_test.clj | 26 +++++++++++++++++ 2 files changed, 72 insertions(+) diff --git a/src/clj/orcpub/security.clj b/src/clj/orcpub/security.clj index d92ce6d13..a20323442 100644 --- a/src/clj/orcpub/security.clj +++ b/src/clj/orcpub/security.clj @@ -309,6 +309,52 @@ (defn registration-allowed? [ip] (under-limit? [:register ip] registrations-per-host-hourly (hours 1))) +;; --------------------------------------------------------------------------- +;; One table of what guards every account endpoint a stranger can reach, keyed by Pedestal +;; route name. A value is a set of guards or {:none "why nothing is needed"}; the route-table +;; test in security_test.clj fails when a route is missing here or this names a route that +;; does not exist. Limit code is not driven by it; the test is the check. + +;; Guards: :per-address-limit, :per-host-limit, :per-account-limit (typed name), +;; :turnstile, :turnstile-after-failure, :uniform-answer (cannot tell whether an address +;; or account exists), :cooldown (email change), :authenticated. +;; --------------------------------------------------------------------------- + +(def auth-guards + {:orcpub.routes.auth/login + #{:per-account-limit :per-host-limit :turnstile-after-failure :uniform-answer} + :orcpub.routes.auth/register + #{:per-host-limit :turnstile :uniform-answer} + :orcpub.routes.auth/verify + {:none "the link carries an unguessable verification key; a wrong key changes nothing"} + :orcpub.routes.auth/re-verify + #{:per-address-limit :per-host-limit :turnstile :uniform-answer} + :orcpub.routes.auth/send-password-reset + #{:per-address-limit :per-host-limit :turnstile :uniform-answer} + :orcpub.routes.auth/reset-password + {:none "needs the unguessable single-use reset key from the mailed link"} + :orcpub.routes.auth/reset-password-page + {:none "a page; needs the unguessable reset key and changes nothing"} + :orcpub.routes.auth/check-username + {:none "usernames are public handles (profiles, shares), so membership is not a secret"} + :orcpub.routes.auth/check-email + {:none "TEMPORARY: removed by the sign-up change that stops revealing a taken address"} + :orcpub.routes.auth/request-email-change + #{:authenticated :cooldown} + :orcpub.routes/unsubscribe + {:none "the link carries a signed token; an unsigned or tampered one is refused"}}) + +(defn guard-of + "The guards of route `route-name`, or nil for an unknown route." + [route-name] + (get auth-guards route-name)) + +(defn guarded-by? + "True when route `route-name` lists `guard` in auth-guards." + [route-name guard] + (let [g (guard-of route-name)] + (boolean (and (set? g) (contains? g guard))))) + ;; The probe has no login, so IP is the only handle on who is asking. A real ;; character builder fires it once per image field, well under this; a script ;; walking a URL list to keep the fetch pool occupied is what it stops. diff --git a/test/clj/orcpub/security_test.clj b/test/clj/orcpub/security_test.clj index 68943979e..32aa65b66 100644 --- a/test/clj/orcpub/security_test.clj +++ b/test/clj/orcpub/security_test.clj @@ -430,3 +430,29 @@ (is (not (str/includes? printed secret)) "not in the banner") (is (str/includes? printed "1x00000000000000000000AA") "the public site key may show") (is (:set? (first (filter #(= "TURNSTILE_SECRET_KEY" (:var %)) rows)))))))) + +;; ---- the guard table covers the real route table ---- + +(def ^:private extra-auth-routes + "Account endpoints whose handlers live outside orcpub.routes.auth." + #{:orcpub.routes/unsubscribe}) + +(defn- auth-route-names [] + (->> routes/routes + (map :route-name) + (filter #(or (= "orcpub.routes.auth" (namespace %)) + (contains? extra-auth-routes %))) + set)) + +(deftest every-auth-route-is-in-the-guard-table + (let [actual (auth-route-names) + listed (set (keys s/auth-guards))] + (is (seq actual) "the route table was read") + (is (= #{} (sets/difference actual listed)) + "auth routes with no entry in security/auth-guards") + (is (= #{} (sets/difference listed actual)) + "auth-guards entries that name no route") + (doseq [[route guard] s/auth-guards] + (is (or (and (set? guard) (seq guard)) + (and (map? guard) (string? (:none guard)) (seq (:none guard)))) + (str route " needs guards or a reason for having none"))))) From 90116b1a5b0f059290f80f20e682eabae1fa9f55 Mon Sep 17 00:00:00 2001 From: codeGlaze Date: Wed, 4 Nov 2026 15:14:53 +0000 Subject: [PATCH 13/27] Put Turnstile on password reset, resend verification and sign-in after a failure --- src/clj/orcpub/routes/auth.clj | 47 +++++-- src/clj/orcpub/security.clj | 52 +++++++ src/cljc/orcpub/errors.cljc | 1 + src/cljs/orcpub/dnd/e5/events/auth.cljs | 77 +++++++---- src/cljs/orcpub/dnd/e5/subs.cljs | 5 + src/cljs/orcpub/dnd/e5/views/auth.cljs | 40 +++--- test/clj/orcpub/security_test.clj | 175 +++++++++++++++++++++++- 7 files changed, 346 insertions(+), 51 deletions(-) diff --git a/src/clj/orcpub/routes/auth.clj b/src/clj/orcpub/routes/auth.clj index e10828b2c..29a04f15d 100644 --- a/src/clj/orcpub/routes/auth.clj +++ b/src/clj/orcpub/routes/auth.clj @@ -189,11 +189,18 @@ (defn base-url [{:keys [scheme headers]}] (str (or (headers "x-forwarded-proto") (name scheme)) "://" (headers "host"))) +(defn- challenge-flag + "Tells the form to show the challenge for the retry. The same map for every failure, so it + cannot tell an unknown name from a wrong password; nil while Turnstile is off." + [] + (when (security/turnstile-enabled?) {:challenge? true})) + (defn bad-credentials-response [db username ip request] (security/add-failed-login-attempt! username ip) + (security/mark-login-challenge! username ip) (if (security/too-many-attempts-for-username? username) (do (security/note-refusal! :login-username) - (login-error errors/too-many-attempts)) + (login-error errors/too-many-attempts (challenge-flag))) (let [user-for-username (find-user-by-username-or-email db username)] ;; A name with no account is not logged: it is sometimes a password typed in the wrong box. (security/audit! :sign-in-failed request (:orcpub.user/username user-for-username)) @@ -217,7 +224,7 @@ ;; One answer for both. Telling somebody the username does not exist made ;; the login form the same membership test the reset endpoint was, and a ;; cheaper one, since it needs no mail to be sent. - (login-error errors/bad-credentials)))) + (login-error errors/bad-credentials (challenge-flag))))) (defn create-login-response [db conn user id & [headers]] (let [token (create-token (:orcpub.user/username user) @@ -244,7 +251,15 @@ ;; failing from this address inside a minute -- one person on several devices can't, a spray across accounts can. (security/multiple-account-access? remote-addr) (do (security/note-refusal! :login-spray) - (login-error errors/too-many-attempts)) + (security/mark-login-challenge! raw-username remote-addr) + (login-error errors/too-many-attempts (challenge-flag))) + + ;; Only for a name that just failed from this connection, and BEFORE the credentials are + ;; looked at, so a bot without a token learns nothing from the answer. A blank token is + ;; :fail without calling Cloudflare; :unreachable is a pass. + (and (security/login-challenge-required? raw-username remote-addr) + (= :fail (security/turnstile-verify (:turnstile-token json-params) remote-addr))) + (login-error errors/challenge-required {:challenge? true}) :else (let [username (s/trim raw-username) password (s/trim raw-password) @@ -259,7 +274,8 @@ (and unverified? expired?) (login-error errors/unverified-expired) unverified? (login-error errors/unverified {:email email}) :else - (do (security/audit! :sign-in request (:orcpub.user/username user)) + (do (security/clear-login-challenge! username remote-addr) + (security/audit! :sign-in request (:orcpub.user/username user)) (create-login-response db conn user id))))))) (defn login [request] @@ -384,6 +400,13 @@ (def ^:private turnstile-failed-message "We couldn't confirm you're not a bot. Please try the check again.") +(defn- turnstile-refusal + "A 400 for a failed challenge, or nil. Answered the same for every address and checked before + any lookup, so it cannot say whether an account exists. The caller retries with a fresh token." + [route-name token remote-addr] + (when (security/turnstile-refused? route-name token remote-addr) + {:status 400 :body {:general [turnstile-failed-message]}})) + (defn register [{:keys [json-params db conn remote-addr] :as request}] (let [{:keys [username email password send-updates?]} json-params username (when username (s/trim username)) @@ -404,8 +427,7 @@ ;; be rejected anyway never costs a verification. :unreachable is a pass (fail open). ;; :general for the same reason as the throttle below. validation (if (and (empty? validation) - (security/turnstile-enabled?) - (= :fail (security/turnstile-verify (:turnstile-token json-params) remote-addr))) + (security/turnstile-refused? ::register (:turnstile-token json-params) remote-addr)) (assoc validation :general [turnstile-failed-message]) validation) ;; Checked last, so a form that was going to be rejected anyway is not @@ -505,10 +527,14 @@ (defn re-verify [{:keys [query-params db conn remote-addr] :as request}] (let [email (:email query-params) + refusal (turnstile-refusal ::re-verify (:turnstile-token query-params) remote-addr) + query-params (dissoc query-params :turnstile-token) {:keys [:orcpub.user/verification-sent :orcpub.user/verified? - :db/id] :as user} (user-for-email db email)] + :db/id] :as user} (when-not refusal (user-for-email db email))] (cond + ;; Before the lookup and before either allowance is spent. + refusal refusal verified? (redirect route-map/verify-success-route) ;; No account for this address: answer like a resend and create nothing. Passing ;; {:db/id nil} on would register a key-only record and email a link to any address typed. @@ -589,12 +615,13 @@ (defn send-password-reset [{:keys [query-params db conn remote-addr] :as request}] (let [email (:email query-params) - {:keys [:db/id]} (user-for-email db email)] + refusal (turnstile-refusal ::send-password-reset (:turnstile-token query-params) remote-addr) + {:keys [:db/id]} (when-not refusal (user-for-email db email))] ;; The answer is identical whether or not that address has an account: ;; confirmed-valid addresses are precisely what a stuffing run needs. ;; The per-address limit is checked AFTER the lookup but never changes the ;; response -- a limit that visibly altered it would itself be a membership oracle, which the uniform 200 closes. - (when (and id (security/reset-email-allowed? email remote-addr)) + (when (and id (not refusal) (security/reset-email-allowed? email remote-addr)) (try (do-send-password-reset id email conn request) (security/audit! :password-reset-requested request @@ -605,7 +632,7 @@ ;; so an error response would mark the address as registered. (println "ERROR: password reset for a known address could not be sent:" (.getMessage e))))) - {:status 200})) + (or refusal {:status 200}))) (def reset-link-spent-message "This reset link has expired or has already been used. Request a new one from the login page.") diff --git a/src/clj/orcpub/security.clj b/src/clj/orcpub/security.clj index a20323442..fa6ab1268 100644 --- a/src/clj/orcpub/security.clj +++ b/src/clj/orcpub/security.clj @@ -463,3 +463,55 @@ (str "HTTP " st) (.. e getClass getSimpleName))) :unreachable)))) + +(defn turnstile-refused? + "True when route `route-name` lists :turnstile in auth-guards, the challenge is on, and `token` + fails it. :unreachable is not a refusal. A route that does not list :turnstile is never refused." + [route-name token remote-ip] + (boolean (and (guarded-by? route-name :turnstile) + (turnstile-enabled?) + (= :fail (turnstile-verify token remote-ip))))) + +;; --------------------------------------------------------------------------- +;; Sign-in challenge after a failure. A failed sign-in marks the NEXT attempt from that +;; connection with that typed name as needing the challenge. The key is the typed text, trimmed +;; and lowercased as the lookup does, never the account, so a mark exists for a name with no +;; account exactly as for one with an account and reveals nothing about either. +;; --------------------------------------------------------------------------- + +(def login-challenge-ms (* 15 60 1000)) + +;; Bounds memory against a flood of invented names from many connections. +(def ^:private login-challenge-cap 50000) + +(def ^:private login-challenges (atom {})) + +(defn- login-challenge-key [typed-name remote-ip] + [(s/lower-case (s/trim (str typed-name))) remote-ip]) + +(defn mark-login-challenge! + "Marks `typed-name` from `remote-ip` as needing the challenge on its next attempt, for 15 minutes. + Does nothing while Turnstile is off." + [typed-name remote-ip] + (when (turnstile-enabled?) + (let [now (System/currentTimeMillis)] + (swap! login-challenges + (fn [m] + (assoc (if (< login-challenge-cap (count m)) + {} + (into {} (remove (fn [[_ until]] (< until now))) m)) + (login-challenge-key typed-name remote-ip) + (+ now login-challenge-ms)))))) + nil) + +(defn clear-login-challenge! [typed-name remote-ip] + (swap! login-challenges dissoc (login-challenge-key typed-name remote-ip)) + nil) + +(defn login-challenge-required? + "True while Turnstile is on and `typed-name` from `remote-ip` failed a sign-in in the last 15 minutes." + [typed-name remote-ip] + (boolean (and (guarded-by? :orcpub.routes.auth/login :turnstile-after-failure) + (turnstile-enabled?) + (when-let [until (get @login-challenges (login-challenge-key typed-name remote-ip))] + (> until (System/currentTimeMillis)))))) diff --git a/src/cljc/orcpub/errors.cljc b/src/cljc/orcpub/errors.cljc index 7a77c599f..52053b36e 100644 --- a/src/cljc/orcpub/errors.cljc +++ b/src/cljc/orcpub/errors.cljc @@ -14,6 +14,7 @@ (def username-required :username-required) (def password-required :password-required) (def too-many-attempts :too-many-attempts) +(def challenge-required :challenge-required) ;; Error handling utilities diff --git a/src/cljs/orcpub/dnd/e5/events/auth.cljs b/src/cljs/orcpub/dnd/e5/events/auth.cljs index 4b073e492..1e93e32ac 100644 --- a/src/cljs/orcpub/dnd/e5/events/auth.cljs +++ b/src/cljs/orcpub/dnd/e5/events/auth.cljs @@ -86,6 +86,7 @@ ;; A button-text choice saved on the account wins over this browser's. {:db (let [account-choice (-> response :body :user-data :dark-button-text?)] (cond-> (-> db + (dissoc :login-challenge?) (update :user-data merge (-> response :body)) (assoc :user (-> response :body :user-data))) (some? account-choice) (assoc-in [:user-data :dark-button-text?] account-choice))) @@ -108,21 +109,32 @@ (reg-event-fx :login-failure (fn [{:keys [db]} [_ response]] - (let [error-code (-> response :body :error)] - (cond - (= error-code errors/username-required) (dispatch-login-failure "Username is required.") - (= error-code errors/too-many-attempts) (dispatch-login-failure "Too many attempts just now. Wait a minute and try again.") - (= error-code errors/password-required) (dispatch-login-failure "Password is required.") - (= error-code errors/bad-credentials) {:dispatch-n [[:clear-login] - (sign-in-failed-message)]} - (= error-code errors/unverified) {:db (assoc db :temp-email (-> response :body :email)) - :dispatch [:route routes/verify-sent-route]} - (= error-code errors/unverified-expired) {:dispatch [:route routes/verify-failed-route]} - :else (dispatch-login-failure - (if (seq branding/support-email) - [:div "An error occurred. If the problem persists please email " - [:a {:href (str "mailto:" branding/support-email) :target :blank} branding/support-email]] - [:div "An error occurred. Please try again later."])))))) + (let [error-code (-> response :body :error) + ;; The server sends the flag identically after every failed sign-in, so the form shows + ;; the challenge for the retry; the token just used is spent either way. + challenge? (boolean (-> response :body :challenge?)) + with-challenge (fn [fx] + (cond-> fx + challenge? (assoc :db (assoc db :login-challenge? true)) + challenge? (update :dispatch-n (fnil conj []) [:turnstile-reset])))] + (with-challenge + (cond + (= error-code errors/challenge-required) + {:dispatch-n [[:clear-login] + [:show-login-message "Please complete the security check below, then sign in again."]]} + (= error-code errors/username-required) (dispatch-login-failure "Username is required.") + (= error-code errors/too-many-attempts) (dispatch-login-failure "Too many attempts just now. Wait a minute and try again.") + (= error-code errors/password-required) (dispatch-login-failure "Password is required.") + (= error-code errors/bad-credentials) {:dispatch-n [[:clear-login] + (sign-in-failed-message)]} + (= error-code errors/unverified) {:db (assoc db :temp-email (-> response :body :email)) + :dispatch [:route routes/verify-sent-route]} + (= error-code errors/unverified-expired) {:dispatch [:route routes/verify-failed-route]} + :else (dispatch-login-failure + (if (seq branding/support-email) + [:div "An error occurred. If the problem persists please email " + [:a {:href (str "mailto:" branding/support-email) :target :blank} branding/support-email]] + [:div "An error occurred. Please try again later."]))))))) (reg-event-fx :logout @@ -149,7 +161,8 @@ (fn [{:keys [db]} [_ params backtrack?]] {:http {:method :post :url login-url - :json-params params + :json-params (cond-> params + (:turnstile-token db) (assoc :turnstile-token (:turnstile-token db))) :on-success [:login-success backtrack?] :on-unauthorized [:login-failure]}})) @@ -306,14 +319,30 @@ routes/verify-success-route routes/verify-sent-route)))) +(defn- challenge-failure + "Effects for a request the server refused: its :general message when it gave one (the failed or + missing challenge), else the generic error. The token is spent either way." + [response] + (let [message (first (get-in response [:body :general]))] + (if message + {:dispatch-n [[:show-login-message message] [:turnstile-reset]]} + {:dispatch-n [(show-generic-error) [:turnstile-reset]]}))) + +(reg-event-fx + :re-verify-failure + (fn [_ [_ response]] + (challenge-failure response))) + (reg-event-fx :re-verify (fn [{:keys [db]} [_ params]] {:db (assoc db :temp-email (:email params)) :http {:method :get :url (backend-url (bidi/path-for routes/routes routes/re-verify-route)) - :query-params params - :on-success [:re-verify-success]}})) + :query-params (cond-> params + (:turnstile-token db) (assoc :turnstile-token (:turnstile-token db))) + :on-success [:re-verify-success] + :on-failure [:re-verify-failure]}})) (reg-event-db :send-password-reset-success @@ -322,11 +351,10 @@ (reg-event-fx :send-password-reset-failure - ;; The endpoint answers 200 for every address now, so :no-account cannot arrive - ;; here and the branch that handled it is gone. Anything reaching this handler - ;; is a network or server fault, which is what the generic error is for. - (fn [_ _] - (show-generic-error))) + ;; The endpoint answers 200 for every address, so :no-account cannot arrive here. A refused + ;; challenge carries a :general message; anything else is a network or server fault. + (fn [_ [_ response]] + (challenge-failure response))) (reg-event-fx :send-password-reset @@ -334,7 +362,8 @@ {:db (assoc db :temp-email (:email params)) :http {:method :get :url (backend-url (bidi/path-for routes/routes routes/send-password-reset-route)) - :query-params params + :query-params (cond-> params + (:turnstile-token db) (assoc :turnstile-token (:turnstile-token db))) :on-success [:send-password-reset-success] :on-failure [:send-password-reset-failure]}})) diff --git a/src/cljs/orcpub/dnd/e5/subs.cljs b/src/cljs/orcpub/dnd/e5/subs.cljs index 9656fdecf..867ede2dc 100644 --- a/src/cljs/orcpub/dnd/e5/subs.cljs +++ b/src/cljs/orcpub/dnd/e5/subs.cljs @@ -875,6 +875,11 @@ (fn [db _] (:login-message-shown? db))) +(reg-sub + :login-challenge? + (fn [db _] + (boolean (:login-challenge? db)))) + (reg-sub :message (fn [db _] diff --git a/src/cljs/orcpub/dnd/e5/views/auth.cljs b/src/cljs/orcpub/dnd/e5/views/auth.cljs index f7b3e91ae..f649cdca2 100644 --- a/src/cljs/orcpub/dnd/e5/views/auth.cljs +++ b/src/cljs/orcpub/dnd/e5/views/auth.cljs @@ -325,6 +325,16 @@ (when tail [:div.m-t-10.auth-tail tail])] {:legal-links? legal-links?})) +(defn hide-login-message [] + (dispatch [:hide-login-message])) + +(defn- login-message-block + "The form's refusal message, when there is one." + [] + (when @(subscribe [:login-message-shown?]) + [:div.m-t-5.p-r-5.p-l-5 + [notifications/message :error @(subscribe [:login-message]) hide-login-message]])) + (defn verify-failed [] (let [params (r/atom {})] (fn [] @@ -332,19 +342,20 @@ {:heading "Your key has expired" :lede (str "You must verify your email within 24 hours of registering. " "Send another verification email by submitting your address here.") - :fields [base-input - {:name :email - :value (:email @params) - :type :email - :title "Email address" - :on-change (partial set-value params :email)}] + :fields [:div + [base-input + {:name :email + :value (:email @params) + :type :email + :title "Email address" + :on-change (partial set-value params :email)}] + ;; A refused challenge is answered here, as on the reset page. + [login-message-block] + [widget]] :tail [:button.form-button.form-submit-btn {:on-click (make-event-handler :re-verify @params)} "RESEND"]})))) -(defn hide-login-message [] - (dispatch [:hide-login-message])) - (defn send-password-reset-page [] (let [params (r/atom {})] (fn [error-message] @@ -365,13 +376,8 @@ :type :email :value email :on-change (partial set-value params :email)}] - (when @(subscribe [:login-message-shown?]) - [:div.m-t-5.p-r-5.p-l-5 - [notifications/message - :error - @(subscribe [:login-message]) - hide-login-message]]) - ] + [login-message-block] + [widget]] :tail [:div [:button.form-button.form-submit-btn @@ -702,6 +708,8 @@ :value (:password @params) :type :password :on-change #(swap! params assoc :password (event-value %))}] + ;; Only after a failed attempt: the server flags it, :login-failure sets this. + (when @(subscribe [:login-challenge?]) [widget]) (when login-message-shown? [:div.m-t-5 [notifications/message :error diff --git a/test/clj/orcpub/security_test.clj b/test/clj/orcpub/security_test.clj index 32aa65b66..933787d2c 100644 --- a/test/clj/orcpub/security_test.clj +++ b/test/clj/orcpub/security_test.clj @@ -316,11 +316,17 @@ (use-fixtures :each (fn [f] (reset! @#'s/sightings {}) + (reset! @#'s/login-challenges {}) + (reset! s/failed-login-attempts-by-username {}) + (reset! s/failed-login-attempts-by-ip {}) (with-redefs [email/configured? (constantly true) pwned/check (constantly 0)] (binding [errors/*error-prefix* "TEST_ERROR:"] (f))) - (reset! @#'s/sightings {}))) + (reset! @#'s/sightings {}) + (reset! @#'s/login-challenges {}) + (reset! s/failed-login-attempts-by-username {}) + (reset! s/failed-login-attempts-by-ip {}))) (def ^:private secret "s3cr3t-turnstile-value-9f2c") @@ -456,3 +462,170 @@ (is (or (and (set? guard) (seq guard)) (and (map? guard) (string? (:none guard)) (seq (:none guard)))) (str route " needs guards or a reason for having none"))))) + +;; ---- Turnstile on password reset, resend verification and sign-in after a failure ---- + +(defn- verify-calls + "Runs `f` with Turnstile on and siteverify answering `answer` (a map, or :throw); returns + [result number-of-siteverify-calls]." + [answer f] + (let [calls (atom 0)] + (with-redefs [s/turnstile-enabled? (constantly true) + s/post-siteverify (fn [& _] + (swap! calls inc) + (if (= :throw answer) + (throw (java.net.SocketTimeoutException. "slow")) + answer))] + [(f) @calls]))) + +(defn- lookups-fail-the-test [& _] (throw (AssertionError. "looked the address up before the challenge"))) + +(deftest reset-and-resend-check-the-challenge-before-anything-else + (doseq [[label handler route-name] + [["send-password-reset" auth/send-password-reset :orcpub.routes.auth/send-password-reset] + ["re-verify" auth/re-verify :orcpub.routes.auth/re-verify]]] + (let [call (fn [token] (handler {:query-params (cond-> {:email "someone@example.com"} + token (assoc :turnstile-token token)) + :db nil :conn nil :remote-addr "9.9.9.9"}))] + (testing (str label ": a failed challenge is told to retry, before any lookup or allowance") + (with-redefs [auth/user-for-email lookups-fail-the-test] + (let [[resp calls] (verify-calls {:success false} #(call "bad"))] + (is (= 400 (:status resp))) + (is (str/includes? (first (get-in resp [:body :general])) "not a bot")) + (is (= 1 calls)) + (is (empty? @@#'s/sightings) "no allowance was spent")) + (testing "a missing token is refused the same way, without calling Cloudflare" + (let [[resp calls] (verify-calls {:success true} #(call nil))] + (is (= 400 (:status resp))) + (is (zero? calls)))))) + (testing (str label ": the refusal is the same whether or not the address has an account") + (let [refused (fn [user] + (with-redefs [auth/user-for-email (constantly user)] + (first (verify-calls {:success false} #(call "bad")))))] + (is (= (refused {:db/id 5}) (refused {}))))) + (testing (str label ": a passing challenge proceeds to the usual work") + (let [looked-up (atom 0)] + (with-redefs [auth/user-for-email (fn [& _] (swap! looked-up inc) {})] + (let [[resp calls] (verify-calls {:success true} #(call "good"))] + (is (= {:status 200} resp)) + (is (= 1 calls)) + (is (= 1 @looked-up)))))) + (testing (str label ": an unreachable Cloudflare fails open") + (with-redefs [auth/user-for-email (constantly {})] + (is (= {:status 200} (first (verify-calls :throw #(call "any"))))))) + (testing (str label ": with Turnstile off nothing is checked") + (let [calls (atom 0)] + (with-redefs [s/turnstile-enabled? (constantly false) + s/post-siteverify (fn [& _] (swap! calls inc) {:success false}) + auth/user-for-email (constantly {})] + (is (= {:status 200} (call nil))) + (is (zero? @calls)))))))) + +(deftest the-resend-token-does-not-reach-the-mail + (let [seen (atom nil)] + (with-redefs [s/turnstile-enabled? (constantly true) + s/post-siteverify (fn [& _] {:success true}) + auth/user-for-email (constantly {:db/id 17}) + auth/do-verification (fn [_ params & _] (reset! seen params) {:status 200})] + (auth/re-verify {:query-params {:email "a@b.com" :turnstile-token "t"} + :db nil :conn nil :remote-addr "9.9.9.9"}) + (is (not (contains? @seen :turnstile-token)))))) + +(defn- login [typed token ip] + (auth/login-response {:json-params (cond-> {:username typed :password "pw"} + token (assoc :turnstile-token token)) + :db nil :conn nil :remote-addr ip :headers {}})) + +(defmacro ^:private with-login-stubs + "Sign-in with Turnstile on: `known` is the one typed name whose password is right." + [known & body] + `(with-redefs [s/turnstile-enabled? (constantly true) + auth/lookup-user (fn [_# u# _#] (if (= ~known u#) {:db/id 1 :orcpub.user/verified? true} {})) + auth/find-user-by-username-or-email (constantly nil) + auth/create-login-response (fn [& _#] {:status 200 :body {:token "t"}})] + ~@body)) + +(deftest sign-in-needs-no-challenge-until-it-fails + (with-login-stubs "kaylee" + (let [[resp calls] (verify-calls {:success false} #(login "kaylee" nil "1.1.1.1"))] + (is (= 200 (:status resp))) + (is (zero? calls) "Cloudflare is not asked")))) + +(deftest a-failure-looks-the-same-for-an-unknown-name-and-a-wrong-password + (with-login-stubs "kaylee" + (let [unknown (login "nobody" nil "1.1.1.1") + ;; "kaylee" exists, but this lookup stub is told it is wrong + wrong (with-redefs [auth/lookup-user (fn [& _] {}) + auth/find-user-by-username-or-email (constantly {:db/id 1 :orcpub.user/username "kaylee"})] + (login "kaylee" nil "1.1.1.1"))] + (is (= 401 (:status unknown))) + (is (= errors/bad-credentials (-> unknown :body :error))) + (is (true? (-> unknown :body :challenge?))) + (is (= unknown wrong) "identical, including the flag")))) + +(deftest the-flag-is-absent-while-turnstile-is-off + (with-redefs [s/turnstile-enabled? (constantly false) + auth/lookup-user (constantly {}) + auth/find-user-by-username-or-email (constantly nil)] + (is (= {:status 401 :body {:error errors/bad-credentials}} (login "nobody" nil "1.1.1.1"))) + (is (= {:status 401 :body {:error errors/bad-credentials}} (login "nobody" nil "1.1.1.1")) + "and a second failure still asks for nothing"))) + +(deftest after-a-failure-the-next-attempt-needs-a-passing-token + (with-login-stubs "kaylee" + (login "kaylee-typo" nil "1.1.1.1") + (testing "no token: challenge required, and the credentials are not looked at" + (with-redefs [auth/lookup-user lookups-fail-the-test] + (let [[resp calls] (verify-calls {:success true} #(login "kaylee-typo" nil "1.1.1.1"))] + (is (= 401 (:status resp))) + (is (= errors/challenge-required (-> resp :body :error))) + (is (true? (-> resp :body :challenge?))) + (is (zero? calls))))) + (testing "a failing token is the same" + (is (= errors/challenge-required + (-> (first (verify-calls {:success false} #(login "kaylee-typo" "bad" "1.1.1.1"))) :body :error)))) + (testing "a passing token reaches the credentials" + (is (= errors/bad-credentials + (-> (first (verify-calls {:success true} #(login "kaylee-typo" "good" "1.1.1.1"))) :body :error)))) + (testing "an unreachable Cloudflare fails open" + (is (= errors/bad-credentials + (-> (first (verify-calls :throw #(login "kaylee-typo" "any" "1.1.1.1"))) :body :error)))))) + +(deftest a-successful-sign-in-clears-the-mark + (with-login-stubs "kaylee" + (login "nobody" nil "1.1.1.1") + (login "kaylee" nil "1.1.1.1") + (is (true? (s/login-challenge-required? "nobody" "1.1.1.1")) "a different name keeps its own mark") + (login "nobody" nil "2.2.2.2") + (s/mark-login-challenge! "kaylee" "1.1.1.1") + (is (= 200 (:status (first (verify-calls {:success true} #(login "kaylee" "good" "1.1.1.1")))))) + (is (false? (s/login-challenge-required? "kaylee" "1.1.1.1")) "the success cleared it") + (is (= 200 (:status (login "kaylee" nil "1.1.1.1"))) "so the next one needs no token"))) + +(deftest the-mark-is-per-typed-name-and-connection + (with-login-stubs "kaylee" + (login " Wash " nil "1.1.1.1") + (is (true? (s/login-challenge-required? "wash" "1.1.1.1")) "trimmed and lowercased as the lookup does") + (is (false? (s/login-challenge-required? "wash" "2.2.2.2")) "another connection") + (is (false? (s/login-challenge-required? "zoe" "1.1.1.1")) "another name"))) + +(deftest the-mark-lapses + (with-login-stubs "kaylee" + (s/mark-login-challenge! "wash" "1.1.1.1") + (with-redefs [s/login-challenge-ms -1] + (s/mark-login-challenge! "zoe" "1.1.1.1") + (is (false? (s/login-challenge-required? "zoe" "1.1.1.1")))) + (is (true? (s/login-challenge-required? "wash" "1.1.1.1"))))) + +(deftest nothing-is-marked-while-turnstile-is-off + (with-redefs [s/turnstile-enabled? (constantly false)] + (s/mark-login-challenge! "wash" "1.1.1.1")) + (is (empty? @@#'s/login-challenges))) + +(deftest a-sprayed-or-throttled-refusal-also-marks-the-next-attempt + (with-login-stubs "kaylee" + (with-redefs [s/multiple-account-access? (constantly true)] + (let [r (login "wash" nil "3.3.3.3")] + (is (= errors/too-many-attempts (-> r :body :error))) + (is (true? (-> r :body :challenge?))))) + (is (true? (s/login-challenge-required? "wash" "3.3.3.3"))))) From cee9f0f530cf5cb64a2ed5fefce3405f54f2cc60 Mon Sep 17 00:00:00 2001 From: codeGlaze Date: Wed, 4 Nov 2026 15:24:31 +0000 Subject: [PATCH 14/27] Say so when the security check cannot load, and tell a missing token from a failed one --- src/clj/orcpub/routes/auth.clj | 10 +++++++-- src/cljc/orcpub/errors.cljc | 6 ++++++ src/cljs/orcpub/dnd/e5/events/auth.cljs | 6 ++++++ src/cljs/orcpub/dnd/e5/subs.cljs | 5 +++++ src/cljs/orcpub/dnd/e5/views/auth.cljs | 27 ++++++++++++++++++------- test/clj/orcpub/security_test.clj | 27 +++++++++++++++++++++++++ 6 files changed, 72 insertions(+), 9 deletions(-) diff --git a/src/clj/orcpub/routes/auth.clj b/src/clj/orcpub/routes/auth.clj index 29a04f15d..88fa03d02 100644 --- a/src/clj/orcpub/routes/auth.clj +++ b/src/clj/orcpub/routes/auth.clj @@ -400,12 +400,18 @@ (def ^:private turnstile-failed-message "We couldn't confirm you're not a bot. Please try the check again.") +(defn- turnstile-message + "Why the challenge refused: no token at all means the widget never ran (a blocked script), which + the player can fix; a token that failed verification just means try the check again." + [token] + (if (s/blank? token) errors/turnstile-blocked-message turnstile-failed-message)) + (defn- turnstile-refusal "A 400 for a failed challenge, or nil. Answered the same for every address and checked before any lookup, so it cannot say whether an account exists. The caller retries with a fresh token." [route-name token remote-addr] (when (security/turnstile-refused? route-name token remote-addr) - {:status 400 :body {:general [turnstile-failed-message]}})) + {:status 400 :body {:general [(turnstile-message token)]}})) (defn register [{:keys [json-params db conn remote-addr] :as request}] (let [{:keys [username email password send-updates?]} json-params @@ -428,7 +434,7 @@ ;; :general for the same reason as the throttle below. validation (if (and (empty? validation) (security/turnstile-refused? ::register (:turnstile-token json-params) remote-addr)) - (assoc validation :general [turnstile-failed-message]) + (assoc validation :general [(turnstile-message (:turnstile-token json-params))]) validation) ;; Checked last, so a form that was going to be rejected anyway is not ;; counted against the host. :general rather than a field key: nobody diff --git a/src/cljc/orcpub/errors.cljc b/src/cljc/orcpub/errors.cljc index 52053b36e..5f68abc8c 100644 --- a/src/cljc/orcpub/errors.cljc +++ b/src/cljc/orcpub/errors.cljc @@ -16,6 +16,12 @@ (def too-many-attempts :too-many-attempts) (def challenge-required :challenge-required) +(def turnstile-blocked-message + "Shown where the security check would be when its script cannot load, and by the server when a + form arrives with no token at all (the same cause, seen from the other end)." + (str "The security check couldn't load. If you use an ad blocker or privacy extension, " + "allow challenges.cloudflare.com, then reload this page.")) + ;; Error handling utilities (def ^:dynamic *error-prefix* diff --git a/src/cljs/orcpub/dnd/e5/events/auth.cljs b/src/cljs/orcpub/dnd/e5/events/auth.cljs index 1e93e32ac..5e4bff6e8 100644 --- a/src/cljs/orcpub/dnd/e5/events/auth.cljs +++ b/src/cljs/orcpub/dnd/e5/events/auth.cljs @@ -205,6 +205,12 @@ (fn [db [_ token]] (assoc db :turnstile-token token))) +(reg-event-db + :turnstile-blocked + ;; True when the widget's script could not load or the widget reported an error. + (fn [db [_ blocked?]] + (assoc db :turnstile-blocked? (boolean blocked?)))) + (reg-event-fx :turnstile-reset (fn [_ _] diff --git a/src/cljs/orcpub/dnd/e5/subs.cljs b/src/cljs/orcpub/dnd/e5/subs.cljs index 867ede2dc..344fd5f23 100644 --- a/src/cljs/orcpub/dnd/e5/subs.cljs +++ b/src/cljs/orcpub/dnd/e5/subs.cljs @@ -875,6 +875,11 @@ (fn [db _] (:login-message-shown? db))) +(reg-sub + :turnstile-blocked? + (fn [db _] + (boolean (:turnstile-blocked? db)))) + (reg-sub :login-challenge? (fn [db _] diff --git a/src/cljs/orcpub/dnd/e5/views/auth.cljs b/src/cljs/orcpub/dnd/e5/views/auth.cljs index f649cdca2..252d9d025 100644 --- a/src/cljs/orcpub/dnd/e5/views/auth.cljs +++ b/src/cljs/orcpub/dnd/e5/views/auth.cljs @@ -3,13 +3,13 @@ and the Cloudflare Turnstile widget the sign-up form carries. The Turnstile widget (moved from orcpub.turnstile) loads only when the server put a site key on the page (window.__TURNSTILE_SITE_KEY__), and only when the form mounts, so no other page - fetches anything from Cloudflare. Fails open on the client: if the script never loads, nothing - is blocked; the server decides." + fetches anything from Cloudflare. If the script cannot load, the form says so." (:require [re-frame.core :refer [subscribe dispatch reg-fx]] [reagent.core :as r] [orcpub.route-map :as routes] [orcpub.components :as comps :refer [base-input form-input make-event-handler]] [orcpub.registration :as registration] + [orcpub.errors :as errors] [orcpub.fork.branding :as branding] [orcpub.dnd.e5.views-2 :as views-2] [orcpub.dnd.e5.views.notifications :as notifications] @@ -50,14 +50,19 @@ (set! (.-async el) true) (set! (.-defer el) true) (.addEventListener el "load" f) - ;; Script failed to load: leave the form as it is; the server fails open. - (.addEventListener el "error" (fn [_] (dispatch [:turnstile-token nil]))) + ;; Script failed to load (an ad blocker, usually): say so where the widget would be, and + ;; drop the tag so remounting the form tries again. + (.addEventListener el "error" (fn [_] + (.remove el) + (dispatch [:turnstile-token nil]) + (dispatch [:turnstile-blocked true]))) (.appendChild (.-head js/document) el))))) (defn reset-widget! "Tokens are single use: asks the widget for a fresh one. No-op without a widget." [] (dispatch [:turnstile-token nil]) + (dispatch [:turnstile-blocked false]) (when-let [id @widget-id] (try (call-api "reset" id) (catch :default _ nil)))) @@ -75,7 +80,9 @@ #js {:sitekey key :callback (fn [token] (dispatch [:turnstile-token token])) :expired-callback (fn [] (dispatch [:turnstile-token nil])) - :error-callback (fn [] (dispatch [:turnstile-token nil]))}) + :error-callback (fn [] + (dispatch [:turnstile-token nil]) + (dispatch [:turnstile-blocked true]))}) (catch :default _ nil))))) (defn widget @@ -86,7 +93,9 @@ (r/create-class {:display-name "turnstile-widget" :component-did-mount - (fn [_] (with-api #(when @el (render! @el key)))) + (fn [_] + (dispatch [:turnstile-blocked false]) + (with-api #(when @el (render! @el key)))) :component-will-unmount (fn [_] (when-let [id @widget-id] @@ -94,7 +103,11 @@ (reset! widget-id nil) (dispatch [:turnstile-token nil])) :reagent-render - (fn [] [:div.m-t-10 {:ref #(reset! el %)}])})))) + (fn [] + [:div.m-t-10 + [:div {:ref #(reset! el %)}] + (when @(subscribe [:turnstile-blocked?]) + [notifications/message :warning errors/turnstile-blocked-message identity])])})))) ;; ---- Account screens ---- diff --git a/test/clj/orcpub/security_test.clj b/test/clj/orcpub/security_test.clj index 933787d2c..8f2c87782 100644 --- a/test/clj/orcpub/security_test.clj +++ b/test/clj/orcpub/security_test.clj @@ -629,3 +629,30 @@ (is (= errors/too-many-attempts (-> r :body :error))) (is (true? (-> r :body :challenge?))))) (is (true? (s/login-challenge-required? "wash" "3.3.3.3"))))) + +;; ---- a blocked widget and a failed check are told apart ---- + +(deftest no-token-is-told-to-allow-the-script-and-a-bad-token-to-retry + (let [messages (fn [resp] (get-in resp [:body :general])) + blocked errors/turnstile-blocked-message] + (is (str/includes? blocked "ad blocker")) + (is (str/includes? blocked "challenges.cloudflare.com")) + (doseq [[label call] + [["register" (fn [token] (auth/register (request (fresh-conn) token)))] + ["send-password-reset" + (fn [token] (auth/send-password-reset + {:query-params (cond-> {:email "a@b.com"} token (assoc :turnstile-token token)) + :db nil :conn nil :remote-addr "9.9.9.9"}))] + ["re-verify" + (fn [token] (auth/re-verify + {:query-params (cond-> {:email "a@b.com"} token (assoc :turnstile-token token)) + :db nil :conn nil :remote-addr "9.9.9.9"}))]]] + (testing label + (with-redefs [auth/user-for-email lookups-fail-the-test] + (doseq [blank [nil "" " "]] + (is (= [blocked] (messages (first (verify-calls {:success true} #(call blank))))) + "a blank token gets the ad-blocker message")) + (let [msgs (messages (first (verify-calls {:success false} #(call "bad"))))] + (is (= 1 (count msgs))) + (is (not= [blocked] msgs) "a failed token does not") + (is (str/includes? (first msgs) "not a bot")))))))) From ead18a585c6dc04ec9eca8db66a8b3b7600551a8 Mon Sep 17 00:00:00 2001 From: codeGlaze Date: Wed, 4 Nov 2026 15:36:35 +0000 Subject: [PATCH 15/27] Sign-up no longer reveals a taken email: same answer, the owner is mailed --- scripts/e2e/auth-flows.js | 7 +- src/clj/orcpub/email.clj | 48 ++++++++++++ src/clj/orcpub/routes.clj | 2 - src/clj/orcpub/routes/auth.clj | 47 +++++++++-- src/clj/orcpub/security.clj | 6 +- src/cljc/orcpub/registration.cljc | 3 +- src/cljc/orcpub/route_map.cljc | 2 - src/cljs/orcpub/dnd/e5/events/auth.cljs | 20 +---- src/cljs/orcpub/dnd/e5/subs.cljs | 10 +-- test/clj/orcpub/registration_email_test.clj | 78 ++++++++++++++++++- .../clj/orcpub/registration_no_email_test.clj | 18 +++++ test/cljc/orcpub/registration_test.cljc | 2 +- 12 files changed, 200 insertions(+), 43 deletions(-) diff --git a/scripts/e2e/auth-flows.js b/scripts/e2e/auth-flows.js index 8fa94f1fd..8866f8d3d 100644 --- a/scripts/e2e/auth-flows.js +++ b/scripts/e2e/auth-flows.js @@ -118,7 +118,8 @@ async function resetLinkFor(page, sink, email) { check((await heading(page)).toLowerCase().includes('registration is complete'), 'a new account registers and verifies', await heading(page)); - // The same address and name a second time must be refused, per field. + // The same name a second time is refused, per field. The address is NOT: sign-up never says an + // address is taken (it answers "check your email" and mails the owner instead). await page.goto(`${BASE}/pages/register-page`, { waitUntil: 'networkidle' }); await page.waitForSelector('.auth-form input'); let b = authInputs(page); @@ -127,8 +128,8 @@ async function resetLinkFor(page, sink, email) { // GOTCHA: matches the server's messages; the page always shows "Already have an account?". await submit(page, () => press(page, 'JOIN'), /already taken by another user/); const taken = await cardText(page); - check(/already taken by another user/i.test(taken) && /already associated with another account/i.test(taken), - 'a username and email already in use are refused', + check(/already taken by another user/i.test(taken) && !/already associated|already in use|taken/i.test(taken.replace(/already taken by another user/ig, '')), + 'a username already in use is refused, and the email is not named as taken', taken.replace(/\n/g, ' | ').slice(0, 120)); // Short password: the rules must say what is wrong, not just refuse. diff --git a/src/clj/orcpub/email.clj b/src/clj/orcpub/email.clj index 490e71906..f24021969 100644 --- a/src/clj/orcpub/email.clj +++ b/src/clj/orcpub/email.clj @@ -259,6 +259,54 @@ (describe-browser user-agent) (attempt-time))}) +(defn signup-attempt-email-html + "Says nothing that identifies the account: no name, username, credential or token. Both links go + to pages, so the reader decides what to do and nothing in this mail can be replayed." + [sign-in-url reset-url] + (into + [:div + "Hello," + [:br] + [:br] + (str "Someone just tried to sign up for " branding/app-name " with this email address, which already has an account.") + [:br] + [:br] + "If it was you, you do not need a second account. Sign in here:" + [:br] + [:br] + [:a {:href sign-in-url} sign-in-url] + [:br] + [:br] + "If you have forgotten your password, you can pick a new one here:" + [:br] + [:br] + [:a {:href reset-url} reset-url] + [:br] + [:br] + "If it was not you, you can ignore this email. Nothing has changed and nobody got in." + [:br] + [:br] + "Sincerely," + [:br] + [:br] + (str "The " branding/email-sender-name)] + (social-links-footer))) + +(defn signup-attempt-email [sign-in-url reset-url] + [{:type "text/html" + :content (str (hiccup/html (signup-attempt-email-html sign-in-url reset-url)))}]) + +(defn signup-attempt-message + "The notice to the owner of an address somebody tried to sign up with again: `base-url`, and a map + with :email. Links to the sign-in and reset PAGES only. Returns the postal message." + [base-url {:keys [email]}] + {:from (str branding/email-sender-name " <" (emailfrom) ">") + :to email + :subject (str branding/app-name " sign-up attempt") + :body (signup-attempt-email + (str base-url (routes/path-for routes/login-page-route)) + (str base-url (routes/path-for routes/send-password-reset-page-route)))}) + (defn password-changed-email-html [first-and-last-name reset-url browser when-str] (into [:div diff --git a/src/clj/orcpub/routes.clj b/src/clj/orcpub/routes.clj index b4b8e45ad..9ed53b513 100644 --- a/src/clj/orcpub/routes.clj +++ b/src/clj/orcpub/routes.clj @@ -2037,8 +2037,6 @@ {:get `community-guidelines-page}] [(route-map/path-for route-map/cookies-policy-route) {:get `cookie-policy-page}] - [(route-map/path-for route-map/check-email-route) - {:get `auth/check-email}] [(route-map/path-for route-map/check-username-route) {:get `auth/check-username}] ["/health" diff --git a/src/clj/orcpub/routes/auth.clj b/src/clj/orcpub/routes/auth.clj index 88fa03d02..a8a43e7cd 100644 --- a/src/clj/orcpub/routes/auth.clj +++ b/src/clj/orcpub/routes/auth.clj @@ -413,14 +413,48 @@ (when (security/turnstile-refused? route-name token remote-addr) {:status 400 :body {:general [(turnstile-message token)]}})) +(def ^:private taken-email-refusal-message + "This email can't be used. Check it and try again, or sign in.") + +(defn- notify-taken-owner! + "Mails the owner of `email` that somebody tried to sign up with it, at most once a day. Never + throws and never changes the answer: a failure here must not tell a taken address from a new one." + [{:keys [db conn] :as request} email] + (try + (let [owner (user-for-email db email)] + (when (and (:db/id owner) + (security/claim-taken-signup-notice! email)) + (outbox/enqueue! conn :signup-attempt + (email/signup-attempt-message + (base-url request) + {:email (or (:orcpub.user/email owner) email)})))) + (catch Exception e + (println "ERROR: could not queue a sign-up attempt notice:" (.getMessage e))))) + +(defn- answer-taken-email + "The answer for a well-formed sign-up whose address already has an account. With a mail server: + exactly what a new sign-up answers, nothing created, the owner mailed instead. Without one there + is nobody to mail, so a plain refusal (owner decision 2026-11-04), not a field error naming the + address. + The password is hashed and thrown away so this path costs about what a new sign-up does, since a + much faster answer would tell a taken address apart by timing alone." + [request email password] + (hashers/encrypt password) + (if (email/configured?) + (do (notify-taken-owner! request email) + {:status 200}) + {:status 400 :body {:general [taken-email-refusal-message]}})) + (defn register [{:keys [json-params db conn remote-addr] :as request}] (let [{:keys [username email password send-updates?]} json-params username (when username (s/trim username)) email (user-email/email-key email) password (when password (s/trim password)) + ;; Whether the address is taken is judged AFTER every check a new sign-up goes through, + ;; and never shown: see answer-taken-email. + taken? (boolean (seq (d/q email-query db email))) validation (registration/validate-registration json-params - (seq (d/q email-query db email)) (seq (d/q username-query db username))) now (java.util.Date.) ;; Checked only once the form is otherwise valid: no reason to ask a third @@ -443,9 +477,15 @@ validation (if (or (seq validation) (security/registration-allowed? remote-addr)) validation (assoc validation :general [registration-throttled-message]))] - (if (seq validation) + (cond + (seq validation) {:status 400 :body validation} + + taken? + (answer-taken-email request email password) + + :else (let [response (do-verification request json-params @@ -749,9 +789,6 @@ (defn check-username [{:keys [db query-params]}] (check-field username-query (:username query-params) db)) -(defn check-email [{:keys [db query-params]}] - (check-field email-query (user-email/email-key (:email query-params)) db)) - (defn rate-limit-remaining-secs "Seconds until the user can act again. In the 0–1 min zone (email in transit) returns time until the 1-min resend window opens. In the 1–5 min zone (for a diff --git a/src/clj/orcpub/security.clj b/src/clj/orcpub/security.clj index fa6ab1268..4f8eb7825 100644 --- a/src/clj/orcpub/security.clj +++ b/src/clj/orcpub/security.clj @@ -277,6 +277,10 @@ (defn claim-sign-in-notice! [username] (claim-once? [:sign-in-notice username] (hours notice-cooldown-hours))) +;; Same reason, for the notice a taken address gets when somebody signs up with it again. +(defn claim-taken-signup-notice! [email-key] + (claim-once? [:taken-signup-notice email-key] (hours notice-cooldown-hours))) + ;; Three reset mails an hour to one address leaves room for "it never arrived, ;; send it again" and takes the bombing ceiling off unlimited. The per-address ;; limit is the one that protects a PERSON; the per-host limit is the one that @@ -337,8 +341,6 @@ {:none "a page; needs the unguessable reset key and changes nothing"} :orcpub.routes.auth/check-username {:none "usernames are public handles (profiles, shares), so membership is not a secret"} - :orcpub.routes.auth/check-email - {:none "TEMPORARY: removed by the sign-up change that stops revealing a taken address"} :orcpub.routes.auth/request-email-change #{:authenticated :cooldown} :orcpub.routes/unsubscribe diff --git a/src/cljc/orcpub/registration.cljc b/src/cljc/orcpub/registration.cljc index e75b07af0..fde24722e 100644 --- a/src/cljc/orcpub/registration.cljc +++ b/src/cljc/orcpub/registration.cljc @@ -244,7 +244,7 @@ (defn bad-hotmail? [email] (and email (second (re-matches #".*(hotmil|hotmall|htmail|htmial|hotmial).(.*)" email)))) -(defn validate-registration [{:keys [email verify-email username password first-and-last-name]} email-taken? username-taken?] +(defn validate-registration [{:keys [email verify-email username password first-and-last-name]} username-taken?] (let [bad-email-format? (bad-email? email) bad-gmail-domain (bad-gmail? email) bad-hotmail-domain (bad-hotmail? email) @@ -255,7 +255,6 @@ (cond-> {} bad-gmail-domain (update :email conj bad-gmail-domain) bad-hotmail-domain (update :email conj (str "Invalid domain '" bad-hotmail-domain "' did you mean 'hotmail'?")) - email-taken? (update :email conj "Email address is already associated with another account") emails-dont-match (update :verify-email conj "Email addresses don't match") bad-email-format? (update :email conj (if (s/blank? email) "Email is required" diff --git a/src/cljc/orcpub/route_map.cljc b/src/cljc/orcpub/route_map.cljc index cb9e6beed..69c619654 100644 --- a/src/cljc/orcpub/route_map.cljc +++ b/src/cljc/orcpub/route_map.cljc @@ -121,7 +121,6 @@ (def follow-user-route :follow-user) (def character-pdf-route :character-pdf) (def image-probe-route :image-probe) -(def check-email-route :check-email) (def check-username-route :check-username) (def user-route :user) (def user-email-route :user-email) @@ -157,7 +156,6 @@ "character.pdf" character-pdf-route "image-probe" image-probe-route - "check-email" check-email-route "check-username" check-username-route "reset-password" reset-password-route diff --git a/src/cljs/orcpub/dnd/e5/events/auth.cljs b/src/cljs/orcpub/dnd/e5/events/auth.cljs index 5e4bff6e8..fa151d1c2 100644 --- a/src/cljs/orcpub/dnd/e5/events/auth.cljs +++ b/src/cljs/orcpub/dnd/e5/events/auth.cljs @@ -220,11 +220,6 @@ #_ ;; dead stub — real impl is orcpub.registration/validate-registration (defn validate-registration []) -(reg-event-db - :email-taken - (fn [db [_ response]] - (assoc db :email-taken? (-> response :body (= "true"))))) - (reg-event-db :username-taken (fn [db [_ response]] @@ -236,11 +231,10 @@ (fn [db [_ first-and-last-name]] (assoc-in db [:registration-form :first-and-last-name] first-and-last-name))) -(reg-event-fx +(reg-event-db :registration-email - (fn [{:keys [db]} [_ email]] - {:db (assoc-in db [:registration-form :email] email) - :dispatch [:check-email email]})) + (fn [db [_ email]] + (assoc-in db [:registration-form :email] email))) (reg-event-fx :registration-verify-email @@ -287,14 +281,6 @@ (fn [db [_ first-and-last-name]] (assoc-in db [:registration-form :first-and-last-name] first-and-last-name))) -(reg-event-fx - :check-email - (fn [{:keys [db]} [_ email]] - {:http {:method :get - :url (backend-url (bidi/path-for routes/routes routes/check-email-route)) - :query-params {:email email} - :on-success [:email-taken]}})) - (reg-event-fx :check-username (fn [{:keys [db]} [_ username]] diff --git a/src/cljs/orcpub/dnd/e5/subs.cljs b/src/cljs/orcpub/dnd/e5/subs.cljs index 344fd5f23..3fe04b306 100644 --- a/src/cljs/orcpub/dnd/e5/subs.cljs +++ b/src/cljs/orcpub/dnd/e5/subs.cljs @@ -63,11 +63,6 @@ (fn [db [_]] (get db :username-taken?))) -(reg-sub - :email-taken? - (fn [db [_]] - (get db :email-taken?))) - (reg-sub :srd-message-closed? (fn [db [_]] @@ -86,14 +81,13 @@ (reg-sub :registration-validation :<- [:registration-form] - :<- [:email-taken?] :<- [:username-taken?] :<- [:registration-server-errors] - (fn [[form email-taken? username-taken? server] [_]] + (fn [[form username-taken? server] [_]] ;; Merged per field, so a server objection sits alongside anything the form ;; found rather than replacing it. (merge-with (comp vec distinct concat) - (registration/validate-registration form email-taken? username-taken?) + (registration/validate-registration form username-taken?) ;; :general is excluded: the submit button disables while this map has ;; anything in it, and a rate limit here would leave it stuck forever. ;; :password-common is excluded too -- it's the meter's verdict already, diff --git a/test/clj/orcpub/registration_email_test.clj b/test/clj/orcpub/registration_email_test.clj index 95835af9a..2334237de 100644 --- a/test/clj/orcpub/registration_email_test.clj +++ b/test/clj/orcpub/registration_email_test.clj @@ -7,7 +7,7 @@ (:require [clojure.edn :as edn] [clojure.string :as str] - [clojure.test :refer [deftest is use-fixtures]] + [clojure.test :refer [deftest is testing use-fixtures]] [datomic.api :as d] [orcpub.email :as email] [orcpub.errors :as errors] @@ -15,6 +15,7 @@ [orcpub.routes :as routes] [orcpub.routes.auth :as auth] [orcpub.security :as security] + [buddy.hashers :as hashers] [orcpub.db.schema :as schema]) (:import [java.util Date UUID])) @@ -117,3 +118,78 @@ (is (nil? (d/q '[:find (count ?e) . :where [?e :orcpub.user/verification-key]] (d/db conn))) "no record was created for an unknown address") (is (empty? (queued conn)) "and no email was queued for it"))) + +;; ---- Sign-up never says an address is taken: the owner is mailed instead ---- + +(defn- sign-up + "A sign-up as `username` with `address`, against `conn`." + [conn username address] + (-> (register-request conn) + (assoc-in [:json-params :username] username) + (assoc-in [:json-params :email] address) + (assoc-in [:json-params :verify-email] address) + auth/register)) + +(defn- accounts-with [conn address] + (d/q '[:find [?e ...] :in $ ?a :where [?e :orcpub.user/email ?a]] (d/db conn) address)) + +(deftest a-taken-address-gets-the-same-answer-as-a-new-one + (reset! @#'security/sightings {}) + (let [conn (fresh-conn) + _ (sign-up conn "newcomer" "newcomer@test.com") + fresh (sign-up conn "second" "fresh@test.com") + taken (sign-up conn "third" "newcomer@test.com")] + (is (= {:status 200} fresh)) + (is (= fresh taken) "same status, same body") + (is (= 1 (count (accounts-with conn "newcomer@test.com"))) "no second account") + (is (nil? (find-user (d/db conn) "third")) "and nothing created under the new username"))) + +(deftest the-owner-is-mailed-once-a-day-with-nothing-to-replay + (reset! @#'security/sightings {}) + (let [conn (fresh-conn) + _ (sign-up conn "newcomer" "newcomer@test.com") + key (:orcpub.user/verification-key (find-user (d/db conn) "newcomer")) + _ (outbox/send-due! conn (constantly true) #(Date.)) + _ (sign-up conn "intruder" "newcomer@test.com") + _ (sign-up conn "intruder2" "newcomer@test.com") + notices (filter #(= :signup-attempt (:kind %)) (queued conn)) + text (body (:message (first notices)))] + (is (= 1 (count notices)) "two attempts in a day, one notice") + (is (= "newcomer@test.com" (:to (first notices)))) + (is (str/includes? text "/login") "a way to sign in") + (is (str/includes? text "send-password-reset") "and to reset the password") + (doseq [secret ["hunter2hunter2" key "newcomer" "intruder"]] + (is (not (str/includes? text secret)) (str "no " secret))) + (testing "a different address has its own allowance" + (sign-up conn "other" "other@test.com") + (sign-up conn "other2" "other@test.com") + (is (= 2 (count (filter #(= :signup-attempt (:kind %)) (queued conn))) ) + "only the one taken address added a notice")))) + +(deftest a-taken-address-goes-through-the-same-checks-and-costs-the-same + (reset! @#'security/sightings {}) + (let [conn (fresh-conn) + _ (sign-up conn "newcomer" "newcomer@test.com") + hashed (atom 0) + allowed (atom 0)] + (with-redefs [hashers/encrypt (fn [& _] (swap! hashed inc) "hash") + security/registration-allowed? (fn [_] (swap! allowed inc) true)] + (sign-up conn "fresh" "fresh@test.com") + (is (= [1 1] [@hashed @allowed]) "a new sign-up") + (sign-up conn "third" "newcomer@test.com") + (is (= [2 2] [@hashed @allowed]) + "a taken one is counted against the host and hashes the password too")) + (testing "a failed challenge refuses a taken address exactly as a new one" + (with-redefs [security/turnstile-enabled? (constantly true) + security/turnstile-verify (constantly :fail) + security/registration-allowed? (fn [_] (swap! allowed inc) true)] + (let [before @allowed + new-resp (sign-up conn "fresh2" "fresh2@test.com") + taken-resp (sign-up conn "third" "newcomer@test.com")] + (is (= 400 (:status taken-resp))) + (is (= new-resp taken-resp)) + (is (= before @allowed) "and spends no allowance")))))) + +(deftest the-address-check-route-is-gone + (is (not-any? #(= "/check-email" (:path %)) routes/routes)) + (is (nil? (resolve 'orcpub.routes.auth/check-email)))) diff --git a/test/clj/orcpub/registration_no_email_test.clj b/test/clj/orcpub/registration_no_email_test.clj index 3cf744ec4..d4c9025d1 100644 --- a/test/clj/orcpub/registration_no_email_test.clj +++ b/test/clj/orcpub/registration_no_email_test.clj @@ -132,3 +132,21 @@ (str "expected a specific, actionable error. Got: " (pr-str resp))) (is (nil? (find-user (d/db conn))) "and no account may be created, verified or otherwise")))))) + +(deftest a-taken-address-gets-a-plain-refusal-when-there-is-no-mail-server + ;; Nobody can be mailed, so the sign-up cannot be answered like a new one. The refusal is + ;; general: it must not be a field error that names the address as taken. + (doseq [unverified-allowed? [true false]] + (let [conn (fresh-conn)] + (with-redefs [email/configured? (constantly false) + email/unverified-registration-allowed? (constantly true)] + (auth/register (register-request conn))) + (with-redefs [email/configured? (constantly false) + email/unverified-registration-allowed? (constantly unverified-allowed?)] + (let [resp (auth/register (assoc-in (register-request conn) [:json-params :username] "second"))] + (is (= 400 (:status resp))) + (is (= {:general ["This email can't be used. Check it and try again, or sign in."]} + (:body resp)) + "a general error, with no :email key") + (is (= 1 (d/q '[:find (count ?e) . :where [?e :orcpub.user/email]] (d/db conn))) + "and no second account")))))) diff --git a/test/cljc/orcpub/registration_test.cljc b/test/cljc/orcpub/registration_test.cljc index 56cebb689..403cfe3e6 100644 --- a/test/cljc/orcpub/registration_test.cljc +++ b/test/cljc/orcpub/registration_test.cljc @@ -65,7 +65,7 @@ (let [errs (reg/validate-registration {:email "ana@example.com" :verify-email "ana@example.com" :username "thornwood" :password "thornwood1"} - false false)] + false)] (testing "the identifier rule fires through the registration path" (is (some #(re-find #"username and email" %) (:password errs)))))) From 93cdb2d3d5fd02af82076267e33903cca5e62a28 Mon Sep 17 00:00:00 2001 From: codeGlaze Date: Wed, 4 Nov 2026 15:46:12 +0000 Subject: [PATCH 16/27] Let the security-check warning be dismissed --- src/cljs/orcpub/dnd/e5/views/auth.cljs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/cljs/orcpub/dnd/e5/views/auth.cljs b/src/cljs/orcpub/dnd/e5/views/auth.cljs index 252d9d025..9990cf55f 100644 --- a/src/cljs/orcpub/dnd/e5/views/auth.cljs +++ b/src/cljs/orcpub/dnd/e5/views/auth.cljs @@ -107,7 +107,7 @@ [:div.m-t-10 [:div {:ref #(reset! el %)}] (when @(subscribe [:turnstile-blocked?]) - [notifications/message :warning errors/turnstile-blocked-message identity])])})))) + [notifications/message :warning errors/turnstile-blocked-message #(dispatch [:turnstile-blocked false])])])})))) ;; ---- Account screens ---- From 8bc2b6e4c0c4578c66c4c57ec5bf27a77e78cebd Mon Sep 17 00:00:00 2001 From: codeGlaze Date: Wed, 4 Nov 2026 17:38:06 +0000 Subject: [PATCH 17/27] Auth forms: one policy table and one guard security/auth-guards is now the policy as data (limits, challenge, answer style per route) and security/guard and record! are the only code that reads it. The per-form predicates, the separate login counters and the turnstile-refused? helper are gone; login counts through the same sightings. Handlers name their route and pass what they know. Tests iterate the table instead of repeating per form. --- src/clj/orcpub/routes/auth.clj | 207 +++-- src/clj/orcpub/security.clj | 481 ++++++------ test/clj/orcpub/registration_email_test.clj | 32 +- .../clj/orcpub/registration_no_email_test.clj | 11 +- test/clj/orcpub/routes_test.clj | 217 +----- test/clj/orcpub/security_audit_test.clj | 6 +- test/clj/orcpub/security_test.clj | 721 +++++++----------- test/clj/orcpub/user_email_test.clj | 2 +- 8 files changed, 674 insertions(+), 1003 deletions(-) diff --git a/src/clj/orcpub/routes/auth.clj b/src/clj/orcpub/routes/auth.clj index a8a43e7cd..1224995af 100644 --- a/src/clj/orcpub/routes/auth.clj +++ b/src/clj/orcpub/routes/auth.clj @@ -195,36 +195,57 @@ [] (when (security/turnstile-enabled?) {:challenge? true})) +(def ^:private turnstile-failed-message + "We couldn't confirm you're not a bot. Please try the check again.") + +(defn- turnstile-message + "Why the challenge refused: a blank token means the widget never ran (a blocked script), which the + player can fix; a token that failed verification just means try the check again." + [blank?] + (if blank? errors/turnstile-blocked-message turnstile-failed-message)) + +(defn- refusal-response + "The response to a refusal from security/guard or record!, in the style the route's policy names + (:answer in security/auth-guards). The same for every address and name, and nothing here looks + anything up, so a refusal cannot say whether an account exists. A failed challenge is retried + with a fresh token." + [route {:keys [reason blank?]}] + (let [{:keys [answer message]} (security/policy route)] + (cond + (and (= reason :turnstile) (= answer :error)) (login-error errors/challenge-required {:challenge? true}) + (= reason :turnstile) {:status 400 :body {:general [(turnstile-message blank?)]}} + (= answer :uniform) {:status 200} + (= answer :error) (login-error errors/too-many-attempts (challenge-flag)) + :else {:status 400 :body {:general [message]}}))) + (defn bad-credentials-response [db username ip request] - (security/add-failed-login-attempt! username ip) - (security/mark-login-challenge! username ip) - (if (security/too-many-attempts-for-username? username) - (do (security/note-refusal! :login-username) - (login-error errors/too-many-attempts (challenge-flag))) - (let [user-for-username (find-user-by-username-or-email db username)] - ;; A name with no account is not logged: it is sometimes a password typed in the wrong box. - (security/audit! :sign-in-failed request (:orcpub.user/username user-for-username)) - ;; Several addresses failing against ONE account inside a minute is also what - ;; a person with a phone, a laptop and a tablet looks like -- so it notifies - ;; the owner rather than locking them out. Runs on another thread, and its - ;; outcome never reaches the response: failing logins must not learn a thing. - (when (and (:db/id user-for-username) - (security/multiple-ip-attempts-to-same-account? username) - (security/claim-sign-in-notice! username)) - (future - (try - (outbox/enqueue! (:conn request) :sign-in-attempts - (email/sign-in-attempts-message - (base-url request) - {:email (:orcpub.user/email user-for-username) - :first-and-last-name (:orcpub.user/first-and-last-name user-for-username) - :user-agent (get (:headers request) "user-agent")})) - (catch Exception e - (println "ERROR: could not queue a sign-in attempts notice:" (.getMessage e)))))) - ;; One answer for both. Telling somebody the username does not exist made - ;; the login form the same membership test the reset endpoint was, and a - ;; cheaper one, since it needs no mail to be sent. - (login-error errors/bad-credentials (challenge-flag))))) + (let [{:keys [refusal notify]} (security/record! ::login :failure {:ip ip :typed-name username})] + (if refusal + (refusal-response ::login refusal) + (let [user-for-username (find-user-by-username-or-email db username) + notice (and notify (:db/id user-for-username) + (security/claim-sign-in-notice! username))] + ;; A name with no account is not logged: it is sometimes a password typed in the wrong box. + (security/audit! :sign-in-failed request (:orcpub.user/username user-for-username)) + ;; Several addresses failing against ONE account inside a minute is also what + ;; a person with a phone, a laptop and a tablet looks like -- so it notifies + ;; the owner rather than locking them out. Runs on another thread, and its + ;; outcome never reaches the response: failing logins must not learn a thing. + (when notice + (future + (try + (outbox/enqueue! (:conn request) :sign-in-attempts + (email/sign-in-attempts-message + (base-url request) + {:email (:orcpub.user/email user-for-username) + :first-and-last-name (:orcpub.user/first-and-last-name user-for-username) + :user-agent (get (:headers request) "user-agent")})) + (catch Exception e + (println "ERROR: could not queue a sign-in attempts notice:" (.getMessage e)))))) + ;; One answer for both. Telling somebody the username does not exist made + ;; the login form the same membership test the reset endpoint was, and a + ;; cheaper one, since it needs no mail to be sent. + (login-error errors/bad-credentials (challenge-flag)))))) (defn create-login-response [db conn user id & [headers]] (let [token (create-token (:orcpub.user/username user) @@ -240,26 +261,17 @@ (defn login-response [{:keys [json-params db conn remote-addr] :as request}] - (let [{raw-username :username raw-password :password} json-params] + (let [{raw-username :username raw-password :password} json-params + refusal (when-not (or (s/blank? raw-username) (s/blank? raw-password)) + ;; Before the credentials are looked at, so a bot without a token learns nothing + ;; from the answer, and a spray is stopped before it can land on the account it + ;; guesses right (see security/auth-guards). + (security/guard ::login {:ip remote-addr :typed-name raw-username + :token (:turnstile-token json-params)}))] (cond (s/blank? raw-username) (login-error errors/username-required) (s/blank? raw-password) (login-error errors/password-required) - - ;; Checked before the credentials, not on the failure path: stuffing ends on - ;; the one account it guesses right, so a check that only runs after a failed - ;; lookup would never see that attempt. Trips on five DISTINCT usernames - ;; failing from this address inside a minute -- one person on several devices can't, a spray across accounts can. - (security/multiple-account-access? remote-addr) - (do (security/note-refusal! :login-spray) - (security/mark-login-challenge! raw-username remote-addr) - (login-error errors/too-many-attempts (challenge-flag))) - - ;; Only for a name that just failed from this connection, and BEFORE the credentials are - ;; looked at, so a bot without a token learns nothing from the answer. A blank token is - ;; :fail without calling Cloudflare; :unreachable is a pass. - (and (security/login-challenge-required? raw-username remote-addr) - (= :fail (security/turnstile-verify (:turnstile-token json-params) remote-addr))) - (login-error errors/challenge-required {:challenge? true}) + refusal (refusal-response ::login refusal) :else (let [username (s/trim raw-username) password (s/trim raw-password) @@ -274,7 +286,7 @@ (and unverified? expired?) (login-error errors/unverified-expired) unverified? (login-error errors/unverified {:email email}) :else - (do (security/clear-login-challenge! username remote-addr) + (do (security/record! ::login :success {:ip remote-addr :typed-name username}) (security/audit! :sign-in request (:orcpub.user/username user)) (create-login-response db conn user id))))))) @@ -393,26 +405,6 @@ ;; sitting right above a meter reporting UNCOMMON in green: two disagreeing verdicts. {:password-common [(breach-message result)]}))) -(def ^:private registration-throttled-message - (str "Too many accounts have been created from this connection in the last hour. " - "Try again a little later, or email us if you are stuck.")) - -(def ^:private turnstile-failed-message - "We couldn't confirm you're not a bot. Please try the check again.") - -(defn- turnstile-message - "Why the challenge refused: no token at all means the widget never ran (a blocked script), which - the player can fix; a token that failed verification just means try the check again." - [token] - (if (s/blank? token) errors/turnstile-blocked-message turnstile-failed-message)) - -(defn- turnstile-refusal - "A 400 for a failed challenge, or nil. Answered the same for every address and checked before - any lookup, so it cannot say whether an account exists. The caller retries with a fresh token." - [route-name token remote-addr] - (when (security/turnstile-refused? route-name token remote-addr) - {:status 400 :body {:general [(turnstile-message token)]}})) - (def ^:private taken-email-refusal-message "This email can't be used. Check it and try again, or sign in.") @@ -462,26 +454,18 @@ validation (if (seq validation) validation (or (breach-errors password) validation)) - ;; Before the host allowance, so a bot that fails the challenge does not use up the - ;; host's signups. After validation and the breach check, so a form that was going to - ;; be rejected anyway never costs a verification. :unreachable is a pass (fail open). - ;; :general for the same reason as the throttle below. - validation (if (and (empty? validation) - (security/turnstile-refused? ::register (:turnstile-token json-params) remote-addr)) - (assoc validation :general [(turnstile-message (:turnstile-token json-params))]) - validation) - ;; Checked last, so a form that was going to be rejected anyway is not - ;; counted against the host. :general rather than a field key: nobody - ;; can edit their way past a rate limit, so it must not sit in the map - ;; that disables the button. - validation (if (or (seq validation) (security/registration-allowed? remote-addr)) - validation - (assoc validation :general [registration-throttled-message]))] + ;; Only for a form that was going to go through: no reason to ask a third party about a + ;; malformed sign-up, or to count it against the host. The challenge comes first, so a bot + ;; that fails it does not use up the host's sign-ups. + refusal (when (empty? validation) + (security/guard ::register {:ip remote-addr :token (:turnstile-token json-params)}))] (cond (seq validation) {:status 400 :body validation} + refusal (refusal-response ::register refusal) + taken? (answer-taken-email request email password) @@ -573,20 +557,23 @@ (defn re-verify [{:keys [query-params db conn remote-addr] :as request}] (let [email (:email query-params) - refusal (turnstile-refusal ::re-verify (:turnstile-token query-params) remote-addr) + user (delay (user-for-email db email)) + ;; The challenge first, then (only for an unverified account that exists) the allowances. + ;; A limit answers like an unknown address, so it is not a membership oracle. + refusal (security/guard ::re-verify + {:ip remote-addr :address email + :token (:turnstile-token query-params) + :actionable (delay (and (:db/id @user) + (not (:orcpub.user/verified? @user))))}) query-params (dissoc query-params :turnstile-token) - {:keys [:orcpub.user/verification-sent - :orcpub.user/verified? - :db/id] :as user} (when-not refusal (user-for-email db email))] + {:keys [:orcpub.user/verified? + :db/id] :as user} (when-not refusal @user)] (cond - ;; Before the lookup and before either allowance is spent. - refusal refusal + refusal (refusal-response ::re-verify refusal) verified? (redirect route-map/verify-success-route) ;; No account for this address: answer like a resend and create nothing. Passing ;; {:db/id nil} on would register a key-only record and email a link to any address typed. (nil? id) {:status 200} - ;; Over the limit: the same answer as an unknown address, so the limit is not a membership oracle. - (not (security/reverify-email-allowed? email remote-addr)) {:status 200} :else (do-verification request (merge query-params @@ -661,24 +648,28 @@ (defn send-password-reset [{:keys [query-params db conn remote-addr] :as request}] (let [email (:email query-params) - refusal (turnstile-refusal ::send-password-reset (:turnstile-token query-params) remote-addr) - {:keys [:db/id]} (when-not refusal (user-for-email db email))] - ;; The answer is identical whether or not that address has an account: - ;; confirmed-valid addresses are precisely what a stuffing run needs. - ;; The per-address limit is checked AFTER the lookup but never changes the - ;; response -- a limit that visibly altered it would itself be a membership oracle, which the uniform 200 closes. - (when (and id (not refusal) (security/reset-email-allowed? email remote-addr)) - (try - (do-send-password-reset id email conn request) - (security/audit! :password-reset-requested request - (:orcpub.user/username (d/entity db id))) - (catch Exception e - ;; Swallowed on purpose. Letting this escape would restore the oracle - ;; in a subtler form -- only a real account can fail to be emailed, - ;; so an error response would mark the address as registered. - (println "ERROR: password reset for a known address could not be sent:" - (.getMessage e))))) - (or refusal {:status 200}))) + user (delay (user-for-email db email)) + ;; The answer is identical whether or not that address has an account: confirmed-valid + ;; addresses are precisely what a stuffing run needs. The allowances are spent only for an + ;; address that has an account, after the lookup, and a limit never changes the response -- + ;; one that visibly altered it would itself be a membership oracle. + refusal (security/guard ::send-password-reset + {:ip remote-addr :address email + :token (:turnstile-token query-params) + :actionable (delay (:db/id @user))})] + (or (when refusal (refusal-response ::send-password-reset refusal)) + (do (when-let [id (:db/id @user)] + (try + (do-send-password-reset id email conn request) + (security/audit! :password-reset-requested request + (:orcpub.user/username (d/entity db id))) + (catch Exception e + ;; Swallowed on purpose. Letting this escape would restore the oracle + ;; in a subtler form -- only a real account can fail to be emailed, + ;; so an error response would mark the address as registered. + (println "ERROR: password reset for a known address could not be sent:" + (.getMessage e))))) + {:status 200})))) (def reset-link-spent-message "This reset link has expired or has already been used. Request a new one from the login page.") diff --git a/src/clj/orcpub/security.clj b/src/clj/orcpub/security.clj index 4f8eb7825..ae715bf54 100644 --- a/src/clj/orcpub/security.clj +++ b/src/clj/orcpub/security.clj @@ -1,107 +1,12 @@ (ns orcpub.security - "Login attempt tracking and rate limiting. + "Abuse limits on the account forms: one policy table (auth-guards), one guard over it, the + Turnstile check, and the cadence of the notices sent to account owners. See orcpub.time for date/time utilities." (:require [clj-http.client :as client] [clojure.string :as s] [orcpub.config :as config] [orcpub.time :as time :refer [minutes hours ago]])) -(defn compare-dates [attempt-1 attempt-2] - (compare (:date attempt-1) (:date attempt-2))) - -(def failed-login-attempts-by-username - (atom {})) - -(def failed-login-attempts-by-ip - (atom {})) - -(defn threshold [] - (-> 1 minutes ago)) - -(defn remove-old [attempts threshold-date] - (reduce - (fn [as [k v]] - (let [past-threshold (into (sorted-set-by compare-dates) (subseq v > {:date threshold-date}))] - (if (seq past-threshold) - (assoc as k past-threshold) - as))) - {} - attempts)) - -(defn add-and-remove-old [key attempt attempts threshold-date] - (-> attempts - (remove-old threshold-date) - (update key #(conj (or % (sorted-set-by compare-dates)) attempt)))) - -(defn add-failed-login-attempt! [username ip] - (let [attempt {:user username - :ip ip - :date (time/now)}] - (swap! failed-login-attempts-by-username - #(add-and-remove-old username attempt % (threshold))) - (swap! failed-login-attempts-by-ip - #(add-and-remove-old ip attempt % (threshold))))) - -(defn threshold-attempts [attempts time] - (let [thresholded (subseq attempts > {:date time})] - thresholded)) - -(defn too-many-attempts-for-username-aux [username attempts-by-username] - (some-> username - attempts-by-username - (threshold-attempts (threshold)) - count - (>= 5))) - -(defn too-many-attempts-for-username? [username] - (too-many-attempts-for-username-aux - username - @failed-login-attempts-by-username)) - -(defn usernames-for-attempts [attempts] - (set (map :user attempts))) - -(defn ips-for-attempts [attempts] - (set (map :ip attempts))) - -(defn multiple-account-access-aux [ip attempts-by-ip] - (some-> ip - attempts-by-ip - ;; Filter attempts newer than 1 minute ago. - ;; Uses {:date ...} map because sorted-set compares by :date field. - (subseq > {:date (-> 1 minutes ago)}) - usernames-for-attempts - count - (>= 5))) - -(defn multiple-account-access? [ip] - (multiple-account-access-aux - ip - @failed-login-attempts-by-ip)) - -(defn multiple-ip-attempts-to-same-account-aux - "True when `username` has failed logins from 3+ distinct IPs in the last minute. - Returns nil, not false, when the username has no recorded attempts." - [username attempts-by-username] - (some-> username - attempts-by-username - ;; Filter attempts newer than 1 minute ago. - ;; Uses {:date ...} map because sorted-set compares by :date field. - (subseq > {:date (-> 1 minutes ago)}) - ips-for-attempts - count - (>= 3))) - -;; Three addresses failing against ONE account inside the window. That is what a -;; credential-stuffing run looks like, and it is also what somebody with a phone, -;; a laptop and a tablet looks like -- so bad-credentials-response in routes.clj -;; uses it to TELL the account holder rather than to lock anyone out. -(defn multiple-ip-attempts-to-same-account? [username] - (multiple-ip-attempts-to-same-account-aux - username - @failed-login-attempts-by-username)) - - (defn- log-safe "`v` as text fit for one log line: control characters removed, at most 100 characters; nil stays nil." [v] @@ -235,30 +140,46 @@ [] @password-changes) +;; Every recorded event is [instant who]: `who` is what a distinct-count limit counts (the typed +;; name behind a connection, or the connection behind a typed name); nil when nothing needs it. (def ^:private sightings (atom {})) +;; The longest window any limit uses; entries older than this belong to nobody. +(def ^:private prune-horizon (hours 24)) + (defn- prune [m cutoff] (into {} (keep (fn [[k ts]] - (let [live (remove #(.isBefore % cutoff) ts)] - (when (seq live) [k (vec live)])))) + (let [live (filterv #(not (.isBefore ^java.time.Instant (first %) cutoff)) ts)] + (when (seq live) [k live])))) m)) -(defn under-limit? - "True while `k` has been seen fewer than `limit` times inside `window`, and - false once it has hit the limit. The sighting is recorded in the same swap - that answers, so simultaneous callers cannot both be told yes on the last - slot. `k` is any value -- callers namespace their own, e.g. [:reset email]." - [k limit window] +(defn- recent + "The sightings of `k` inside `window`, without recording anything." + [k window] + (let [cutoff (ago window)] + (filterv #(not (.isBefore ^java.time.Instant (first %) cutoff)) (get @sightings k)))) + +(defn- sight! + "Records one sighting of `k` by `who` and returns those inside `window` from BEFORE it. The + record and the read are one swap, so simultaneous callers cannot both be told yes on the last + slot." + [k window who] (let [cutoff (ago window) + at (time/now) [before _] (swap-vals! sightings (fn [m] - (let [m (prune m cutoff)] - (update m k #(conj (vec %) (time/now)))))) - seen (count (remove #(.isBefore % cutoff) (get before k))) - allowed (< seen limit)] - ;; The key's first element names the limit, so every caller is counted - ;; without having to remember to say so. + (-> (prune m (ago prune-horizon)) + (update k #(conj (filterv (fn [e] (not (.isBefore ^java.time.Instant (first e) cutoff))) %) + [at who])))))] + (filterv #(not (.isBefore ^java.time.Instant (first %) cutoff)) (get before k)))) + +(defn under-limit? + "True while `k` has been seen fewer than `limit` times inside `window`, and false once it has hit + the limit. `k` is any value; a vector's first element names the limit in the logs. Used directly + only by endpoints that are not account forms; those go through `guard`." + [k limit window] + (let [allowed (< (count (sight! k window nil)) limit)] (when-not allowed (note-refusal! (if (vector? k) (first k) k) (when (vector? k) (second k)))) @@ -269,72 +190,56 @@ [k window] (under-limit? k 1 window)) -;; One sign-in notice per account per day. An attacker who can trigger the -;; condition can trigger it on a loop, and without this the warning would be a -;; way to mail-bomb any account whose username is public. -(def notice-cooldown-hours 24) - -(defn claim-sign-in-notice! [username] - (claim-once? [:sign-in-notice username] (hours notice-cooldown-hours))) - -;; Same reason, for the notice a taken address gets when somebody signs up with it again. -(defn claim-taken-signup-notice! [email-key] - (claim-once? [:taken-signup-notice email-key] (hours notice-cooldown-hours))) +;; The probe has no login, so IP is the only handle on who is asking. A real +;; character builder fires it once per image field, well under this; a script +;; walking a URL list to keep the fetch pool occupied is what it stops. +(def image-probe-per-host-hourly 300) -;; Three reset mails an hour to one address leaves room for "it never arrived, -;; send it again" and takes the bombing ceiling off unlimited. The per-address -;; limit is the one that protects a PERSON; the per-host limit is the one that -;; stops somebody walking a list of addresses through the same endpoint. -(def reset-per-address-hourly 3) -(def reset-per-host-hourly 10) - -(defn reset-email-allowed? [email ip] - (and (under-limit? [:reset-address email] reset-per-address-hourly (hours 1)) - (under-limit? [:reset-host ip] reset-per-host-hourly (hours 1)))) - -;; Same ceilings as reset: the resend endpoint mails any registered, unverified -;; address just as the reset endpoint does, so it gets the same two limits. -(def reverify-per-address-hourly 3) -(def reverify-per-host-hourly 10) - -(defn reverify-email-allowed? - "True while `email` and `ip` are both under their hourly resend-verification - limits. Counts the attempt against each limit, so call it once per request." - [email ip] - (and (under-limit? [:reverify-address email] reverify-per-address-hourly (hours 1)) - (under-limit? [:reverify-host ip] reverify-per-host-hourly (hours 1)))) - -;; What this defends is NOT the account table -- an unverified account cannot log -;; in, so bulk signups sit inert. What signup CAN do is send mail to an address -;; the filler doesn't own, same as the reset endpoint. Sized to real use (eight -;; people at one game night, plus retries and typos), not to the attack: a bulk run wants thousands, so any sane number stops it. -(def registrations-per-host-hourly 10) - -(defn registration-allowed? [ip] - (under-limit? [:register ip] registrations-per-host-hourly (hours 1))) +(defn image-probe-allowed? [ip] + (under-limit? [:image-probe-host ip] image-probe-per-host-hourly (hours 1))) ;; --------------------------------------------------------------------------- -;; One table of what guards every account endpoint a stranger can reach, keyed by Pedestal -;; route name. A value is a set of guards or {:none "why nothing is needed"}; the route-table -;; test in security_test.clj fails when a route is missing here or this names a route that -;; does not exist. Limit code is not driven by it; the test is the check. - -;; Guards: :per-address-limit, :per-host-limit, :per-account-limit (typed name), -;; :turnstile, :turnstile-after-failure, :uniform-answer (cannot tell whether an address -;; or account exists), :cooldown (email change), :authenticated. +;; The policy of every account endpoint a stranger can reach, as data. `guard` and `record!` below +;; are the only code that reads it; handlers hold no numbers. The route-table test fails when a +;; route is missing or stale, and the table-driven tests iterate it. ;; --------------------------------------------------------------------------- (def auth-guards + "Per route key: :limits [[scope n window] ...] (scope :per-address :per-host :per-name + :names-per-host; window :minute :hour; a fourth element :when-failing refuses only the failing + attempt that reaches n), :counted-on :failure (else every request counts), :spend + :when-actionable (only when ctx's :actionable delay is true), :turnstile :always or + :after-failure, :answer :uniform (the ordinary 200) :message (the :message) :error (the form's + own), :notify {:kind :scope :distinct :window} (see record!); or {:none \"why\"}." {:orcpub.routes.auth/login - #{:per-account-limit :per-host-limit :turnstile-after-failure :uniform-answer} + {:limits [[:names-per-host 5 :minute] [:per-name 5 :minute :when-failing]] + :counted-on :failure + :turnstile :after-failure + :answer :error + :notify {:kind :sign-in-attempts :scope :per-name :distinct 3 :window :minute}} + ;; What this defends is NOT the account table -- an unverified account cannot log in, so bulk + ;; signups sit inert. What signup CAN do is send mail to an address the filler doesn't own. + ;; Sized to real use (eight people at one game night, plus retries and typos). :orcpub.routes.auth/register - #{:per-host-limit :turnstile :uniform-answer} + {:limits [[:per-host 10 :hour]] + :turnstile :always + :answer :message + :message (str "Too many accounts have been created from this connection in the last hour. " + "Try again a little later, or email us if you are stuck.")} :orcpub.routes.auth/verify {:none "the link carries an unguessable verification key; a wrong key changes nothing"} + ;; Three mails an hour to one address leaves room for "it never arrived, send it again"; the + ;; per-host limit stops somebody walking a list of addresses through the endpoint. :orcpub.routes.auth/re-verify - #{:per-address-limit :per-host-limit :turnstile :uniform-answer} + {:limits [[:per-address 3 :hour] [:per-host 10 :hour]] + :turnstile :always + :answer :uniform + :spend :when-actionable} :orcpub.routes.auth/send-password-reset - #{:per-address-limit :per-host-limit :turnstile :uniform-answer} + {:limits [[:per-address 3 :hour] [:per-host 10 :hour]] + :turnstile :always + :answer :uniform + :spend :when-actionable} :orcpub.routes.auth/reset-password {:none "needs the unguessable single-use reset key from the mailed link"} :orcpub.routes.auth/reset-password-page @@ -342,72 +247,48 @@ :orcpub.routes.auth/check-username {:none "usernames are public handles (profiles, shares), so membership is not a secret"} :orcpub.routes.auth/request-email-change - #{:authenticated :cooldown} + {:none "needs a signed-in session and the current password, and has its own cooldown (email-change-rate-limited?)"} :orcpub.routes/unsubscribe {:none "the link carries a signed token; an unsigned or tampered one is refused"}}) -(defn guard-of - "The guards of route `route-name`, or nil for an unknown route." - [route-name] - (get auth-guards route-name)) +(defn policy + "The guard policy of `route`, or nil for a route that has none (or is unknown)." + [route] + (let [p (get auth-guards route)] + (when-not (:none p) p))) -(defn guarded-by? - "True when route `route-name` lists `guard` in auth-guards." - [route-name guard] - (let [g (guard-of route-name)] - (boolean (and (set? g) (contains? g guard))))) +(def ^:private windows {:minute (minutes 1) :hour (hours 1)}) -;; The probe has no login, so IP is the only handle on who is asking. A real -;; character builder fires it once per image field, well under this; a script -;; walking a URL list to keep the fetch pool occupied is what it stops. -(def image-probe-per-host-hourly 300) +(def ^:private scopes + {:per-address {:subject :address} + :per-host {:subject :ip} + :per-name {:subject :typed-name :who :ip} + :names-per-host {:subject :ip :who :typed-name :distinct? true}}) -(defn image-probe-allowed? [ip] - (under-limit? [:image-probe-host ip] image-probe-per-host-hourly (hours 1))) +(defn limit-name + "The name a limit goes by in the logs and the busiest line: the route plus the scope." + [route scope] + (keyword (str (name route) "-" (name scope)))) -(defn busiest - "The heaviest single user of each limit in the window, whether or not it was - ever refused. A host that stops at ten signups an hour, every hour, never - trips anything and so never appears in the refusals at all -- this is the - only place it shows up." - [] - (->> @sightings - (reduce (fn [acc [k ts]] - (let [limit (if (vector? k) (first k) k)] - (update acc limit (fnil max 0) (count ts)))) - {}))) +(defn- normalise + "Typed text as the lookups see it: trimmed and lowercased. Anything else is left alone." + [v] + (if (string? v) (s/lower-case (s/trim v)) v)) -(defn busiest-summary - "A line naming any limit whose heaviest user is at least at `floor` of it -- - the quiet version of abuse, which sits just inside every number it is given." - [highs floor] - (let [caps {:register registrations-per-host-hourly - :reset-address reset-per-address-hourly - :reset-host reset-per-host-hourly - :reverify-address reverify-per-address-hourly - :reverify-host reverify-per-host-hourly - :image-probe-host image-probe-per-host-hourly} - near (for [[what n] highs - :let [cap (get caps what)] - :when (and cap (>= n (* floor cap)))] - (str (name what) " " n "/" cap))] - (when (seq near) - (str "limits, busiest source: " (apply str (interpose ", " near)))))) +(defn- limit-key [route scope ctx] + [(limit-name route scope) (normalise (get ctx (:subject (scopes scope))))]) -(defn summary-job - "Heartbeat job: at most two lines an hour, and silent when there is nothing - to say. The first is what was turned away and how widely; the second is the - heaviest user of any limit that is sitting at 80% or more of it." - [_conn] - (let [highs (busiest)] - (when-let [line (refusal-summary (take-refusals!))] - (println line)) - (when-let [line (busiest-summary highs 0.8)] - (println line)))) +(defn- who-of [scope ctx] + (normalise (some->> (:who (scopes scope)) (get ctx)))) + +(defn- full? + "Whether `entries` (sightings of one limit) have reached `n`." + [scope n entries] + (>= (if (:distinct? (scopes scope)) (count (distinct (map second entries))) (count entries)) n)) ;; --------------------------------------------------------------------------- -;; Cloudflare Turnstile check for the sign-up form (managed mode). -;; GOTCHA: fails OPEN. If Cloudflare cannot be reached, the signup goes through; only an +;; Cloudflare Turnstile (managed mode), on the forms whose policy asks for it. +;; GOTCHA: fails OPEN. If Cloudflare cannot be reached the request goes through; only an ;; answer of success=false (or no token at all) refuses. The secret key is never logged. ;; --------------------------------------------------------------------------- @@ -466,14 +347,6 @@ (.. e getClass getSimpleName))) :unreachable)))) -(defn turnstile-refused? - "True when route `route-name` lists :turnstile in auth-guards, the challenge is on, and `token` - fails it. :unreachable is not a refusal. A route that does not list :turnstile is never refused." - [route-name token remote-ip] - (boolean (and (guarded-by? route-name :turnstile) - (turnstile-enabled?) - (= :fail (turnstile-verify token remote-ip))))) - ;; --------------------------------------------------------------------------- ;; Sign-in challenge after a failure. A failed sign-in marks the NEXT attempt from that ;; connection with that typed name as needing the challenge. The key is the typed text, trimmed @@ -489,7 +362,7 @@ (def ^:private login-challenges (atom {})) (defn- login-challenge-key [typed-name remote-ip] - [(s/lower-case (s/trim (str typed-name))) remote-ip]) + [(normalise (str typed-name)) remote-ip]) (defn mark-login-challenge! "Marks `typed-name` from `remote-ip` as needing the challenge on its next attempt, for 15 minutes. @@ -513,7 +386,153 @@ (defn login-challenge-required? "True while Turnstile is on and `typed-name` from `remote-ip` failed a sign-in in the last 15 minutes." [typed-name remote-ip] - (boolean (and (guarded-by? :orcpub.routes.auth/login :turnstile-after-failure) - (turnstile-enabled?) + (boolean (and (turnstile-enabled?) (when-let [until (get @login-challenges (login-challenge-key typed-name remote-ip))] (> until (System/currentTimeMillis)))))) + +;; --------------------------------------------------------------------------- +;; The one guard. A handler calls `guard` before it does the work and, for a form that counts +;; failures, `record!` when one happens; both read auth-guards and nothing else. +;; --------------------------------------------------------------------------- + +(defn- refuse! [k] + (note-refusal! (first k) (second k)) + {:reason :limit :limit (first k)}) + +(defn- challenge-refusal + "{:reason :turnstile :blank? ...} when the policy wants the challenge for this request, it is on, + and the token fails it. :unreachable is not a refusal." + [p {:keys [token ip typed-name]}] + (when (and (:turnstile p) + (turnstile-enabled?) + (or (= :always (:turnstile p)) (login-challenge-required? typed-name ip)) + (= :fail (turnstile-verify token ip))) + {:reason :turnstile :blank? (s/blank? token)})) + +(defn- inspect-limits + "The first limit already full, without counting this request: for forms that count failures." + [route p ctx] + (some (fn [[scope n window when-failing]] + (let [k (limit-key route scope ctx)] + (when (and (not when-failing) (full? scope n (recent k (windows window)))) + (refuse! k)))) + (:limits p))) + +(defn- spend-limits + "Counts this request against each limit in order, stopping at the first that is full. Skipped when + the policy spends only on an actionable request and this one is not." + [route p ctx] + (when (or (not= :when-actionable (:spend p)) (force (:actionable ctx))) + (some (fn [[scope n window]] + (let [k (limit-key route scope ctx)] + (when (full? scope n (sight! k (windows window) (who-of scope ctx))) + (refuse! k)))) + (:limits p)))) + +(defn guard + "nil when the request may go on, else a refusal: {:reason :turnstile :blank? bool} or + {:reason :limit :limit kw}. `route` is a key of auth-guards; `ctx` holds what the handler knows: + :ip, :address, :typed-name, :token, and :actionable (a delay: whether this request has anything + to do, forced only after the challenge). A route with no policy is never refused. Order: limits + that merely look (failure-counted forms), the challenge, then limits that count -- so a failed + challenge spends no allowance and a refusal can never come from a lookup." + [route ctx] + (when-let [p (policy route)] + (let [on-failure? (= :failure (:counted-on p))] + (or (when on-failure? + (when-let [r (inspect-limits route p ctx)] + (when (= :after-failure (:turnstile p)) + (mark-login-challenge! (:typed-name ctx) (:ip ctx))) + r)) + (challenge-refusal p ctx) + (when-not on-failure? (spend-limits route p ctx)))))) + +(defn record! + "Counts an outcome for a form whose policy counts failures. :failure records it against every + limit, marks the next attempt for the challenge when the policy has one, and returns + {:refusal r-or-nil :notify kind-or-nil}: a refusal when a :when-failing limit is now full, and the + kind of notice to claim when the policy's :notify spread has been reached. :success clears the + mark. Returns nil for a route with no policy." + [route event ctx] + (when-let [p (policy route)] + (case event + :success (do (when (= :after-failure (:turnstile p)) + (clear-login-challenge! (:typed-name ctx) (:ip ctx))) + nil) + :failure + (let [seen (mapv (fn [[scope n window when-failing :as limit]] + (let [k (limit-key route scope ctx)] + [limit k (sight! k (windows window) (who-of scope ctx))])) + (:limits p)) + _ (when (= :after-failure (:turnstile p)) + (mark-login-challenge! (:typed-name ctx) (:ip ctx))) + {:keys [kind scope distinct window]} (:notify p)] + {:refusal (some (fn [[[scope n _ when-failing] k before]] + (when (and when-failing + (full? scope n (conj before [nil (who-of scope ctx)]))) + (refuse! k))) + seen) + :notify (when (and kind + (>= (count (clojure.core/distinct + (map second (recent (limit-key route scope ctx) (windows window))))) + distinct)) + kind)})))) + +;; --------------------------------------------------------------------------- +;; What the hourly heartbeat reports. +;; --------------------------------------------------------------------------- + +(defn busiest + "The heaviest single user of each limit in the window, whether or not it was + ever refused. A host that stops at ten signups an hour, every hour, never + trips anything and so never appears in the refusals at all -- this is the + only place it shows up." + [] + (->> @sightings + (reduce (fn [acc [k ts]] + (let [limit (if (vector? k) (first k) k)] + (update acc limit (fnil max 0) (count ts)))) + {}))) + +(defn- caps + "What each hourly limit allows, read off the policy table (plus the image probe)." + [] + (into {:image-probe-host image-probe-per-host-hourly} + (for [[route p] auth-guards + [scope n window] (:limits p) + :when (= :hour window)] + [(limit-name route scope) n]))) + +(defn busiest-summary + "A line naming any limit whose heaviest user is at least at `floor` of it -- + the quiet version of abuse, which sits just inside every number it is given." + [highs floor] + (let [caps (caps) + near (for [[what n] highs + :let [cap (get caps what)] + :when (and cap (>= n (* floor cap)))] + (str (name what) " " n "/" cap))] + (when (seq near) + (str "limits, busiest source: " (apply str (interpose ", " near)))))) + +(defn summary-job + "Heartbeat job: at most two lines an hour, and silent when there is nothing + to say. The first is what was turned away and how widely; the second is the + heaviest user of any limit that is sitting at 80% or more of it." + [_conn] + (let [highs (busiest)] + (when-let [line (refusal-summary (take-refusals!))] + (println line)) + (when-let [line (busiest-summary highs 0.8)] + (println line)))) + +;; One sign-in notice per account per day, and one taken-sign-up notice per address per day. An +;; attacker who can trigger the condition can trigger it on a loop, so without this the warning +;; would be a way to mail-bomb anyone whose username or address is known. +(def notice-cooldown-hours 24) + +(defn claim-sign-in-notice! [username] + (claim-once? [:sign-in-notice username] (hours notice-cooldown-hours))) + +(defn claim-taken-signup-notice! [email-key] + (claim-once? [:taken-signup-notice email-key] (hours notice-cooldown-hours))) diff --git a/test/clj/orcpub/registration_email_test.clj b/test/clj/orcpub/registration_email_test.clj index 2334237de..036ce783a 100644 --- a/test/clj/orcpub/registration_email_test.clj +++ b/test/clj/orcpub/registration_email_test.clj @@ -20,13 +20,14 @@ (:import [java.util Date UUID])) (use-fixtures :each - ;; registration-allowed? counts sign-ups per address in memory for the whole JVM, and these - ;; tests all register from a nil address; this file tests the email, not the throttle. + ;; Sign-ups are counted per connection in memory for the whole JVM, and these tests all register + ;; from a nil address; this file tests the email, not the throttle. (fn [f] - (with-redefs [security/registration-allowed? (constantly true) - email/configured? (constantly true)] + (reset! @#'security/sightings {}) + (with-redefs [email/configured? (constantly true)] (binding [errors/*error-prefix* "TEST_ERROR:"] - (f))))) + (f))) + (reset! @#'security/sightings {}))) (defn- fresh-conn "A connection to a new in-memory database with the full schema." @@ -144,7 +145,7 @@ (is (= 1 (count (accounts-with conn "newcomer@test.com"))) "no second account") (is (nil? (find-user (d/db conn) "third")) "and nothing created under the new username"))) -(deftest the-owner-is-mailed-once-a-day-with-nothing-to-replay +(deftest the-owner-is-mailed-once-with-nothing-to-replay (reset! @#'security/sightings {}) (let [conn (fresh-conn) _ (sign-up conn "newcomer" "newcomer@test.com") @@ -154,7 +155,7 @@ _ (sign-up conn "intruder2" "newcomer@test.com") notices (filter #(= :signup-attempt (:kind %)) (queued conn)) text (body (:message (first notices)))] - (is (= 1 (count notices)) "two attempts in a day, one notice") + (is (= 1 (count notices)) "two attempts close together, one notice") (is (= "newcomer@test.com" (:to (first notices)))) (is (str/includes? text "/login") "a way to sign in") (is (str/includes? text "send-password-reset") "and to reset the password") @@ -171,24 +172,23 @@ (let [conn (fresh-conn) _ (sign-up conn "newcomer" "newcomer@test.com") hashed (atom 0) - allowed (atom 0)] - (with-redefs [hashers/encrypt (fn [& _] (swap! hashed inc) "hash") - security/registration-allowed? (fn [_] (swap! allowed inc) true)] + spent #(count (get @@#'security/sightings [:register-per-host nil]))] + (reset! @#'security/sightings {}) + (with-redefs [hashers/encrypt (fn [& _] (swap! hashed inc) "hash")] (sign-up conn "fresh" "fresh@test.com") - (is (= [1 1] [@hashed @allowed]) "a new sign-up") + (is (= [1 1] [@hashed (spent)]) "a new sign-up") (sign-up conn "third" "newcomer@test.com") - (is (= [2 2] [@hashed @allowed]) + (is (= [2 2] [@hashed (spent)]) "a taken one is counted against the host and hashes the password too")) (testing "a failed challenge refuses a taken address exactly as a new one" (with-redefs [security/turnstile-enabled? (constantly true) - security/turnstile-verify (constantly :fail) - security/registration-allowed? (fn [_] (swap! allowed inc) true)] - (let [before @allowed + security/turnstile-verify (constantly :fail)] + (let [before (spent) new-resp (sign-up conn "fresh2" "fresh2@test.com") taken-resp (sign-up conn "third" "newcomer@test.com")] (is (= 400 (:status taken-resp))) (is (= new-resp taken-resp)) - (is (= before @allowed) "and spends no allowance")))))) + (is (= before (spent)) "and spends no allowance")))))) (deftest the-address-check-route-is-gone (is (not-any? #(= "/check-email" (:path %)) routes/routes)) diff --git a/test/clj/orcpub/registration_no_email_test.clj b/test/clj/orcpub/registration_no_email_test.clj index d4c9025d1..34a08803b 100644 --- a/test/clj/orcpub/registration_no_email_test.clj +++ b/test/clj/orcpub/registration_no_email_test.clj @@ -28,12 +28,13 @@ (:import [java.util UUID])) (use-fixtures :each - ;; registration-allowed? counts sign-ups per address in memory for the whole JVM, and these - ;; tests all register from a nil address; this file tests mail-less registration, not the throttle. + ;; Sign-ups are counted per connection in memory for the whole JVM, and these tests all register + ;; from a nil address; this file tests mail-less registration, not the throttle. (fn [f] - (with-redefs [security/registration-allowed? (constantly true)] - (binding [errors/*error-prefix* "TEST_ERROR:"] - (f))))) + (reset! @#'security/sightings {}) + (binding [errors/*error-prefix* "TEST_ERROR:"] + (f)) + (reset! @#'security/sightings {}))) (defn- fresh-conn [] (let [uri (str "datomic:mem:rne-" (UUID/randomUUID))] diff --git a/test/clj/orcpub/routes_test.clj b/test/clj/orcpub/routes_test.clj index 58a692dce..373c4c599 100644 --- a/test/clj/orcpub/routes_test.clj +++ b/test/clj/orcpub/routes_test.clj @@ -397,189 +397,46 @@ (is (true? (:send-updates? (body))))))))) -(deftest a-sprayed-address-is-refused-before-the-credentials - ;; :db is nil deliberately. lookup-user would throw on it, so these only pass - ;; if the address is judged before any credential work is attempted -- which - ;; is the point of the check: stuffing ends on the account it guesses RIGHT, - ;; and a check that runs only after a failed lookup never sees that attempt. - (let [request {:json-params {:username "kaylee" :password "whatever"} - :db nil - :remote-addr "1.2.3.4"}] - (testing "an address that sprayed five accounts is turned away" - (with-redefs [security/multiple-account-access? (constantly true)] - (let [{:keys [status body]} (auth/login-response request)] - (is (= 401 status)) - (is (= errors/too-many-attempts (:error body)))))) - (testing "an ordinary address still reaches the credential check" - (with-redefs [security/multiple-account-access? (constantly false)] - (is (thrown? Exception (auth/login-response request))))) - (testing "a blank field is still answered before the address is consulted" - (with-redefs [security/multiple-account-access? - (fn [_] (throw (AssertionError. "consulted too early")))] - (is (= errors/username-required - (-> (auth/login-response (assoc-in request [:json-params :username] "")) - :body :error))))))) - - -(deftest password-reset-says-the-same-thing-about-every-address - ;; The endpoint used to answer 400 {:error :no-account} for an address with no - ;; account, which turned it into a membership test anyone could run. - (let [sent (atom []) - request {:query-params {:email "someone@example.com"} :db nil :conn nil}] - (with-redefs [auth/do-send-password-reset - (fn [id email _ _] (swap! sent conj [id email]) {:status 200})] - (testing "an address with no account" - (with-redefs [auth/user-for-email (constantly nil)] - (is (= {:status 200} (auth/send-password-reset request))) - (is (empty? @sent) "no mail for an address we do not know"))) - (testing "an address with an account gets the identical answer" - (with-redefs [auth/user-for-email (constantly {:db/id 17})] - (is (= {:status 200} (auth/send-password-reset request))) - (is (= [[17 "someone@example.com"]] @sent))))) - (testing "a send that fails does not mark the address as registered" - (with-redefs [auth/user-for-email (constantly {:db/id 17}) - auth/do-send-password-reset - (fn [& _] (throw (ex-info "smtp is down" {})))] - (is (= {:status 200} (auth/send-password-reset request))))))) - - -(defn- clear-limits! [] - (reset! @#'security/sightings {})) - -(deftest resend-verification-is-limited-per-address-and-answers-the-same - (let [sent (atom 0) - resend (fn [email ip] - (auth/re-verify {:query-params {:email email} :db nil :conn nil - :remote-addr ip}))] - (clear-limits!) - (with-redefs [auth/user-for-email (constantly {:db/id 17}) - auth/do-verification (fn [& _] (swap! sent inc) {:status 200})] - (testing "within the per-address limit, mail goes out" - (dotimes [_ 3] - (is (= {:status 200} (resend "someone@example.com" "1.2.3.4")))) - (is (= 3 @sent))) - (testing "the fourth in the hour sends nothing and answers the same" - (is (= {:status 200} (resend "someone@example.com" "1.2.3.4"))) - (is (= 3 @sent)))) - (clear-limits!))) - -(deftest resend-verification-is-limited-per-host-and-answers-the-same - (let [sent (atom 0) - resend (fn [n] (auth/re-verify {:query-params {:email (str "user" n "@example.com")} - :db nil :conn nil :remote-addr "5.6.7.8"}))] - (clear-limits!) - (with-redefs [auth/user-for-email (constantly {:db/id 17}) - auth/do-verification (fn [& _] (swap! sent inc) {:status 200})] - (testing "ten different addresses from one host get mail" - (dotimes [n 10] - (is (= {:status 200} (resend n)))) - (is (= 10 @sent))) - (testing "the eleventh sends nothing and answers the same" - (is (= {:status 200} (resend 10))) - (is (= 10 @sent)))) - (clear-limits!))) - -(deftest password-reset-is-limited-per-address-and-answers-the-same - (let [sent (atom 0) - reset (fn [email ip] - (auth/send-password-reset {:query-params {:email email} :db nil :conn nil - :remote-addr ip}))] - (clear-limits!) - (with-redefs [auth/user-for-email (constantly {:db/id 17}) - auth/do-send-password-reset (fn [& _] (swap! sent inc) {:status 200})] - (let [first-response (reset "someone@example.com" "1.2.3.4")] - (testing "within the per-address limit, mail goes out" - (dotimes [_ 2] - (is (= first-response (reset "someone@example.com" "1.2.3.4")))) - (is (= 3 @sent))) - (testing "the fourth in the hour sends nothing and answers the same" - (is (= first-response (reset "someone@example.com" "1.2.3.4"))) - (is (= 3 @sent))))) - (clear-limits!))) - -(deftest password-reset-is-limited-per-host-and-answers-the-same - (let [sent (atom 0) - reset (fn [n] (auth/send-password-reset {:query-params {:email (str "user" n "@example.com")} - :db nil :conn nil :remote-addr "5.6.7.8"}))] - (clear-limits!) - (with-redefs [auth/user-for-email (constantly {:db/id 17}) - auth/do-send-password-reset (fn [& _] (swap! sent inc) {:status 200})] - (let [first-response (reset 0)] - (testing "ten different addresses from one host get mail" - (dotimes [n 9] - (is (= first-response (reset (inc n))))) - (is (= 10 @sent))) - (testing "the eleventh sends nothing and answers the same" - (is (= first-response (reset 10))) - (is (= 10 @sent))))) - (clear-limits!))) - -(deftest password-reset-for-an-unknown-address-sends-nothing-and-answers-the-same - (let [sent (atom 0) - reset (fn [email] (auth/send-password-reset {:query-params {:email email} :db nil :conn nil - :remote-addr "9.9.9.9"}))] - (clear-limits!) - (with-redefs [auth/do-send-password-reset (fn [& _] (swap! sent inc) {:status 200})] - (let [known (with-redefs [auth/user-for-email (constantly {:db/id 17})] - (reset "known@example.com")) - sent-for-known @sent - unknown (with-redefs [auth/user-for-email (constantly {})] - (reset "nobody@example.com"))] - (is (= 1 sent-for-known)) - (is (= known unknown)) - (is (= 1 @sent)))) - (clear-limits!))) - +(deftest a-failed-send-does-not-mark-a-reset-address-as-registered + ;; Swallowed on purpose: only a real account can fail to be emailed, so an error response would + ;; reopen the membership test the uniform 200 closed. (Everything else about the reset form's + ;; limits and answers is read off security/auth-guards in security_test.clj.) + (with-redefs [auth/user-for-email (constantly {:db/id 17}) + auth/do-send-password-reset (fn [& _] (throw (ex-info "smtp is down" {})))] + (is (= {:status 200} (auth/send-password-reset {:query-params {:email "someone@example.com"} + :db nil :conn nil :remote-addr "9.9.9.9"}))))) + +(defn- fail-from [ip typed request] + (auth/bad-credentials-response nil typed ip request)) (deftest the-owner-is-told-when-one-account-is-tried-from-several-places - (let [posted (promise) + (reset! @#'security/sightings {}) + (let [posted (atom []) request {:scheme :https :headers {"host" "example.test"}} - call #(auth/bad-credentials-response nil "kaylee" "1.2.3.4" request)] - (with-redefs [auth/find-user-by-username-or-email - (constantly {:db/id 17 - :orcpub.user/email "kaylee@serenity.example" :orcpub.user/email-key "kaylee@serenity.example" - :orcpub.user/first-and-last-name "Kaylee"}) - outbox/enqueue! - (fn [_conn _kind message] (deliver posted message))] - - (testing "the response says bad credentials either way, as it did before" - (with-redefs [security/multiple-ip-attempts-to-same-account? (constantly true) - security/claim-sign-in-notice! (constantly true)] - (is (= errors/bad-credentials (-> (call) :body :error))))) - - (testing "and the notice reaches the address on the account" - (let [message (deref posted 2000 :never-sent)] - (is (= "kaylee@serenity.example" (:to message))) - (is (re-find #"https://example\.test" (pr-str (:body message))) "linking to this site"))))) - - (testing "a spread of addresses that never happened sends nothing" - (let [posted (atom [])] - (with-redefs [auth/find-user-by-username-or-email (constantly {:db/id 17}) - security/multiple-ip-attempts-to-same-account? (constantly false) - outbox/enqueue! (fn [& a] (swap! posted conj a))] - (auth/bad-credentials-response nil "kaylee" "1.2.3.4" {}) - (Thread/sleep 60) - (is (empty? @posted))))) - - (testing "an address with no account here is told nothing at all" - (let [posted (atom [])] - (with-redefs [auth/find-user-by-username-or-email (constantly nil) - security/multiple-ip-attempts-to-same-account? (constantly true) - outbox/enqueue! (fn [& a] (swap! posted conj a))] - (auth/bad-credentials-response nil "nobody" "1.2.3.4" {}) - (Thread/sleep 60) - (is (empty? @posted)))))) - -(deftest a-sign-in-notice-is-claimed-once-per-window - ;; Without this an attacker who can trigger the condition can trigger it on a - ;; loop, turning the warning into a way to mail-bomb any account by username. - (let [who (str "claim-test-" (System/nanoTime))] - (is (true? (security/claim-sign-in-notice! who))) - (is (false? (security/claim-sign-in-notice! who))) - (is (false? (security/claim-sign-in-notice! who))) - (is (true? (security/claim-sign-in-notice! (str who "-other"))) - "a different account has its own window"))) - + account {:db/id 17 :orcpub.user/email "kaylee@serenity.example" + :orcpub.user/first-and-last-name "Kaylee"}] + (with-redefs [outbox/enqueue! (fn [_conn _kind message] (swap! posted conj message))] + (testing "a spread of addresses that never happened sends nothing" + (with-redefs [auth/find-user-by-username-or-email (constantly account)] + (fail-from "1.1.1.1" "kaylee" request) + (fail-from "2.2.2.2" "kaylee" request) + (Thread/sleep 60) + (is (empty? @posted)))) + (testing "an address with no account here is told nothing at all" + (with-redefs [auth/find-user-by-username-or-email (constantly nil)] + (dotimes [i 3] (fail-from (str "3.3.3." i) "nobody" request)) + (Thread/sleep 60) + (is (empty? @posted)))) + (testing "three places at once reach the address on the account; the answer is bad credentials either way" + (with-redefs [auth/find-user-by-username-or-email (constantly account)] + (is (= errors/bad-credentials (-> (fail-from "3.3.3.3" "kaylee" request) :body :error))) + (let [message (do (Thread/sleep 100) (first @posted))] + (is (= "kaylee@serenity.example" (:to message))) + (is (re-find #"https://example\.test" (pr-str (:body message))) "linking to this site") + ) + (fail-from "4.4.4.4" "kaylee" request) + (Thread/sleep 100) + (is (= 1 (count @posted)) "a further attempt inside the gap sends nothing more")))))) (deftest a-user-agent-is-described-the-way-a-person-would ;; Order matters in describe-browser: Edge and Opera both claim to be Chrome, diff --git a/test/clj/orcpub/security_audit_test.clj b/test/clj/orcpub/security_audit_test.clj index 81208f9ca..8d0cde8b7 100644 --- a/test/clj/orcpub/security_audit_test.clj +++ b/test/clj/orcpub/security_audit_test.clj @@ -14,10 +14,8 @@ (use-fixtures :each (fn [f] - (with-redefs [security/registration-allowed? (constantly true) - security/multiple-account-access? (constantly false) - security/too-many-attempts-for-username? (constantly false) - security/multiple-ip-attempts-to-same-account? (constantly false) + (with-redefs [security/guard (constantly nil) + security/record! (constantly nil) email/configured? (constantly true)] (f)))) diff --git a/test/clj/orcpub/security_test.clj b/test/clj/orcpub/security_test.clj index 8f2c87782..b516eb841 100644 --- a/test/clj/orcpub/security_test.clj +++ b/test/clj/orcpub/security_test.clj @@ -9,231 +9,22 @@ [orcpub.pwned :as pwned] [orcpub.routes :as routes] [orcpub.routes.auth :as auth] - [orcpub.time :as time :refer [seconds minutes hours millis ago now]] + [orcpub.time :as time] [orcpub.security :as s] [orcpub.db.schema :as schema] [clojure.set :as sets]) (:import [java.util UUID])) -;; Convenience wrappers for tests - these take n and return an Instant n units ago -(defn seconds-ago [n] (-> n seconds ago)) -(defn minutes-ago [n] (-> n minutes ago)) -(defn hours-ago [n] (-> n hours ago)) -(defn millis-ago [n] (-> n millis ago)) - -(defn attempts-set [attempts] - (into - (sorted-set-by s/compare-dates) - attempts)) - -(defn attempts-for-dates [dates] - (into - (sorted-set-by s/compare-dates) - (map - (fn [date] - {:date date}) - dates))) - -(deftest test-compare-dates - (is (= 1 (s/compare-dates - {:date (seconds-ago 10)} - {:date (seconds-ago 11)}))) - (is (= 1 (s/compare-dates - {:date (seconds-ago 10)} - {:date (minutes-ago 11)}))) - (is (= -1 (s/compare-dates - {:date (seconds-ago 10)} - {:date (seconds-ago 9)}))) - (is (= -1 (s/compare-dates - {:date (minutes-ago 10)} - {:date (seconds-ago 9)})))) - -(deftest test-too-many-attempts-for-username? - (let [attempts {"larry" (attempts-for-dates (map seconds-ago (range 5))) - "larry-2" (attempts-for-dates (map seconds-ago (range 6))) - "redorc" (attempts-for-dates (map seconds-ago (range 4))) - "redorc-2" (sets/union - (attempts-for-dates (map seconds-ago (range 1 5))) - (attempts-for-dates (map hours-ago (range 1 6))))}] - (is (s/too-many-attempts-for-username-aux "larry" attempts)) - (is (s/too-many-attempts-for-username-aux "larry-2" attempts)) - (is (not (s/too-many-attempts-for-username-aux "redorc" attempts))) - (is (= 5 (-> "redorc-2" attempts (subseq < {:date (minutes-ago 1)}) count))) - (is (= 4 (-> "redorc-2" attempts (subseq > {:date (minutes-ago 1)}) count))) - (is (not (s/too-many-attempts-for-username-aux "redorc-2" attempts))) - (is (not (s/too-many-attempts-for-username-aux "larry-3" attempts))))) - -(deftest test-multiple-account-access? - (let [attempts {"1.2.3.4" (attempts-set - (map - (fn [i] - {:date (seconds-ago i) - :user (str "user-" i)}) - (range 5))) - "1.2.3.5" (attempts-set - (map - (fn [i] - {:date (seconds-ago i) - :user (str "user-" i)}) - (range 6))) - "1.2.3.6" (attempts-set - (map - (fn [i] - {:date (seconds-ago i) - :user (str "user-" i)}) - (range 4)))} - attempts-2 (update - attempts - "1.2.3.4" - sets/union - (attempts-set - (map - (fn [i] - {:date (hours-ago i) - :user (str "user-" i)}) - (range 1 10))))] - (is (s/multiple-account-access-aux "1.2.3.4" attempts)) - (is (s/multiple-account-access-aux "1.2.3.5" attempts)) - (is (not (s/multiple-account-access-aux "1.2.3.6" attempts))) - (is (not (s/multiple-account-access-aux "1.2.3.6" attempts-2))) - (is (not (s/multiple-account-access-aux "1.2.3.8" attempts-2))))) - -;; Was disabled with "TODO: Fix / remove test" because the function it covers -;; never called its own aux -- it returned the attempts atom, which is truthy -;; even when empty, so every assertion expecting false failed. The function is -;; fixed, so the test is live again. -(deftest test-multiple-ip-attempts-to-same-account? - (let [attempts {"user-1" (attempts-set - (map - (fn [i] - {:date (millis-ago i) - :ip (str i)}) - (range 3))) - "user-2" (attempts-set - (map - (fn [i] - {:date (millis-ago i) - :ip (str i)}) - (range 4))) - "user-3" (attempts-set - (map - (fn [i] - {:date (millis-ago i) - :ip (str i)}) - (range 2)))}] - (is (s/multiple-ip-attempts-to-same-account-aux - "user-1" - attempts)) - (is (s/multiple-ip-attempts-to-same-account-aux - "user-1" - (update - attempts - "user-1" - (fn [as] - (sets/union - as - (attempts-set - (map - (fn [s] - (assoc s :ip "0")) - as))))))) - (is (not - (s/multiple-ip-attempts-to-same-account-aux - "user-3" - (update - attempts - "user-3" - (fn [as] - (sets/union - as - (attempts-set - (map - (fn [s] - (assoc s :ip "0")) - as)))))))) - (is (s/multiple-ip-attempts-to-same-account-aux - "user-2" - attempts)) - (is (not (s/multiple-ip-attempts-to-same-account-aux - "user-3" - attempts))) - (is (not (s/multiple-ip-attempts-to-same-account-aux - "user-4" - attempts))))) - -(deftest test-add-and-remove-old - (let [attempts {"user-1" (attempts-set - (map - (fn [i] - {:ip (str i) - :user "user-1" - :date (minutes-ago i)}) - (range 1 10))) - "user-2" (attempts-set - (map - (fn [i] - {:ip (str i) - :user "user-2" - :date (minutes-ago (+ i 10))}) - (range 1 10))) - "user-3" (attempts-set - (map - (fn [i] - {:ip (str i) - :user "user-3" - :date (minutes-ago i)}) - (range 1 20)))} - result (s/add-and-remove-old - "user-1" - {:ip "x" - :user "user-1" - :date (now)} - attempts - (minutes-ago 10))] - (is (-> "user-2" result nil?)) - (is (= 10 (-> "user-1" result count))) - (is (= 9 (-> "user-3" result count))))) - -(deftest multiple-ip-attempts-answers-no-for-an-untouched-account - ;; The precise shape of the bug: the function returned the attempts map - ;; instead of calling its aux, and an empty map is truthy in Clojure, so it - ;; answered "yes" for an account with no attempts at all. - (is (not (s/multiple-ip-attempts-to-same-account-aux "nobody" {}))) - (is (not (s/multiple-ip-attempts-to-same-account? "nobody")) - "and through the public predicate, which is what callers use")) - -(deftest attempts-sharing-an-instant-collapse - ;; A property of the production structure, not a test artifact: attempts live - ;; in a sorted-set-by compare-dates, which orders on :date alone, so two - ;; attempts recorded in the same instant are treated as one element and one - ;; is dropped. Worth knowing before trusting these counts as exact. - (let [instant (now) - two-ips (into (sorted-set-by s/compare-dates) - [{:user "u" :ip "1.1.1.1" :date instant} - {:user "u" :ip "2.2.2.2" :date instant}])] - (is (= 1 (count two-ips)) - "two attempts, one instant, one surviving entry"))) - - (deftest refusals-are-counted-so-the-numbers-can-be-tuned (s/take-refusals!) (is (nil? (s/refusal-summary {})) "a quiet hour says nothing") ;; Eleven signups from one host inside the hour: the first ten pass. - (dotimes [_ 11] (s/registration-allowed? "9.9.9.9")) + (dotimes [_ 11] (s/guard :orcpub.routes.auth/register {:ip "9.9.9.9"})) (let [counts (s/take-refusals!)] - (is (= 1 (:n (:register counts)))) - (is (= "limits: register 1" (s/refusal-summary counts)))) + (is (= 1 (:n (:register-per-host counts)))) + (is (= "limits: register-per-host 1" (s/refusal-summary counts)))) (is (= {} (s/take-refusals!)) "taking them resets, so each hour is its own period")) -(deftest a-limit-turns-away-only-what-is-past-it - (s/take-refusals!) - (let [host (str "10.0.0." (rand-int 250))] - (is (every? true? (repeatedly 10 #(s/registration-allowed? host)))) - (is (false? (s/registration-allowed? host))) - (is (true? (s/registration-allowed? (str host ".other"))) - "a different host has its own allowance"))) - - (deftest one-host-hammering-reads-differently-from-a-spread ;; The count alone cannot tell these apart, and they are not the same event: ;; twenty refusals from twenty addresses is a pool working through a list. @@ -248,17 +39,19 @@ ;; The case refusals cannot see at all: a host taking nine of its ten signups ;; an hour, every hour, trips nothing and is never counted. busiest-summary ;; is pure, so it is tested on its own rather than through the shared atom. - (is (= "limits, busiest source: register 9/10" (s/busiest-summary {:register 9} 0.8))) - (is (= "limits, busiest source: register 10/10" (s/busiest-summary {:register 10} 0.8))) - (is (nil? (s/busiest-summary {:register 2} 0.8)) "an ordinary hour says nothing") - (is (nil? (s/busiest-summary {:unknown-limit 99} 0.8)) "a limit with no cap is not guessed at")) + (is (= "limits, busiest source: register-per-host 9/10" (s/busiest-summary {:register-per-host 9} 0.8))) + (is (nil? (s/busiest-summary {:register-per-host 2} 0.8)) "an ordinary hour says nothing") + (is (nil? (s/busiest-summary {:unknown-limit 99} 0.8)) "a limit with no cap is not guessed at") + (testing "every hourly limit in the table has its cap, derived from it" + (doseq [[route p] s/auth-guards, [scope n window] (:limits p) :when (= :hour window)] + (is (str/ends-with? (s/busiest-summary {(s/limit-name route scope) n} 0.8) + (str (name (s/limit-name route scope)) " " n "/" n)))))) (deftest busiest-reads-the-live-window (let [host (str "7.7.7." (rand-int 250))] - (dotimes [_ 9] (s/registration-allowed? host)) + (dotimes [_ 9] (s/guard :orcpub.routes.auth/register {:ip host})) ;; Other tests share this atom, so the floor is what matters, not the value. - (is (>= (:register (s/busiest)) 9)))) - + (is (>= (:register-per-host (s/busiest)) 9)))) (deftest a-password-change-withdraws-the-tokens-that-came-before-it (s/restore-password-changes! {}) @@ -308,25 +101,16 @@ (is (false? (s/token-withdrawn? "wash" 6000)) "and expired entries still drop out") (s/restore-password-changes! {})) -;; ---- Cloudflare Turnstile on the sign-up form (moved from turnstile_test.clj) ---- -;; Off unless both keys are set, fails open when Cloudflare is unreachable, refuses only on an -;; explicit failure, and a refused attempt does not use up the host's signup allowance. -;; No test reaches the network. - (use-fixtures :each (fn [f] (reset! @#'s/sightings {}) (reset! @#'s/login-challenges {}) - (reset! s/failed-login-attempts-by-username {}) - (reset! s/failed-login-attempts-by-ip {}) (with-redefs [email/configured? (constantly true) pwned/check (constantly 0)] (binding [errors/*error-prefix* "TEST_ERROR:"] (f))) (reset! @#'s/sightings {}) - (reset! @#'s/login-challenges {}) - (reset! s/failed-login-attempts-by-username {}) - (reset! s/failed-login-attempts-by-ip {}))) + (reset! @#'s/login-challenges {}))) (def ^:private secret "s3cr3t-turnstile-value-9f2c") @@ -337,68 +121,12 @@ @(d/transact conn schema/all-schemas) conn))) -(defn- request [conn token] - {:conn conn :db (d/db conn) :scheme :https :headers {"host" "example.test"} - :remote-addr "7.7.7.7" - :json-params (cond-> {:username "newcomer" :email "newcomer@test.com" - :verify-email "newcomer@test.com" - :password "hunter2hunter2" :send-updates? false} - token (assoc :turnstile-token token))}) - -(defn- user-exists? [conn] - (some? (d/q '[:find ?e . :where [?e :orcpub.user/username "newcomer"]] (d/db conn)))) - -(defn- host-count [] - (count (get @@#'s/sightings [:register "7.7.7.7"]))) - - -(deftest disabled-register-works-and-never-calls-cloudflare - (let [conn (fresh-conn) calls (atom 0)] - (with-redefs [s/turnstile-enabled? (constantly false) - s/turnstile-verify (fn [& _] (swap! calls inc) :fail) - s/post-siteverify (fn [& _] (swap! calls inc) (throw (ex-info "no" {})))] - (is (= 200 (:status (auth/register (request conn nil))))) - (is (user-exists? conn)) - (is (zero? @calls) "siteverify is never called")))) - -(deftest enabled-and-passing-creates-the-account - (let [conn (fresh-conn)] - (with-redefs [s/turnstile-enabled? (constantly true) - s/post-siteverify (fn [& _] {:success true})] - (is (= 200 (:status (auth/register (request conn "good-token"))))) - (is (user-exists? conn))))) - -(deftest enabled-and-failing-refuses-without-using-the-host-allowance - (let [conn (fresh-conn)] - (with-redefs [s/turnstile-enabled? (constantly true) - s/post-siteverify (fn [& _] {:success false})] - (let [resp (auth/register (request conn "bad-token"))] - (is (= 400 (:status resp))) - (is (= 1 (count (get-in resp [:body :general]))) "a :general error") - (is (str/includes? (first (get-in resp [:body :general])) "not a bot")) - (is (= [:general] (keys (:body resp))) "no field key") - (is (not (user-exists? conn)) "nothing created") - (is (zero? (host-count)) "the host's allowance is not consumed"))))) - -(deftest enabled-and-unreachable-fails-open - (let [conn (fresh-conn)] - (with-redefs [s/turnstile-enabled? (constantly true) - s/post-siteverify (fn [& _] (throw (java.net.SocketTimeoutException. "slow")))] - (is (= 200 (:status (auth/register (request conn "any-token"))))) - (is (user-exists? conn))))) - (deftest a-blank-token-fails-without-calling-cloudflare (let [calls (atom 0)] (with-redefs [s/post-siteverify (fn [& _] (swap! calls inc) {:success true})] (doseq [t [nil "" " "]] (is (= :fail (s/turnstile-verify t "1.2.3.4")))) - (is (zero? @calls) "no HTTP call")) - (testing "and through register, while enabled" - (let [conn (fresh-conn)] - (with-redefs [s/turnstile-enabled? (constantly true) - s/post-siteverify (fn [& _] (swap! calls inc) {:success true})] - (is (= 400 (:status (auth/register (request conn nil))))) - (is (zero? @calls))))))) + (is (zero? @calls) "no HTTP call")))) (deftest verify-maps-cloudflare-answers (with-redefs [s/post-siteverify (fn [& _] {:success true})] @@ -458,12 +186,127 @@ "auth routes with no entry in security/auth-guards") (is (= #{} (sets/difference listed actual)) "auth-guards entries that name no route") - (doseq [[route guard] s/auth-guards] - (is (or (and (set? guard) (seq guard)) - (and (map? guard) (string? (:none guard)) (seq (:none guard)))) - (str route " needs guards or a reason for having none"))))) + (doseq [[route p] s/auth-guards] + (testing (str route) + (if (:none p) + (is (string? (:none p)) "a reason for having none") + (do (is (seq (:limits p)) "limits") + (is (every? (fn [[scope n window]] (and (#{:per-address :per-host :per-name :names-per-host} scope) + (pos? n) (#{:minute :hour} window))) + (:limits p))) + (is (#{:always :after-failure nil} (:turnstile p))) + (is (#{:uniform :message :error} (:answer p))) + (is (or (not= :message (:answer p)) (seq (:message p))) "a message to show"))))))) + +;; The table-driven tests read the table, so deleting a row would also delete its tests. This pins +;; what must stay in it: the forms that cost something to serve, and the limits each one has. +(deftest the-forms-that-cost-something-stay-guarded + (doseq [[route [challenge scopes]] + {:orcpub.routes.auth/login [:after-failure #{:names-per-host :per-name}] + :orcpub.routes.auth/register [:always #{:per-host}] + :orcpub.routes.auth/re-verify [:always #{:per-address :per-host}] + :orcpub.routes.auth/send-password-reset [:always #{:per-address :per-host}]} + :let [p (s/policy route)]] + (is (= challenge (:turnstile p)) (str route " keeps its challenge")) + (is (sets/subset? scopes (set (map first (:limits p)))) (str route " keeps its limits")))) + +;; ---- the table-driven tests: one body for every form, read off s/auth-guards ---- +;; A new row in the table is tested the moment it is added; a route with a policy and no driver +;; below fails here, so nothing is guarded without being tested. + +(def ^:private worked + "Counts the real work the stubbed handlers were asked to do (a mail, a verification, an account)." + (atom 0)) + +(defn- reg-ctx-request [conn n ip token] + {:conn conn :db (d/db conn) :scheme :https :headers {"host" "example.test"} :remote-addr ip + :json-params (cond-> {:username (str "user" n) :email (str "user" n "@test.com") + :verify-email (str "user" n "@test.com") + :password "hunter2hunter2" :send-updates? false} + token (assoc :turnstile-token token))}) -;; ---- Turnstile on password reset, resend verification and sign-in after a failure ---- +(defn- login [typed token ip] + (auth/login-response {:json-params (cond-> {:username typed :password "pw"} + token (assoc :turnstile-token token)) + :db nil :conn nil :remote-addr ip :headers {}})) + +(def ^:private drivers + "route -> (fn [] call), where (call {:address :ip :token :typed}) runs the real handler." + (letfn [(by-query [handler] + (fn [] (fn [{:keys [address ip token]}] + (handler {:query-params (cond-> {:email address} token (assoc :turnstile-token token)) + :db nil :conn nil :remote-addr ip}))))] + {:orcpub.routes.auth/send-password-reset (by-query auth/send-password-reset) + :orcpub.routes.auth/re-verify (by-query auth/re-verify) + :orcpub.routes.auth/register (fn [] (let [conn (fresh-conn) n (atom 0)] + (fn [{:keys [ip token]}] + (auth/register (reg-ctx-request conn (swap! n inc) ip token))))) + :orcpub.routes.auth/login (fn [] (fn [{:keys [typed ip token]}] (login typed token ip)))})) + +(defmacro ^:private in-world + "Runs `body` with Turnstile off, every address known and unverified, sends counted in `worked`, and + every sign-in a failure." + [& body] + `(with-redefs [s/turnstile-enabled? (constantly false) + auth/user-for-email (constantly {:db/id 17}) + auth/do-send-password-reset (fn [& _#] (swap! worked inc) {:status 200}) + auth/do-verification (fn [& _#] (swap! worked inc) {:status 200}) + auth/lookup-user (constantly {}) + auth/find-user-by-username-or-email (constantly nil)] + (reset! worked 0) + ~@body)) + +(defn- guarded-routes [pred] + (for [[route p] s/auth-guards :when (and (not (:none p)) (pred p))] + [route p ((or (drivers route) (throw (ex-info (str "no driver for guarded route " route) {}))))])) + +(defn- ctx-for + "A request that varies in every way but `scope`'s subject, so only that limit can fill up." + [scope i] + {:address (if (= :per-address scope) "same@example.com" (str "u" i "@example.com")) + :ip (if (#{:per-host :names-per-host} scope) "5.5.5.5" (str "10.0." i ".1")) + :typed (if (= :per-name scope) "Same-Name" (str "name" i))}) + +(defn- refused? [p resp before] + (case (:answer p) + :uniform (= before @worked) + :message (= [(:message p)] (get-in resp [:body :general])) + :error (= errors/too-many-attempts (get-in resp [:body :error])))) + +(deftest every-limit-refuses-when-its-number-is-reached + (doseq [[route p call] (guarded-routes :limits) + [scope n _ when-failing] (:limits p)] + (testing (str route " " scope " " n) + (reset! @#'s/sightings {}) + (in-world + (let [outcomes (vec (for [i (range 1 (+ n 2))] + (let [before @worked, resp (call (ctx-for scope i))] + (refused? p resp before)))) + first-refused (inc (count (take-while false? outcomes)))] + ;; a limit refuses the request after the n-th that counted; one that only refuses a + ;; FAILING attempt refuses the n-th itself + (is (= (if when-failing n (inc n)) first-refused)) + (is (every? true? (drop (dec first-refused) outcomes)) "and stays refused") + (is (= (if (= :error (:answer p)) 0 n) @worked) + "only the requests inside the limit did any work")))))) + +(deftest a-uniform-answer-does-not-depend-on-the-address + (doseq [[route p call] (guarded-routes #(= :uniform (:answer %)))] + (testing (str route) + (let [attempts (+ 2 (apply max (map second (:limits p)))) + run (fn [lookup] + (reset! @#'s/sightings {}) + (in-world + (with-redefs [auth/user-for-email (constantly lookup)] + (let [resps (vec (for [_ (range attempts)] (call {:address "a@example.com" :ip "6.6.6.6"})))] + [(set resps) @worked])))) + [known-responses known-work] (run {:db/id 17}) + [unknown-responses unknown-work] (run {})] + (is (= known-responses unknown-responses) "one answer, limited or not, known or not") + (is (= 1 (count known-responses))) + (is (pos? known-work)) + (is (< known-work attempts) "and the known address was in fact limited") + (is (zero? unknown-work) "nothing is done for an address with no account"))))) (defn- verify-calls "Runs `f` with Turnstile on and siteverify answering `answer` (a map, or :throw); returns @@ -480,61 +323,48 @@ (defn- lookups-fail-the-test [& _] (throw (AssertionError. "looked the address up before the challenge"))) -(deftest reset-and-resend-check-the-challenge-before-anything-else - (doseq [[label handler route-name] - [["send-password-reset" auth/send-password-reset :orcpub.routes.auth/send-password-reset] - ["re-verify" auth/re-verify :orcpub.routes.auth/re-verify]]] - (let [call (fn [token] (handler {:query-params (cond-> {:email "someone@example.com"} - token (assoc :turnstile-token token)) - :db nil :conn nil :remote-addr "9.9.9.9"}))] - (testing (str label ": a failed challenge is told to retry, before any lookup or allowance") - (with-redefs [auth/user-for-email lookups-fail-the-test] - (let [[resp calls] (verify-calls {:success false} #(call "bad"))] - (is (= 400 (:status resp))) - (is (str/includes? (first (get-in resp [:body :general])) "not a bot")) - (is (= 1 calls)) - (is (empty? @@#'s/sightings) "no allowance was spent")) - (testing "a missing token is refused the same way, without calling Cloudflare" - (let [[resp calls] (verify-calls {:success true} #(call nil))] - (is (= 400 (:status resp))) - (is (zero? calls)))))) - (testing (str label ": the refusal is the same whether or not the address has an account") - (let [refused (fn [user] - (with-redefs [auth/user-for-email (constantly user)] - (first (verify-calls {:success false} #(call "bad")))))] - (is (= (refused {:db/id 5}) (refused {}))))) - (testing (str label ": a passing challenge proceeds to the usual work") - (let [looked-up (atom 0)] - (with-redefs [auth/user-for-email (fn [& _] (swap! looked-up inc) {})] - (let [[resp calls] (verify-calls {:success true} #(call "good"))] - (is (= {:status 200} resp)) - (is (= 1 calls)) - (is (= 1 @looked-up)))))) - (testing (str label ": an unreachable Cloudflare fails open") - (with-redefs [auth/user-for-email (constantly {})] - (is (= {:status 200} (first (verify-calls :throw #(call "any"))))))) - (testing (str label ": with Turnstile off nothing is checked") - (let [calls (atom 0)] - (with-redefs [s/turnstile-enabled? (constantly false) - s/post-siteverify (fn [& _] (swap! calls inc) {:success false}) - auth/user-for-email (constantly {})] - (is (= {:status 200} (call nil))) - (is (zero? @calls)))))))) - -(deftest the-resend-token-does-not-reach-the-mail - (let [seen (atom nil)] - (with-redefs [s/turnstile-enabled? (constantly true) - s/post-siteverify (fn [& _] {:success true}) - auth/user-for-email (constantly {:db/id 17}) - auth/do-verification (fn [_ params & _] (reset! seen params) {:status 200})] - (auth/re-verify {:query-params {:email "a@b.com" :turnstile-token "t"} - :db nil :conn nil :remote-addr "9.9.9.9"}) - (is (not (contains? @seen :turnstile-token)))))) - -(defn- login [typed token ip] - (auth/login-response {:json-params (cond-> {:username typed :password "pw"} - token (assoc :turnstile-token token)) - :db nil :conn nil :remote-addr ip :headers {}})) +(deftest the-challenge-is-checked-before-any-allowance-or-lookup + (doseq [[route p call] (guarded-routes #(= :always (:turnstile %)))] + (let [ctx (ctx-for :per-host 1)] + (testing (str route ": a failed token is told to retry, with nothing spent or looked up") + (reset! @#'s/sightings {}) + (in-world + (with-redefs [auth/user-for-email lookups-fail-the-test] + (let [[resp calls] (verify-calls {:success false} #(call (assoc ctx :token "bad")))] + (is (= 400 (:status resp))) + (is (str/includes? (first (get-in resp [:body :general])) "not a bot")) + (is (= [:general] (keys (:body resp))) "a :general error, no field key") + (is (= 1 calls)) + (is (empty? @@#'s/sightings) "no allowance was spent") + (is (zero? @worked)))))) + (testing (str route ": a missing token says the script is blocked, without calling Cloudflare") + (in-world + (with-redefs [auth/user-for-email lookups-fail-the-test] + (doseq [blank [nil "" " "]] + (let [[resp calls] (verify-calls {:success true} #(call (assoc ctx :token blank)))] + (is (= [errors/turnstile-blocked-message] (get-in resp [:body :general]))) + (is (zero? calls))))))) + (testing (str route ": a passing token goes on to the work") + (reset! @#'s/sightings {}) + (in-world + (let [[resp calls] (verify-calls {:success true} #(call (assoc ctx :token "good")))] + (is (= 200 (:status resp))) + (is (= 1 calls)) + (is (= 1 @worked))))) + (testing (str route ": an unreachable Cloudflare fails open") + (reset! @#'s/sightings {}) + (in-world + (let [[resp _] (verify-calls :throw #(call (assoc ctx :token "any")))] + (is (= 200 (:status resp))) + (is (= 1 @worked))))) + (testing (str route ": with Turnstile off nothing is checked") + (reset! @#'s/sightings {}) + (in-world + (let [calls (atom 0)] + (with-redefs [s/post-siteverify (fn [& _] (swap! calls inc) {:success false})] + (is (= 200 (:status (call ctx)))) + (is (zero? @calls)) + (is (= 1 @worked))))))))) (defmacro ^:private with-login-stubs "Sign-in with Turnstile on: `known` is the one typed name whose password is right." @@ -545,114 +375,89 @@ auth/create-login-response (fn [& _#] {:status 200 :body {:token "t"}})] ~@body)) -(deftest sign-in-needs-no-challenge-until-it-fails - (with-login-stubs "kaylee" - (let [[resp calls] (verify-calls {:success false} #(login "kaylee" nil "1.1.1.1"))] - (is (= 200 (:status resp))) - (is (zero? calls) "Cloudflare is not asked")))) - -(deftest a-failure-looks-the-same-for-an-unknown-name-and-a-wrong-password - (with-login-stubs "kaylee" - (let [unknown (login "nobody" nil "1.1.1.1") - ;; "kaylee" exists, but this lookup stub is told it is wrong - wrong (with-redefs [auth/lookup-user (fn [& _] {}) - auth/find-user-by-username-or-email (constantly {:db/id 1 :orcpub.user/username "kaylee"})] - (login "kaylee" nil "1.1.1.1"))] - (is (= 401 (:status unknown))) - (is (= errors/bad-credentials (-> unknown :body :error))) - (is (true? (-> unknown :body :challenge?))) - (is (= unknown wrong) "identical, including the flag")))) - -(deftest the-flag-is-absent-while-turnstile-is-off - (with-redefs [s/turnstile-enabled? (constantly false) - auth/lookup-user (constantly {}) - auth/find-user-by-username-or-email (constantly nil)] - (is (= {:status 401 :body {:error errors/bad-credentials}} (login "nobody" nil "1.1.1.1"))) - (is (= {:status 401 :body {:error errors/bad-credentials}} (login "nobody" nil "1.1.1.1")) - "and a second failure still asks for nothing"))) - -(deftest after-a-failure-the-next-attempt-needs-a-passing-token - (with-login-stubs "kaylee" - (login "kaylee-typo" nil "1.1.1.1") - (testing "no token: challenge required, and the credentials are not looked at" - (with-redefs [auth/lookup-user lookups-fail-the-test] - (let [[resp calls] (verify-calls {:success true} #(login "kaylee-typo" nil "1.1.1.1"))] - (is (= 401 (:status resp))) - (is (= errors/challenge-required (-> resp :body :error))) - (is (true? (-> resp :body :challenge?))) - (is (zero? calls))))) - (testing "a failing token is the same" - (is (= errors/challenge-required - (-> (first (verify-calls {:success false} #(login "kaylee-typo" "bad" "1.1.1.1"))) :body :error)))) - (testing "a passing token reaches the credentials" - (is (= errors/bad-credentials - (-> (first (verify-calls {:success true} #(login "kaylee-typo" "good" "1.1.1.1"))) :body :error)))) - (testing "an unreachable Cloudflare fails open" - (is (= errors/bad-credentials - (-> (first (verify-calls :throw #(login "kaylee-typo" "any" "1.1.1.1"))) :body :error)))))) - -(deftest a-successful-sign-in-clears-the-mark - (with-login-stubs "kaylee" - (login "nobody" nil "1.1.1.1") - (login "kaylee" nil "1.1.1.1") - (is (true? (s/login-challenge-required? "nobody" "1.1.1.1")) "a different name keeps its own mark") - (login "nobody" nil "2.2.2.2") - (s/mark-login-challenge! "kaylee" "1.1.1.1") - (is (= 200 (:status (first (verify-calls {:success true} #(login "kaylee" "good" "1.1.1.1")))))) - (is (false? (s/login-challenge-required? "kaylee" "1.1.1.1")) "the success cleared it") - (is (= 200 (:status (login "kaylee" nil "1.1.1.1"))) "so the next one needs no token"))) - -(deftest the-mark-is-per-typed-name-and-connection - (with-login-stubs "kaylee" - (login " Wash " nil "1.1.1.1") - (is (true? (s/login-challenge-required? "wash" "1.1.1.1")) "trimmed and lowercased as the lookup does") - (is (false? (s/login-challenge-required? "wash" "2.2.2.2")) "another connection") - (is (false? (s/login-challenge-required? "zoe" "1.1.1.1")) "another name"))) - -(deftest the-mark-lapses - (with-login-stubs "kaylee" - (s/mark-login-challenge! "wash" "1.1.1.1") - (with-redefs [s/login-challenge-ms -1] - (s/mark-login-challenge! "zoe" "1.1.1.1") - (is (false? (s/login-challenge-required? "zoe" "1.1.1.1")))) - (is (true? (s/login-challenge-required? "wash" "1.1.1.1"))))) - -(deftest nothing-is-marked-while-turnstile-is-off - (with-redefs [s/turnstile-enabled? (constantly false)] - (s/mark-login-challenge! "wash" "1.1.1.1")) - (is (empty? @@#'s/login-challenges))) - -(deftest a-sprayed-or-throttled-refusal-also-marks-the-next-attempt - (with-login-stubs "kaylee" - (with-redefs [s/multiple-account-access? (constantly true)] - (let [r (login "wash" nil "3.3.3.3")] - (is (= errors/too-many-attempts (-> r :body :error))) - (is (true? (-> r :body :challenge?))))) - (is (true? (s/login-challenge-required? "wash" "3.3.3.3"))))) - -;; ---- a blocked widget and a failed check are told apart ---- - -(deftest no-token-is-told-to-allow-the-script-and-a-bad-token-to-retry - (let [messages (fn [resp] (get-in resp [:body :general])) - blocked errors/turnstile-blocked-message] - (is (str/includes? blocked "ad blocker")) - (is (str/includes? blocked "challenges.cloudflare.com")) - (doseq [[label call] - [["register" (fn [token] (auth/register (request (fresh-conn) token)))] - ["send-password-reset" - (fn [token] (auth/send-password-reset - {:query-params (cond-> {:email "a@b.com"} token (assoc :turnstile-token token)) - :db nil :conn nil :remote-addr "9.9.9.9"}))] - ["re-verify" - (fn [token] (auth/re-verify - {:query-params (cond-> {:email "a@b.com"} token (assoc :turnstile-token token)) - :db nil :conn nil :remote-addr "9.9.9.9"}))]]] - (testing label - (with-redefs [auth/user-for-email lookups-fail-the-test] - (doseq [blank [nil "" " "]] - (is (= [blocked] (messages (first (verify-calls {:success true} #(call blank))))) - "a blank token gets the ad-blocker message")) - (let [msgs (messages (first (verify-calls {:success false} #(call "bad"))))] - (is (= 1 (count msgs))) - (is (not= [blocked] msgs) "a failed token does not") - (is (str/includes? (first msgs) "not a bot")))))))) +(deftest a-route-that-challenges-after-failure-asks-only-after-one + (doseq [[route _ call] (guarded-routes #(= :after-failure (:turnstile %)))] + (reset! @#'s/sightings {}) + (let [ip "1.1.1.1" + attempt (fn [typed token ip] (call {:typed typed :token token :ip ip}))] + (testing (str route ": no challenge until a failure") + (with-login-stubs "kaylee" + (let [[resp calls] (verify-calls {:success false} #(attempt "kaylee" nil ip))] + (is (= 200 (:status resp))) + (is (zero? calls) "Cloudflare is not asked")))) + (testing (str route ": a failure looks the same for an unknown name and a wrong password") + (with-login-stubs "kaylee" + (let [unknown (attempt "nobody" nil ip) + wrong (with-redefs [auth/lookup-user (constantly {}) + auth/find-user-by-username-or-email + (constantly {:db/id 1 :orcpub.user/username "kaylee"})] + (attempt "kaylee" nil ip))] + (is (= errors/bad-credentials (-> unknown :body :error))) + (is (true? (-> unknown :body :challenge?))) + (is (= unknown wrong) "identical, including the flag")))) + (testing (str route ": the flag is absent while Turnstile is off") + (reset! @#'s/login-challenges {}) + (with-redefs [s/turnstile-enabled? (constantly false) + auth/lookup-user (constantly {}) + auth/find-user-by-username-or-email (constantly nil)] + (is (= {:status 401 :body {:error errors/bad-credentials}} (attempt "nobody" nil ip))) + (is (= {:status 401 :body {:error errors/bad-credentials}} (attempt "nobody" nil ip))) + (is (empty? @@#'s/login-challenges) "and nothing is marked"))) + (testing (str route ": after a failure the next attempt needs a passing token") + (reset! @#'s/login-challenges {}) + (with-login-stubs "kaylee" + (attempt "kaylee-typo" nil ip) + (with-redefs [auth/lookup-user lookups-fail-the-test] + (let [[resp calls] (verify-calls {:success true} #(attempt "kaylee-typo" nil ip))] + (is (= errors/challenge-required (-> resp :body :error)) "credentials are not looked at") + (is (true? (-> resp :body :challenge?))) + (is (zero? calls))) + (is (= errors/challenge-required + (-> (first (verify-calls {:success false} #(attempt "kaylee-typo" "bad" ip))) :body :error)))) + (is (= errors/bad-credentials + (-> (first (verify-calls {:success true} #(attempt "kaylee-typo" "good" ip))) :body :error))) + (is (= errors/bad-credentials + (-> (first (verify-calls :throw #(attempt "kaylee-typo" "any" ip))) :body :error)) + "an unreachable Cloudflare fails open"))) + (testing (str route ": the mark is per typed name and connection, trimmed and lowercased") + (reset! @#'s/login-challenges {}) + (with-login-stubs "kaylee" + (attempt " Wash " nil ip) + (is (true? (s/login-challenge-required? "wash" ip))) + (is (false? (s/login-challenge-required? "wash" "2.2.2.2")) "another connection") + (is (false? (s/login-challenge-required? "zoe" ip)) "another name"))) + (testing (str route ": a successful sign-in clears the mark") + (with-login-stubs "kaylee" + (s/mark-login-challenge! "kaylee" ip) + (is (= 200 (:status (first (verify-calls {:success true} #(attempt "kaylee" "good" ip)))))) + (is (false? (s/login-challenge-required? "kaylee" ip))) + (is (= 200 (:status (attempt "kaylee" nil ip))) "so the next one needs no token"))) + (testing (str route ": the mark lapses") + (with-login-stubs "kaylee" + (with-redefs [s/login-challenge-ms -1] + (s/mark-login-challenge! "zoe" ip) + (is (false? (s/login-challenge-required? "zoe" ip)))))) + (testing (str route ": a refusal by a limit also marks the next attempt") + (reset! @#'s/sightings {}) + (with-login-stubs "kaylee" + (dotimes [i 5] (attempt (str "spray" i) nil "3.3.3.3")) + (let [r (attempt "wash" nil "3.3.3.3")] + (is (= errors/too-many-attempts (-> r :body :error))) + (is (true? (-> r :body :challenge?))) + (is (true? (s/login-challenge-required? "wash" "3.3.3.3"))))))))) + +(deftest a-blank-field-is-answered-before-the-guard-is-consulted + (with-redefs [s/guard (fn [& _] (throw (AssertionError. "consulted too early")))] + (is (= errors/username-required + (-> (auth/login-response {:json-params {:username "" :password "x"} :remote-addr "1.2.3.4"}) + :body :error))))) + +(deftest the-resend-token-does-not-reach-the-mail + (let [seen (atom nil)] + (with-redefs [s/turnstile-enabled? (constantly true) + s/post-siteverify (fn [& _] {:success true}) + auth/user-for-email (constantly {:db/id 17}) + auth/do-verification (fn [_ params & _] (reset! seen params) {:status 200})] + (auth/re-verify {:query-params {:email "a@b.com" :turnstile-token "t"} + :db nil :conn nil :remote-addr "9.9.9.9"}) + (is (not (contains? @seen :turnstile-token)))))) diff --git a/test/clj/orcpub/user_email_test.clj b/test/clj/orcpub/user_email_test.clj index c38c66766..3cb373b1f 100644 --- a/test/clj/orcpub/user_email_test.clj +++ b/test/clj/orcpub/user_email_test.clj @@ -95,7 +95,7 @@ (deftest registration-sets-the-key (let [conn (fresh-conn)] - (with-redefs [security/registration-allowed? (constantly true) + (with-redefs [security/guard (constantly nil) email/configured? (constantly false) email/unverified-registration-allowed? (constantly true)] (is (= 200 (:status (auth/register {:conn conn :db (d/db conn) :scheme :https :headers {"host" "example.test"} From 9d7c564bfb030528d320259b8597315bd492042f Mon Sep 17 00:00:00 2001 From: codeGlaze Date: Wed, 4 Nov 2026 17:43:48 +0000 Subject: [PATCH 18/27] Owner notices: one claim-notice! with a cadence Sign-in-attempt and taken-sign-up notices go through one table-driven claim-notice!: the first at once, then only when new attempts came in, at least 6 hours apart and at most 4 in a rolling day. Every attempt is counted and a follow-up says how many came in since the previous notice. Still pages only, no credential, sent off-thread. --- src/clj/orcpub/email.clj | 38 ++++++++++------ src/clj/orcpub/routes/auth.clj | 17 +++---- src/clj/orcpub/security.clj | 50 +++++++++++++++------ test/clj/orcpub/registration_email_test.clj | 1 + test/clj/orcpub/routes_test.clj | 14 +++++- test/clj/orcpub/security_test.clj | 41 ++++++++++++++++- 6 files changed, 125 insertions(+), 36 deletions(-) diff --git a/src/clj/orcpub/email.clj b/src/clj/orcpub/email.clj index f24021969..14d263bb1 100644 --- a/src/clj/orcpub/email.clj +++ b/src/clj/orcpub/email.clj @@ -213,7 +213,7 @@ (.format (java.time.format.DateTimeFormatter/ofPattern "d MMMM yyyy 'at' HH:mm 'UTC'") (java.time.ZonedDateTime/now java.time.ZoneOffset/UTC))) -(defn sign-in-attempts-email-html [first-and-last-name reset-url browser when-str] +(defn sign-in-attempts-email-html [first-and-last-name reset-url browser when-str since-last] (into [:div (str "Dear " (if (seq first-and-last-name) first-and-last-name (str branding/app-name " User")) ",") @@ -225,6 +225,10 @@ (str "The last of those attempts was on " when-str ", from " browser ".") [:br] [:br] + (when since-last + (list (str "Since the last email about this, there have been " since-last " more attempts.") + [:br] + [:br])) "Usually this is nothing. A phone and a laptop both signed out at the same time will do it, as will a password you half remember. Nobody got in, nothing has changed, and your account is not locked." [:br] [:br] @@ -240,16 +244,17 @@ (str "The " branding/email-sender-name)] (social-links-footer))) -(defn sign-in-attempts-email [first-and-last-name reset-url browser when-str] +(defn sign-in-attempts-email [first-and-last-name reset-url browser when-str since-last] [{:type "text/html" :content (str (hiccup/html (sign-in-attempts-email-html - first-and-last-name reset-url browser when-str)))}]) + first-and-last-name reset-url browser when-str since-last)))}]) (defn sign-in-attempts-message "The notice that failed sign-ins arrived from several places at once: `base-url`, and a map - with :email :first-and-last-name :user-agent. Links to the reset PAGE, never a token, so people - are not trained to click mailed credentials (account-flows.md). Returns the postal message." - [base-url {:keys [email first-and-last-name user-agent]}] + with :email :first-and-last-name :user-agent, and :since-last (how many attempts since the previous + notice) on a follow-up. Links to the reset PAGE, never a token, so people are not trained to click + mailed credentials (account-flows.md). Returns the postal message." + [base-url {:keys [email first-and-last-name user-agent since-last]}] {:from (str branding/email-sender-name " <" (emailfrom) ">") :to email :subject (str branding/app-name " sign-in attempts") @@ -257,12 +262,13 @@ first-and-last-name (str base-url (routes/path-for routes/send-password-reset-page-route)) (describe-browser user-agent) - (attempt-time))}) + (attempt-time) + since-last)}) (defn signup-attempt-email-html "Says nothing that identifies the account: no name, username, credential or token. Both links go to pages, so the reader decides what to do and nothing in this mail can be replayed." - [sign-in-url reset-url] + [sign-in-url reset-url since-last] (into [:div "Hello," @@ -271,6 +277,10 @@ (str "Someone just tried to sign up for " branding/app-name " with this email address, which already has an account.") [:br] [:br] + (when since-last + (list (str "Since the last email about this, there have been " since-last " more attempts.") + [:br] + [:br])) "If it was you, you do not need a second account. Sign in here:" [:br] [:br] @@ -292,20 +302,22 @@ (str "The " branding/email-sender-name)] (social-links-footer))) -(defn signup-attempt-email [sign-in-url reset-url] +(defn signup-attempt-email [sign-in-url reset-url since-last] [{:type "text/html" - :content (str (hiccup/html (signup-attempt-email-html sign-in-url reset-url)))}]) + :content (str (hiccup/html (signup-attempt-email-html sign-in-url reset-url since-last)))}]) (defn signup-attempt-message "The notice to the owner of an address somebody tried to sign up with again: `base-url`, and a map - with :email. Links to the sign-in and reset PAGES only. Returns the postal message." - [base-url {:keys [email]}] + with :email, and :since-last (attempts since the previous notice) on a follow-up. Links to the + sign-in and reset PAGES only. Returns the postal message." + [base-url {:keys [email since-last]}] {:from (str branding/email-sender-name " <" (emailfrom) ">") :to email :subject (str branding/app-name " sign-up attempt") :body (signup-attempt-email (str base-url (routes/path-for routes/login-page-route)) - (str base-url (routes/path-for routes/send-password-reset-page-route)))}) + (str base-url (routes/path-for routes/send-password-reset-page-route)) + since-last)}) (defn password-changed-email-html [first-and-last-name reset-url browser when-str] (into diff --git a/src/clj/orcpub/routes/auth.clj b/src/clj/orcpub/routes/auth.clj index 1224995af..a929ba4b8 100644 --- a/src/clj/orcpub/routes/auth.clj +++ b/src/clj/orcpub/routes/auth.clj @@ -223,8 +223,8 @@ (if refusal (refusal-response ::login refusal) (let [user-for-username (find-user-by-username-or-email db username) - notice (and notify (:db/id user-for-username) - (security/claim-sign-in-notice! username))] + notice (when (and notify (:db/id user-for-username)) + (security/claim-notice! notify (:db/id user-for-username)))] ;; A name with no account is not logged: it is sometimes a password typed in the wrong box. (security/audit! :sign-in-failed request (:orcpub.user/username user-for-username)) ;; Several addresses failing against ONE account inside a minute is also what @@ -237,9 +237,10 @@ (outbox/enqueue! (:conn request) :sign-in-attempts (email/sign-in-attempts-message (base-url request) - {:email (:orcpub.user/email user-for-username) - :first-and-last-name (:orcpub.user/first-and-last-name user-for-username) - :user-agent (get (:headers request) "user-agent")})) + (merge notice + {:email (:orcpub.user/email user-for-username) + :first-and-last-name (:orcpub.user/first-and-last-name user-for-username) + :user-agent (get (:headers request) "user-agent")}))) (catch Exception e (println "ERROR: could not queue a sign-in attempts notice:" (.getMessage e)))))) ;; One answer for both. Telling somebody the username does not exist made @@ -414,12 +415,12 @@ [{:keys [db conn] :as request} email] (try (let [owner (user-for-email db email)] - (when (and (:db/id owner) - (security/claim-taken-signup-notice! email)) + (when-let [notice (and (:db/id owner) + (security/claim-notice! :taken-signup email))] (outbox/enqueue! conn :signup-attempt (email/signup-attempt-message (base-url request) - {:email (or (:orcpub.user/email owner) email)})))) + (assoc notice :email (or (:orcpub.user/email owner) email)))))) (catch Exception e (println "ERROR: could not queue a sign-up attempt notice:" (.getMessage e))))) diff --git a/src/clj/orcpub/security.clj b/src/clj/orcpub/security.clj index ae715bf54..e50b195a6 100644 --- a/src/clj/orcpub/security.clj +++ b/src/clj/orcpub/security.clj @@ -185,11 +185,6 @@ (when (vector? k) (second k)))) allowed)) -(defn claim-once? - "True the first time `k` is claimed inside `window`, false until it lapses." - [k window] - (under-limit? k 1 window)) - ;; The probe has no login, so IP is the only handle on who is asking. A real ;; character builder fires it once per image field, well under this; a script ;; walking a URL list to keep the fetch pool occupied is what it stops. @@ -526,13 +521,42 @@ (when-let [line (busiest-summary highs 0.8)] (println line)))) -;; One sign-in notice per account per day, and one taken-sign-up notice per address per day. An -;; attacker who can trigger the condition can trigger it on a loop, so without this the warning -;; would be a way to mail-bomb anyone whose username or address is known. -(def notice-cooldown-hours 24) +;; --------------------------------------------------------------------------- +;; Notices to an account's owner about attempts on it: the first at once, then only when new +;; attempts came in, no sooner than :min-gap-hours after the last and at most :max-per-day in a +;; rolling day, each saying how many came in. Without a cadence the warning mail-bombs the owner. +;; --------------------------------------------------------------------------- + +(def notices + {:sign-in-attempts {:first :immediate :min-gap-hours 6 :max-per-day 4} + :taken-signup {:first :immediate :min-gap-hours 6 :max-per-day 4}}) -(defn claim-sign-in-notice! [username] - (claim-once? [:sign-in-notice username] (hours notice-cooldown-hours))) +(def ^:private notice-state (atom {})) -(defn claim-taken-signup-notice! [email-key] - (claim-once? [:taken-signup-notice email-key] (hours notice-cooldown-hours))) +(defn claim-notice! + "Counts one attempt for `kind` (a key of `notices`) against `k` (the account or address) and says + whether to mail the owner now: nil when not, {} for the first notice, {:since-last n} for a + follow-up, n being the attempts since the previous notice, this one included." + [kind k] + (let [{:keys [min-gap-hours max-per-day]} (notices kind) + at (time/now) + day-ago (.minus ^java.time.Instant at (hours 24)) + gap-ago (.minus ^java.time.Instant at (hours min-gap-hours)) + entry-key [kind k] + claimed (fn [m] + (let [{:keys [pending sent notified?] :or {pending 0 sent []}} (get m entry-key) + sent (filterv #(.isAfter ^java.time.Instant % day-ago) sent) + pending (inc pending) + due? (if (empty? sent) + (or notified? (= :immediate (:first (notices kind)))) + (and (not (.isAfter ^java.time.Instant (peek sent) gap-ago)) + (< (count sent) max-per-day)))] + (assoc m entry-key + (if due? + {:pending 0 :sent (conj sent at) :seen at :notified? true + :claimed (if notified? {:since-last pending} {})} + {:pending pending :sent sent :seen at :notified? notified?})))) + after (swap! notice-state + (fn [m] + (claimed (into {} (remove (fn [[_ e]] (.isBefore ^java.time.Instant (:seen e) day-ago))) m))))] + (:claimed (get after entry-key)))) diff --git a/test/clj/orcpub/registration_email_test.clj b/test/clj/orcpub/registration_email_test.clj index 036ce783a..36d276c91 100644 --- a/test/clj/orcpub/registration_email_test.clj +++ b/test/clj/orcpub/registration_email_test.clj @@ -24,6 +24,7 @@ ;; from a nil address; this file tests the email, not the throttle. (fn [f] (reset! @#'security/sightings {}) + (reset! @#'security/notice-state {}) (with-redefs [email/configured? (constantly true)] (binding [errors/*error-prefix* "TEST_ERROR:"] (f))) diff --git a/test/clj/orcpub/routes_test.clj b/test/clj/orcpub/routes_test.clj index 373c4c599..daba5422c 100644 --- a/test/clj/orcpub/routes_test.clj +++ b/test/clj/orcpub/routes_test.clj @@ -411,6 +411,7 @@ (deftest the-owner-is-told-when-one-account-is-tried-from-several-places (reset! @#'security/sightings {}) + (reset! @#'security/notice-state {}) (let [posted (atom []) request {:scheme :https :headers {"host" "example.test"}} account {:db/id 17 :orcpub.user/email "kaylee@serenity.example" @@ -433,11 +434,22 @@ (let [message (do (Thread/sleep 100) (first @posted))] (is (= "kaylee@serenity.example" (:to message))) (is (re-find #"https://example\.test" (pr-str (:body message))) "linking to this site") - ) + (is (not (re-find #"more attempts" (pr-str (:body message)))) "the first says nothing of a count")) (fail-from "4.4.4.4" "kaylee" request) (Thread/sleep 100) (is (= 1 (count @posted)) "a further attempt inside the gap sends nothing more")))))) +(deftest a-follow-up-notice-says-how-many-attempts-came-in + (doseq [[label message] + [["sign-in" (email/sign-in-attempts-message "https://example.test" {:email "a@b.c" :since-last 7})] + ["sign-up" (email/signup-attempt-message "https://example.test" {:email "a@b.c" :since-last 7})]]] + (let [text (pr-str (:body message))] + (is (re-find #"7 more attempts" text) label) + (is (not (re-find #"more attempts" + (pr-str (:body (email/signup-attempt-message "https://example.test" {:email "a@b.c"})))))) + (is (not (re-find #"token|key=" text)) "no credential, only pages")))) + + (deftest a-user-agent-is-described-the-way-a-person-would ;; Order matters in describe-browser: Edge and Opera both claim to be Chrome, ;; and Chrome claims to be Safari, so the checks run most-specific first. diff --git a/test/clj/orcpub/security_test.clj b/test/clj/orcpub/security_test.clj index b516eb841..75862e611 100644 --- a/test/clj/orcpub/security_test.clj +++ b/test/clj/orcpub/security_test.clj @@ -105,12 +105,14 @@ (fn [f] (reset! @#'s/sightings {}) (reset! @#'s/login-challenges {}) + (reset! @#'s/notice-state {}) (with-redefs [email/configured? (constantly true) pwned/check (constantly 0)] (binding [errors/*error-prefix* "TEST_ERROR:"] (f))) (reset! @#'s/sightings {}) - (reset! @#'s/login-challenges {}))) + (reset! @#'s/login-challenges {}) + (reset! @#'s/notice-state {}))) (def ^:private secret "s3cr3t-turnstile-value-9f2c") @@ -461,3 +463,40 @@ (auth/re-verify {:query-params {:email "a@b.com" :turnstile-token "t"} :db nil :conn nil :remote-addr "9.9.9.9"}) (is (not (contains? @seen :turnstile-token)))))) + +;; ---- notices to an account's owner: first at once, then at most every 6 hours and 4 a day ---- + +(defn- clock-from [t0] + (let [clock (atom t0)] + [(fn [] @clock) (fn [minutes] (reset! clock (.plusSeconds t0 (* 60 minutes))))])) + +(def ^:private t0 (.toInstant #inst "2026-01-01T00:00:00Z")) + +(deftest every-notice-follows-its-cadence + (doseq [[kind {:keys [min-gap-hours]}] s/notices] + (testing (str kind) + (reset! @#'s/notice-state {}) + (let [[now-fn at] (clock-from t0) + gap (* 60 min-gap-hours) + claim #(s/claim-notice! kind "someone")] + (with-redefs [time/now now-fn] + (is (= {} (claim)) "the first attempt is told at once") + (is (nil? (claim)) "a second inside the gap is not") + (at (dec gap)) + (is (nil? (claim)) "nor one just short of it") + (at (inc gap)) + (is (= {:since-last 3} (claim)) "after the gap the next attempt is told, with how many came in since") + (is (nil? (claim)) "and then the gap starts again") + (dotimes [_ 4] (claim)) + (at (+ (* 2 (inc gap)) 2)) + (is (= {:since-last 6} (claim)) "attempts are counted while suppressed") + (is (= {} (s/claim-notice! kind "someone-else")) "a different key has its own cadence")))))) + +(deftest no-more-than-the-daily-maximum-goes-out-in-a-rolling-day + (with-redefs [s/notices {:k {:first :immediate :min-gap-hours 1 :max-per-day 4}}] + (let [[now-fn at] (clock-from t0)] + (with-redefs [time/now now-fn] + (is (= [true true true true false] + (for [i (range 5)] (do (at (* i 61)) (some? (s/claim-notice! :k "x")))))) + (at (+ (* 24 60) 1)) + (is (= {:since-last 2} (s/claim-notice! :k "x")) "the first notice has left the day"))))) From 1aa919e224fe39dbf1c9489711e4612f9c6cef0d Mon Sep 17 00:00:00 2001 From: codeGlaze Date: Wed, 4 Nov 2026 17:52:53 +0000 Subject: [PATCH 19/27] Auth forms: the page shell and one request interceptor carry the protection auth-form-page takes :challenge (:always or :after-failure) and places the Turnstile widget and its blocked-script message itself; pages no longer place a widget. One pair of interceptors in events/auth attaches the current token to register, login, reset and resend requests and resets the widget when they fail. --- src/cljs/orcpub/dnd/e5/events/auth.cljs | 64 +++++++---- src/cljs/orcpub/dnd/e5/views/auth.cljs | 147 ++++++++++++------------ 2 files changed, 115 insertions(+), 96 deletions(-) diff --git a/src/cljs/orcpub/dnd/e5/events/auth.cljs b/src/cljs/orcpub/dnd/e5/events/auth.cljs index fa151d1c2..a8655672d 100644 --- a/src/cljs/orcpub/dnd/e5/events/auth.cljs +++ b/src/cljs/orcpub/dnd/e5/events/auth.cljs @@ -11,7 +11,27 @@ [orcpub.errors :as errors] [orcpub.fork.branding :as branding] [orcpub.route-map :as routes] - [re-frame.core :refer [reg-event-db reg-event-fx]])) + [re-frame.core :refer [->interceptor reg-event-db reg-event-fx]])) + +;; The protection every auth request shares (security/auth-guards decides which forms ask for it): +;; the current Turnstile token goes out with the request, and a failure asks the widget for a fresh +;; one, because a token works once. Attach these to the events that send and that receive. +(def challenge-request + (->interceptor + :id :challenge-request + :after (fn [context] + (let [token (:turnstile-token (get-in context [:coeffects :db])) + http (get-in context [:effects :http]) + params-key (if (contains? http :json-params) :json-params :query-params)] + (cond-> context + (and token http) (assoc-in [:effects :http params-key] + (assoc (get http params-key) :turnstile-token token))))))) + +(def challenge-reset + (->interceptor + :id :challenge-reset + :after (fn [context] + (update-in context [:effects :dispatch-n] (fnil conj []) [:turnstile-reset])))) (reg-event-fx :change-email @@ -108,15 +128,15 @@ (reg-event-fx :login-failure + [challenge-reset] (fn [{:keys [db]} [_ response]] (let [error-code (-> response :body :error) ;; The server sends the flag identically after every failed sign-in, so the form shows - ;; the challenge for the retry; the token just used is spent either way. + ;; the challenge for the retry. challenge? (boolean (-> response :body :challenge?)) with-challenge (fn [fx] (cond-> fx - challenge? (assoc :db (assoc db :login-challenge? true)) - challenge? (update :dispatch-n (fnil conj []) [:turnstile-reset])))] + challenge? (assoc :db (assoc db :login-challenge? true))))] (with-challenge (cond (= error-code errors/challenge-required) @@ -158,11 +178,11 @@ (reg-event-fx :login - (fn [{:keys [db]} [_ params backtrack?]] + [challenge-request] + (fn [_ [_ params backtrack?]] {:http {:method :post :url login-url - :json-params (cond-> params - (:turnstile-token db) (assoc :turnstile-token (:turnstile-token db))) + :json-params params :on-success [:login-success backtrack?] :on-unauthorized [:login-failure]}})) @@ -189,6 +209,7 @@ :register-failure ;; :registration-server-errors holds what only the server can judge, shown by field; any other ;; failure becomes a :general notice, so no server-side failure is silent. account-flows.md. + [challenge-reset] (fn [{:keys [db]} [_ response]] (let [body (:body response)] {:db (assoc db :registration-server-errors @@ -197,8 +218,7 @@ {:general ["Registration is currently unavailable. Please contact the site administrator."]} (and (map? body) (not (contains? body :error))) body :else {:general ["Registration failed. Please try again."]})) - ;; A Turnstile token is single use: any failed attempt needs a fresh one. - :dispatch-n [[:clear-login] [:turnstile-reset]]}))) + :dispatch-n [[:clear-login]]}))) (reg-event-db :turnstile-token @@ -291,13 +311,13 @@ (reg-event-fx :register + [challenge-request] (fn [{:keys [db]} [_ params backtrack?]] (let [registration-form (:registration-form db)] {:db (assoc db :temp-email (:email registration-form)) :http {:method :post :url (backend-url (bidi/path-for routes/routes routes/register-route)) - :json-params (cond-> registration-form - (:turnstile-token db) (assoc :turnstile-token (:turnstile-token db))) + :json-params registration-form :on-success [:register-success backtrack?] :on-failure [:register-failure]}}))) @@ -311,28 +331,27 @@ routes/verify-success-route routes/verify-sent-route)))) -(defn- challenge-failure +(defn- refused-request "Effects for a request the server refused: its :general message when it gave one (the failed or - missing challenge), else the generic error. The token is spent either way." + missing challenge), else the generic error." [response] (let [message (first (get-in response [:body :general]))] - (if message - {:dispatch-n [[:show-login-message message] [:turnstile-reset]]} - {:dispatch-n [(show-generic-error) [:turnstile-reset]]}))) + {:dispatch-n [(if message [:show-login-message message] (show-generic-error))]})) (reg-event-fx :re-verify-failure + [challenge-reset] (fn [_ [_ response]] - (challenge-failure response))) + (refused-request response))) (reg-event-fx :re-verify + [challenge-request] (fn [{:keys [db]} [_ params]] {:db (assoc db :temp-email (:email params)) :http {:method :get :url (backend-url (bidi/path-for routes/routes routes/re-verify-route)) - :query-params (cond-> params - (:turnstile-token db) (assoc :turnstile-token (:turnstile-token db))) + :query-params params :on-success [:re-verify-success] :on-failure [:re-verify-failure]}})) @@ -345,17 +364,18 @@ :send-password-reset-failure ;; The endpoint answers 200 for every address, so :no-account cannot arrive here. A refused ;; challenge carries a :general message; anything else is a network or server fault. + [challenge-reset] (fn [_ [_ response]] - (challenge-failure response))) + (refused-request response))) (reg-event-fx :send-password-reset + [challenge-request] (fn [{:keys [db]} [_ params]] {:db (assoc db :temp-email (:email params)) :http {:method :get :url (backend-url (bidi/path-for routes/routes routes/send-password-reset-route)) - :query-params (cond-> params - (:turnstile-token db) (assoc :turnstile-token (:turnstile-token db))) + :query-params params :on-success [:send-password-reset-success] :on-failure [:send-password-reset-failure]}})) diff --git a/src/cljs/orcpub/dnd/e5/views/auth.cljs b/src/cljs/orcpub/dnd/e5/views/auth.cljs index 9990cf55f..af8df397b 100644 --- a/src/cljs/orcpub/dnd/e5/views/auth.cljs +++ b/src/cljs/orcpub/dnd/e5/views/auth.cljs @@ -326,18 +326,6 @@ :on-confirm on-confirm}] [password-meter password context refused]]) -(defn auth-form-page - "An auth-page shell for a form: `fields` in a column, then `tail` (submit and - any links or fineprint) below them. - See account-flows.md." - [{:keys [heading lede fields tail legal-links?] - :or {legal-links? true}}] - (auth-page heading lede - [:div - [:div.m-t-10.auth-form fields] - (when tail [:div.m-t-10.auth-tail tail])] - {:legal-links? legal-links?})) - (defn hide-login-message [] (dispatch [:hide-login-message])) @@ -348,6 +336,25 @@ [:div.m-t-5.p-r-5.p-l-5 [notifications/message :error @(subscribe [:login-message]) hide-login-message]])) +(defn auth-form-page + "An auth-page shell for a form: `fields` in a column, then the form's protection, then `tail` + (submit and any links or fineprint). `challenge` is :always or :after-failure (or absent): the + shell places the Turnstile widget and its blocked-script message, so a page never does. + `message?` adds the form's refusal message under the widget. + See account-flows.md." + [{:keys [heading lede fields tail legal-links? challenge message?] + :or {legal-links? true}}] + (auth-page heading lede + [:div + [:div.m-t-10.auth-form + fields + (when (or (= :always challenge) + (and (= :after-failure challenge) @(subscribe [:login-challenge?]))) + [widget]) + (when message? [login-message-block])] + (when tail [:div.m-t-10.auth-tail tail])] + {:legal-links? legal-links?})) + (defn verify-failed [] (let [params (r/atom {})] (fn [] @@ -361,10 +368,9 @@ :value (:email @params) :type :email :title "Email address" - :on-change (partial set-value params :email)}] - ;; A refused challenge is answered here, as on the reset page. - [login-message-block] - [widget]] + :on-change (partial set-value params :email)}]] + :challenge :always + :message? true :tail [:button.form-button.form-submit-btn {:on-click (make-event-handler :re-verify @params)} "RESEND"]})))) @@ -388,9 +394,9 @@ []) :type :email :value email - :on-change (partial set-value params :email)}] - [login-message-block] - [widget]] + :on-change (partial set-value params :email)}]] + :challenge :always + :message? true :tail [:div [:button.form-button.form-submit-btn @@ -658,9 +664,8 @@ :on-confirm (fn [e] (dispatch [:registration-verify-password (event-value e)]))}] [:div.m-t-20.t-a-l.m-l-15 [comps/labeled-checkbox (str "Yes! Send me updates about " branding/app-name) send-updates? false - #(dispatch [:registration-send-updates? (not send-updates?)])]] - [widget] - ] + #(dispatch [:registration-send-updates? (not send-updates?)])]]] + :challenge :always :tail [:div (when-let [notice @(subscribe [:registration-notice])] @@ -701,55 +706,49 @@ (defn login-page [] (let [params (r/atom {})] (fn [] - (let [login-message-shown? @(subscribe [:login-message-shown?]) - login-message @(subscribe [:login-message])] - ;; .login-form-inputs was this page's own container, so its fields were - ;; 350px where every other page's are the column's width, and the tail - ;; nested inside it came out narrower than the fields above it. It is on - ;; the same shape as the rest now. - (auth-form-page - {:heading "Welcome back" - :fields - [:div - [form-input {:title "Username or Email" - :key :username - :value (:username @params) - :type :username - :on-change #(swap! params assoc :username (event-value %))}] - [form-input {:title "Password" - :key :password - :value (:password @params) - :type :password - :on-change #(swap! params assoc :password (event-value %))}] - ;; Only after a failed attempt: the server flags it, :login-failure sets this. - (when @(subscribe [:login-challenge?]) [widget]) - (when login-message-shown? - [:div.m-t-5 [notifications/message - :error - login-message - hide-login-message]])] - :tail - [:div - [:button.form-button.join-button - {:on-click #(dispatch [:login @params true])} - "LOGIN"] - ;; One group, one rhythm: each question and its answer share a line, - ;; the way the register page already asks its one. - [:div.m-t-20.auth-alts - [:div.auth-alt - [:span "Don't have a login?"] - [:span.orange.underline.pointer - {:on-click route-to-register-page} - "REGISTER NOW"]] - [:div.auth-alt - [:span "Forgot your password?"] - [:span.orange.underline.pointer - {:on-click route-to-reset-password-page} - "RESET PASSWORD"]]] - ;; Kept apart from the pair above: it is not another way in, it is - ;; what to do when the way in never arrived. - [:div.auth-help - [:span "Didn't receive the validation email? Check your spam folder, or "] - [:a.orange {:href "/help/im-not-getting-my-signup-password-reset-email/" :target "_blank"} - "read how to let our email through"] - [:span "."]]]}))))) + ;; .login-form-inputs was this page's own container, so its fields were + ;; 350px where every other page's are the column's width, and the tail + ;; nested inside it came out narrower than the fields above it. It is on + ;; the same shape as the rest now. + (auth-form-page + {:heading "Welcome back" + :fields + [:div + [form-input {:title "Username or Email" + :key :username + :value (:username @params) + :type :username + :on-change #(swap! params assoc :username (event-value %))}] + [form-input {:title "Password" + :key :password + :value (:password @params) + :type :password + :on-change #(swap! params assoc :password (event-value %))}]] + ;; Only after a failed attempt: the server flags it, :login-failure sets the flag. + :challenge :after-failure + :message? true + :tail + [:div + [:button.form-button.join-button + {:on-click #(dispatch [:login @params true])} + "LOGIN"] + ;; One group, one rhythm: each question and its answer share a line, + ;; the way the register page already asks its one. + [:div.m-t-20.auth-alts + [:div.auth-alt + [:span "Don't have a login?"] + [:span.orange.underline.pointer + {:on-click route-to-register-page} + "REGISTER NOW"]] + [:div.auth-alt + [:span "Forgot your password?"] + [:span.orange.underline.pointer + {:on-click route-to-reset-password-page} + "RESET PASSWORD"]]] + ;; Kept apart from the pair above: it is not another way in, it is + ;; what to do when the way in never arrived. + [:div.auth-help + [:span "Didn't receive the validation email? Check your spam folder, or "] + [:a.orange {:href "/help/im-not-getting-my-signup-password-reset-email/" :target "_blank"} + "read how to let our email through"] + [:span "."]]]})))) From 710a241dcdf0edac66fbad34de8d32ee08c4e9f3 Mon Sep 17 00:00:00 2001 From: codeGlaze Date: Wed, 4 Nov 2026 18:58:43 +0000 Subject: [PATCH 20/27] Take the login challenge flag from the guard table --- src/clj/orcpub/routes/auth.clj | 10 ++-------- src/clj/orcpub/security.clj | 8 ++++++++ 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/src/clj/orcpub/routes/auth.clj b/src/clj/orcpub/routes/auth.clj index a929ba4b8..5a08fd204 100644 --- a/src/clj/orcpub/routes/auth.clj +++ b/src/clj/orcpub/routes/auth.clj @@ -189,12 +189,6 @@ (defn base-url [{:keys [scheme headers]}] (str (or (headers "x-forwarded-proto") (name scheme)) "://" (headers "host"))) -(defn- challenge-flag - "Tells the form to show the challenge for the retry. The same map for every failure, so it - cannot tell an unknown name from a wrong password; nil while Turnstile is off." - [] - (when (security/turnstile-enabled?) {:challenge? true})) - (def ^:private turnstile-failed-message "We couldn't confirm you're not a bot. Please try the check again.") @@ -215,7 +209,7 @@ (and (= reason :turnstile) (= answer :error)) (login-error errors/challenge-required {:challenge? true}) (= reason :turnstile) {:status 400 :body {:general [(turnstile-message blank?)]}} (= answer :uniform) {:status 200} - (= answer :error) (login-error errors/too-many-attempts (challenge-flag)) + (= answer :error) (login-error errors/too-many-attempts (security/challenge-flag ::login)) :else {:status 400 :body {:general [message]}}))) (defn bad-credentials-response [db username ip request] @@ -246,7 +240,7 @@ ;; One answer for both. Telling somebody the username does not exist made ;; the login form the same membership test the reset endpoint was, and a ;; cheaper one, since it needs no mail to be sent. - (login-error errors/bad-credentials (challenge-flag)))))) + (login-error errors/bad-credentials (security/challenge-flag ::login)))))) (defn create-login-response [db conn user id & [headers]] (let [token (create-token (:orcpub.user/username user) diff --git a/src/clj/orcpub/security.clj b/src/clj/orcpub/security.clj index e50b195a6..0f0f79cf9 100644 --- a/src/clj/orcpub/security.clj +++ b/src/clj/orcpub/security.clj @@ -424,6 +424,14 @@ (refuse! k)))) (:limits p)))) +(defn challenge-flag + "What a failed request on `route` tells its form about the challenge: {:challenge? true} when + the route's policy is :turnstile :after-failure and Turnstile is on, else nil. The same map for + every failure, so it cannot tell an unknown name from a wrong password." + [route] + (when (and (= :after-failure (:turnstile (policy route))) (turnstile-enabled?)) + {:challenge? true})) + (defn guard "nil when the request may go on, else a refusal: {:reason :turnstile :blank? bool} or {:reason :limit :limit kw}. `route` is a key of auth-guards; `ctx` holds what the handler knows: From 58cf1c5e861f2d39d7f6afe908e2125a0ebffdd7 Mon Sep 17 00:00:00 2001 From: codeGlaze Date: Wed, 4 Nov 2026 18:58:56 +0000 Subject: [PATCH 21/27] Branch changelog for fix/auth-abuse --- docs/branch-changelog.md | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) create mode 100644 docs/branch-changelog.md diff --git a/docs/branch-changelog.md b/docs/branch-changelog.md new file mode 100644 index 000000000..c017a352b --- /dev/null +++ b/docs/branch-changelog.md @@ -0,0 +1,30 @@ + + +# Branch changelog — `fix/auth-abuse` + +## Why this branch exists + +The live site was hit with password-reset spam on 2026-11-03. An audit of the account forms found +resend-verification had no limit, sign-up told anyone whether an email had an account, and the +limits were written per form, so a new form could ship unguarded. This branch puts every account +form under one policy table and one guard (with a test that fails if a route is missing from it), +adds an optional Cloudflare Turnstile check (off unless both keys are set), and moves the account +code out of `routes.clj`, `views.cljs` and `events.cljs` into `routes/auth`, `views/auth` and +`events/auth`. + +## Added + +- **Accounts:** an optional Cloudflare Turnstile check on sign-up, password reset and resend verification, and on sign-in after a failed attempt. Off unless `TURNSTILE_SITE_KEY` and `TURNSTILE_SECRET_KEY` are set; if Cloudflare can't be reached, requests go through. +- **Accounts:** when the security check can't load, the form says so and suggests allowing challenges.cloudflare.com in an ad blocker. + +## Changed + +- **Accounts:** sign-up no longer says when an email is already in use. It answers as for a new address and emails the account's owner instead. Without a mail server, a taken address gets a plain refusal. +- **Accounts:** warnings about sign-in attempts on your account now follow up while attempts continue (at most every 6 hours, with a count), instead of once a day. + +## Fixed + +## Security + +- **Accounts:** account emails can no longer be triggered in bulk from one form that had no limit. From cbbe7a9fae8e583ff3418451262388a2df543ebc Mon Sep 17 00:00:00 2001 From: codeGlaze Date: Wed, 4 Nov 2026 22:07:19 +0000 Subject: [PATCH 22/27] Close auth-abuse review findings: configured-URL notices, Turnstile 4xx and non-text tokens, bounded challenge checks and memory, conditional re-verify, released notice claims --- .env.example | 4 +- docs/ENVIRONMENT.md | 4 +- src/clj/orcpub/routes/auth.clj | 84 +++++++----- src/clj/orcpub/security.clj | 137 +++++++++++++++----- src/cljs/orcpub/dnd/e5/views/auth.cljs | 6 +- test/clj/orcpub/registration_email_test.clj | 65 +++++++++- test/clj/orcpub/routes_test.clj | 22 +++- test/clj/orcpub/security_test.clj | 131 ++++++++++++++++++- test/cljs/orcpub/dnd/e5/events_test.cljs | 8 ++ 9 files changed, 380 insertions(+), 81 deletions(-) diff --git a/.env.example b/.env.example index 5870b7910..e8a28442c 100644 --- a/.env.example +++ b/.env.example @@ -209,8 +209,8 @@ PROFILE_ENCRYPTION_KEYS= # ORCPUB_SHARE_PRUNE_DAYS=180 # Check new passwords against known breaches (Have I Been Pwned). on or off. Default on. # ORCPUB_PWNED_CHECK=on -# Cloudflare Turnstile on the sign-up form (managed mode). Off unless BOTH are set. Fails open -# if Cloudflare cannot be reached. Cloudflare's test keys always pass: +# Cloudflare Turnstile (managed mode) on sign-up, password reset, resend verification and sign-in +# after a failed attempt. Off unless BOTH are set. Fails open if Cloudflare cannot be reached. Cloudflare's test keys always pass: # site key 1x00000000000000000000AA secret 1x0000000000000000000000000000000AA # TURNSTILE_SITE_KEY= # TURNSTILE_SECRET_KEY= diff --git a/docs/ENVIRONMENT.md b/docs/ENVIRONMENT.md index 2ea3af4a2..21cfb4fc6 100644 --- a/docs/ENVIRONMENT.md +++ b/docs/ENVIRONMENT.md @@ -50,7 +50,7 @@ start-up output, so you can decide which ones matter for your site. | `ORCPUB_SHARE_MAX_UPLOAD_KB`, `ORCPUB_SHARE_MAX_TEXT_KB`, `ORCPUB_SHARE_MAX_ACCOUNT_KB` | How much homebrew a share link and an account may keep | [Share links](#share-links) | | `ORCPUB_SHARE_PRUNE_DAYS` | How long an unused share link is kept | [Share links](#share-links) | | `ORCPUB_PWNED_CHECK` | Whether new passwords are checked against known breaches | [Security](#security) | -| `TURNSTILE_SITE_KEY`, `TURNSTILE_SECRET_KEY` | Cloudflare Turnstile bot check on the sign-up form | [Security](#security) | +| `TURNSTILE_SITE_KEY`, `TURNSTILE_SECRET_KEY` | Cloudflare Turnstile bot check on sign-up, password reset, resend verification and sign-in after a failure | [Security](#security) | | `TRUST_CLOUDFLARE`, `TRUSTED_PROXIES` | Which proxies to trust when finding a player's real address | [Security](#security) | | `APP_EMAIL_SIGNOFF` | Who the friendlier emails are signed from | [BRANDING-AND-INTEGRATIONS.md](BRANDING-AND-INTEGRATIONS.md) | @@ -213,7 +213,7 @@ the table in half. Plain ASCII, no colour: it is read in aggregators as often as | `CSP_POLICY` | `strict` | Content Security Policy mode: `strict`, `permissive`, or `none` | | `DEV_MODE` | `"true"` (in :dev profile) | When true, **no CSP header is sent at all** — that is what lets Figwheel's `ws://localhost:3449` through. Must be the string `"true"` (case-insensitive); any other value, including `"1"`, `"yes"` or empty, is false. | | `ORCPUB_PWNED_CHECK` | `on` | Screen new passwords against the Have I Been Pwned corpus. Accepts `on`/`off`, `true`/`false`, `1`/`0`, `yes`/`no`. | -| `TURNSTILE_SITE_KEY` | unset | Cloudflare Turnstile site key (public; sent to the browser). The sign-up form shows the managed-mode check only when **both** this and `TURNSTILE_SECRET_KEY` are set; otherwise the feature is entirely off. Adds `https://challenges.cloudflare.com` to the CSP `frame-src` (and, under `CSP_POLICY=permissive`, `script-src`). Fails open: if Cloudflare cannot be reached, sign-up goes through. For testing, Cloudflare's dummy keys always pass: site key `1x00000000000000000000AA`, secret `1x0000000000000000000000000000000AA`. | +| `TURNSTILE_SITE_KEY` | unset | Cloudflare Turnstile site key (public; sent to the browser). The managed-mode check appears on sign-up, password reset, resend verification, and sign-in after a failed attempt, only when **both** this and `TURNSTILE_SECRET_KEY` are set; otherwise the feature is entirely off. Adds `https://challenges.cloudflare.com` to the CSP `frame-src` (and, under `CSP_POLICY=permissive`, `script-src`). Fails open: if Cloudflare cannot be reached (or answers with a server error), the request goes through; a refusal from Cloudflare (4xx) or a missing token does not. For testing, Cloudflare's dummy keys always pass: site key `1x00000000000000000000AA`, secret `1x0000000000000000000000000000000AA`. | | `TURNSTILE_SECRET_KEY` | unset | Turnstile secret key; server-side only, never logged or shown (the startup report says only set / NOT SET). See `TURNSTILE_SITE_KEY`. | | `TRUST_CLOUDFLARE` | unset | Set to `true` only when the site is served through Cloudflare. The sign-in, sign-up and reset limits and the security log then see each player's real address instead of Cloudflare's. Leave it unset otherwise: anyone can send requests from Cloudflare's addresses, so trusting them on a site not behind Cloudflare would let a visitor pick their own address. | | `TRUSTED_PROXIES` | unset | Other proxies in front of the app, as comma-separated addresses or ranges (`203.0.113.10,198.51.100.0/24`). Private networks, where Docker, Swarm, Traefik and nginx proxies sit, are always trusted. | diff --git a/src/clj/orcpub/routes/auth.clj b/src/clj/orcpub/routes/auth.clj index 5a08fd204..447015699 100644 --- a/src/clj/orcpub/routes/auth.clj +++ b/src/clj/orcpub/routes/auth.clj @@ -14,6 +14,7 @@ [orcpub.email :as email] [orcpub.errors :as errors] [orcpub.fork.auth :as fork-auth] + [orcpub.fork.branding :as branding] [orcpub.fork.user-data :as user-data] [orcpub.index :refer [index]] [orcpub.outbox :as outbox] @@ -189,6 +190,12 @@ (defn base-url [{:keys [scheme headers]}] (str (or (headers "x-forwarded-proto") (name scheme)) "://" (headers "host"))) +(defn- site-url + "The configured public site address (APP_URL), without a trailing slash, or nil. What links in + mail to a stranger are built on, since a request's own headers are the sender's to choose." + [] + (some-> branding/app-url not-empty (s/replace #"/+$" ""))) + (def ^:private turnstile-failed-message "We couldn't confirm you're not a bot. Please try the check again.") @@ -236,6 +243,7 @@ :first-and-last-name (:orcpub.user/first-and-last-name user-for-username) :user-agent (get (:headers request) "user-agent")}))) (catch Exception e + (security/release-notice! notify (:db/id user-for-username) notice) (println "ERROR: could not queue a sign-in attempts notice:" (.getMessage e)))))) ;; One answer for both. Telling somebody the username does not exist made ;; the login form the same membership test the reset endpoint was, and a @@ -349,24 +357,34 @@ e))))) :else (let [verification-key (str (java.util.UUID/randomUUID)) - existing-id (:db/id tx-data)] - (try - @(d/transact - conn - [(merge - tx-data - {:db/id (or existing-id "verification-subject") - :orcpub.user/verified? false - :orcpub.user/verification-key verification-key - :orcpub.user/verification-sent (java.util.Date.)}) - (outbox/email-tx :verification - (email/verification-message (base-url request) params verification-key))]) - (catch Exception e - (println "ERROR: Failed to create verification record:" (.getMessage e)) - (throw (ex-info "Unable to complete registration. Please try again or contact support." - {:error :verification-failed} - e)))) - (outbox/sent!) + existing-id (:db/id tx-data) + ;; A resend may not undo a verification that landed after the caller read the account: + ;; the write is a compare-and-swap on the value read just now, and a verified account is + ;; left alone. + verified-now (when existing-id + (:orcpub.user/verified? (d/entity (d/db conn) existing-id)))] + (when-not (true? verified-now) + (let [queued? (try + @(d/transact + conn + (cond-> [(merge + tx-data + {:db/id (or existing-id "verification-subject") + :orcpub.user/verification-key verification-key + :orcpub.user/verification-sent (java.util.Date.)} + (when-not existing-id {:orcpub.user/verified? false})) + (outbox/email-tx :verification + (email/verification-message (base-url request) params verification-key))] + existing-id (conj [:db/cas existing-id :orcpub.user/verified? verified-now false]))) + true + (catch Exception e + (when-not (odb/cas-failed? e) + (println "ERROR: Failed to create verification record:" (.getMessage e)) + (throw (ex-info "Unable to complete registration. Please try again or contact support." + {:error :verification-failed} + e))) + false))] + (when queued? (outbox/sent!)))) {:status 200}))) (defn- breach-message @@ -406,17 +424,25 @@ (defn- notify-taken-owner! "Mails the owner of `email` that somebody tried to sign up with it, at most once a day. Never throws and never changes the answer: a failure here must not tell a taken address from a new one." - [{:keys [db conn] :as request} email] - (try - (let [owner (user-for-email db email)] - (when-let [notice (and (:db/id owner) - (security/claim-notice! :taken-signup email))] - (outbox/enqueue! conn :signup-attempt - (email/signup-attempt-message - (base-url request) - (assoc notice :email (or (:orcpub.user/email owner) email)))))) - (catch Exception e - (println "ERROR: could not queue a sign-up attempt notice:" (.getMessage e))))) + [{:keys [db conn]} email] + (let [claimed (atom nil)] + (try + ;; GOTCHA: links come from the configured site address, never the request's Host or + ;; X-Forwarded-Proto, which the sender controls: a forged Host would put a phishing link in + ;; mail from us to the account's owner. No configured address, no notice. + (when-let [site (site-url)] + (let [owner (user-for-email db email)] + (when-let [notice (and (:db/id owner) + (security/claim-notice! :taken-signup email))] + (reset! claimed notice) + (outbox/enqueue! conn :signup-attempt + (email/signup-attempt-message + site + (assoc notice :email (or (:orcpub.user/email owner) email))))))) + (catch Exception e + ;; The claim is given back, or the owner is never told about this attempt. + (when-let [notice @claimed] (security/release-notice! :taken-signup email notice)) + (println "ERROR: could not queue a sign-up attempt notice:" (.getMessage e)))))) (defn- answer-taken-email "The answer for a well-formed sign-up whose address already has an account. With a mail server: diff --git a/src/clj/orcpub/security.clj b/src/clj/orcpub/security.clj index 0f0f79cf9..67410114c 100644 --- a/src/clj/orcpub/security.clj +++ b/src/clj/orcpub/security.clj @@ -144,21 +144,36 @@ ;; name behind a connection, or the connection behind a typed name); nil when nothing needs it. (def ^:private sightings (atom {})) -;; The longest window any limit uses; entries older than this belong to nobody. +;; Bounds on the map. Every key is pruned by ITS OWN limit's window (carried as metadata on its +;; entries vector, so the shape other code reads is unchanged); a key with no recorded window falls +;; back to the longest any limit uses. (def ^:private prune-horizon (hours 24)) -(defn- prune [m cutoff] +;; Ceiling on distinct keys. Over it, the stalest keys go; the key being recorded is never refused, +;; since refusing would switch limiting off for whoever floods new keys. +(def ^:private sighting-key-cap 100000) + +(defn- live-entries [ts cutoff] + (filterv #(not (.isBefore ^java.time.Instant (first %) cutoff)) ts)) + +(defn- prune [m] (into {} (keep (fn [[k ts]] - (let [live (filterv #(not (.isBefore ^java.time.Instant (first %) cutoff)) ts)] - (when (seq live) [k live])))) + (let [live (live-entries ts (ago (or (:window (meta ts)) prune-horizon)))] + (when (seq live) [k (with-meta live (meta ts))])))) m)) +(defn- cap-keys [m] + (if (<= (count m) sighting-key-cap) + m + (let [keep-n (long (* 0.9 sighting-key-cap)) + newest (fn [[_ ts]] (.toEpochMilli ^java.time.Instant (first (peek ts))))] + (into {} (take-last keep-n (sort-by newest m)))))) + (defn- recent "The sightings of `k` inside `window`, without recording anything." [k window] - (let [cutoff (ago window)] - (filterv #(not (.isBefore ^java.time.Instant (first %) cutoff)) (get @sightings k)))) + (live-entries (get @sightings k) (ago window))) (defn- sight! "Records one sighting of `k` by `who` and returns those inside `window` from BEFORE it. The @@ -169,10 +184,10 @@ at (time/now) [before _] (swap-vals! sightings (fn [m] - (-> (prune m (ago prune-horizon)) - (update k #(conj (filterv (fn [e] (not (.isBefore ^java.time.Instant (first e) cutoff))) %) - [at who])))))] - (filterv #(not (.isBefore ^java.time.Instant (first %) cutoff)) (get before k)))) + (let [mine (live-entries (get m k) cutoff) + m (-> m (dissoc k) prune cap-keys)] + (assoc m k (with-meta (conj mine [at who]) {:window window})))))] + (live-entries (get before k) cutoff))) (defn under-limit? "True while `k` has been seen fewer than `limit` times inside `window`, and false once it has hit @@ -204,10 +219,11 @@ :names-per-host; window :minute :hour; a fourth element :when-failing refuses only the failing attempt that reaches n), :counted-on :failure (else every request counts), :spend :when-actionable (only when ctx's :actionable delay is true), :turnstile :always or - :after-failure, :answer :uniform (the ordinary 200) :message (the :message) :error (the form's + :after-failure, :challenge-limit [:per-host n window] (caps Cloudflare checks per host), :answer :uniform (the ordinary 200) :message (the :message) :error (the form's own), :notify {:kind :scope :distinct :window} (see record!); or {:none \"why\"}." {:orcpub.routes.auth/login {:limits [[:names-per-host 5 :minute] [:per-name 5 :minute :when-failing]] + :challenge-limit [:per-host 30 :minute] :counted-on :failure :turnstile :after-failure :answer :error @@ -217,6 +233,7 @@ ;; Sized to real use (eight people at one game night, plus retries and typos). :orcpub.routes.auth/register {:limits [[:per-host 10 :hour]] + :challenge-limit [:per-host 30 :minute] :turnstile :always :answer :message :message (str "Too many accounts have been created from this connection in the last hour. " @@ -227,11 +244,13 @@ ;; per-host limit stops somebody walking a list of addresses through the endpoint. :orcpub.routes.auth/re-verify {:limits [[:per-address 3 :hour] [:per-host 10 :hour]] + :challenge-limit [:per-host 30 :minute] :turnstile :always :answer :uniform :spend :when-actionable} :orcpub.routes.auth/send-password-reset {:limits [[:per-address 3 :hour] [:per-host 10 :hour]] + :challenge-limit [:per-host 30 :minute] :turnstile :always :answer :uniform :spend :when-actionable} @@ -298,8 +317,10 @@ (config/turnstile-enabled?)) (defn- post-siteverify - "POSTs to Cloudflare; returns the parsed JSON body as a map. Throws on transport failure, - non-2xx or an unparseable body. A separate fn so tests can with-redefs it." + "POSTs to Cloudflare; returns the parsed JSON body as a map. A 4xx is an answer (Cloudflare + refused the request or the token), so it returns the body, or {} when that is not a map, and + the caller reads it as a failure. Throws on transport failure and on anything else non-2xx (5xx + is Cloudflare being down). A separate fn so tests can with-redefs it." [token remote-ip] (let [{:keys [status body]} (client/post turnstile-endpoint @@ -312,9 +333,10 @@ :throw-exceptions false :cookie-policy :none :redirect-strategy :none})] - (if (<= 200 status 299) - body - (throw (ex-info "siteverify non-2xx" {:status status}))))) + (cond + (<= 200 status 299) body + (<= 400 status 499) (if (map? body) body {}) + :else (throw (ex-info "siteverify unavailable" {:status status}))))) ;; A sustained outage would otherwise log a line per signup. (def ^:private turnstile-log-window-ms 60000) @@ -327,11 +349,18 @@ ;; Reason is an exception class name or HTTP status: never the secret or the token. (println "turnstile: siteverify unreachable, letting signup through -" reason)))) +(defn- blank-token? + "True for no token: nil, blank text, or anything that is not text (a number, map or vector sent + in the JSON body)." + [token] + (or (not (string? token)) (s/blank? token))) + (defn turnstile-verify "Checks a Turnstile `token` for `remote-ip`. Returns :pass, :fail, or :unreachable (the caller - treats :unreachable as a pass). A blank token is :fail without calling Cloudflare." + treats :unreachable as a pass; only a transport failure or a 5xx is that). A blank or non-text + token is :fail without calling Cloudflare." [token remote-ip] - (if (s/blank? token) + (if (blank-token? token) :fail (try (let [result (post-siteverify token remote-ip)] @@ -367,11 +396,16 @@ (let [now (System/currentTimeMillis)] (swap! login-challenges (fn [m] - (assoc (if (< login-challenge-cap (count m)) - {} - (into {} (remove (fn [[_ until]] (< until now))) m)) - (login-challenge-key typed-name remote-ip) - (+ now login-challenge-ms)))))) + (let [k (login-challenge-key typed-name remote-ip) + m (if (>= (count m) login-challenge-cap) + (into {} (remove (fn [[_ until]] (< until now))) m) + m)] + ;; Still full of LIVE marks: leave them all and skip this one. Clearing them would + ;; let a flood of invented names lift every real challenge. Skipping is safe: an + ;; unmarked pair gets the one unchallenged try a fresh connection already gets. + (if (and (>= (count m) login-challenge-cap) (not (contains? m k))) + m + (assoc m k (+ now login-challenge-ms)))))))) nil) (defn clear-login-challenge! [typed-name remote-ip] @@ -394,15 +428,29 @@ (note-refusal! (first k) (second k)) {:reason :limit :limit (first k)}) +(defn- challenge-limit-refusal + "A limit refusal when this host has already used the route's :challenge-limit of Cloudflare + checks, else nil. Counts the attempt, so it is called only when a check is about to be made. + Its own key, apart from the route's limits: a failed challenge spends none of those." + [route p {:keys [ip]}] + (when-let [[scope n window] (:challenge-limit p)] + (let [k [(keyword (str (name route) "-challenge")) (normalise ip)]] + (when (full? scope n (sight! k (windows window) nil)) + (refuse! k))))) + (defn- challenge-refusal - "{:reason :turnstile :blank? ...} when the policy wants the challenge for this request, it is on, - and the token fails it. :unreachable is not a refusal." - [p {:keys [token ip typed-name]}] + "A refusal when the policy wants the challenge for this request, it is on, and the token fails + it: {:reason :turnstile :blank? ...}, or a limit refusal when the host has asked for too many + checks (no call is made then). :unreachable is not a refusal." + [route p {:keys [token ip typed-name] :as ctx}] (when (and (:turnstile p) (turnstile-enabled?) - (or (= :always (:turnstile p)) (login-challenge-required? typed-name ip)) - (= :fail (turnstile-verify token ip))) - {:reason :turnstile :blank? (s/blank? token)})) + (or (= :always (:turnstile p)) (login-challenge-required? typed-name ip))) + (if (blank-token? token) + {:reason :turnstile :blank? true} + (or (challenge-limit-refusal route p ctx) + (when (= :fail (turnstile-verify token ip)) + {:reason :turnstile :blank? false}))))) (defn- inspect-limits "The first limit already full, without counting this request: for forms that count failures." @@ -447,7 +495,7 @@ (when (= :after-failure (:turnstile p)) (mark-login-challenge! (:typed-name ctx) (:ip ctx))) r)) - (challenge-refusal p ctx) + (challenge-refusal route p ctx) (when-not on-failure? (spend-limits route p ctx)))))) (defn record! @@ -491,11 +539,12 @@ trips anything and so never appears in the refusals at all -- this is the only place it shows up." [] - (->> @sightings - (reduce (fn [acc [k ts]] - (let [limit (if (vector? k) (first k) k)] - (update acc limit (fnil max 0) (count ts)))) - {}))) + (let [cutoff (ago (hours 1))] + (->> @sightings + (reduce (fn [acc [k ts]] + (let [limit (if (vector? k) (first k) k)] + (update acc limit (fnil max 0) (count (live-entries ts cutoff))))) + {})))) (defn- caps "What each hourly limit allows, read off the policy table (plus the image probe)." @@ -568,3 +617,21 @@ (fn [m] (claimed (into {} (remove (fn [[_ e]] (.isBefore ^java.time.Instant (:seen e) day-ago))) m))))] (:claimed (get after entry-key)))) + +(defn release-notice! + "Gives back a claim from `claim-notice!` whose mail could not be queued, so the notice is not + counted as sent and the next attempt is due again: drops the latest send time, restores the + attempts that were waiting (`notice` is what the claim returned) and, for a first notice, the + not-yet-notified state." + [kind k notice] + (swap! notice-state + (fn [m] + (if-let [e (get m [kind k])] + (assoc m [kind k] + (-> e + (update :sent #(if (seq %) (pop %) %)) + (assoc :pending (:since-last notice 1)) + (assoc :notified? (contains? notice :since-last)) + (dissoc :claimed))) + m))) + nil) diff --git a/src/cljs/orcpub/dnd/e5/views/auth.cljs b/src/cljs/orcpub/dnd/e5/views/auth.cljs index af8df397b..e11631606 100644 --- a/src/cljs/orcpub/dnd/e5/views/auth.cljs +++ b/src/cljs/orcpub/dnd/e5/views/auth.cljs @@ -545,11 +545,13 @@ (defn verify-sent [] (email-sent [:div - [:span "We sent a verification email to "] + ;; Conditional on purpose, like password-reset-sent: sign-up and resend answer the same for an + ;; address that is taken or unknown, so this page cannot claim a mail went to it. + [:span "If a verification email can be sent to "] ;; Ink, not .red. Red is what a fault looks like on every one of these ;; pages, and this is the address somebody just typed correctly. [:span.auth-emphasis @(subscribe [:temp-email])] - [:span ". You must verify to complete registration and the link we sent will only be valid for 24 hours."] + [:span ", it is on its way. You must verify to complete registration and the link will only be valid for 24 hours."] [:span " "] [:span "Remember to check your spam folder."]])) diff --git a/test/clj/orcpub/registration_email_test.clj b/test/clj/orcpub/registration_email_test.clj index 36d276c91..d35c31a99 100644 --- a/test/clj/orcpub/registration_email_test.clj +++ b/test/clj/orcpub/registration_email_test.clj @@ -11,6 +11,7 @@ [datomic.api :as d] [orcpub.email :as email] [orcpub.errors :as errors] + [orcpub.fork.branding :as branding] [orcpub.outbox :as outbox] [orcpub.routes :as routes] [orcpub.routes.auth :as auth] @@ -25,7 +26,8 @@ (fn [f] (reset! @#'security/sightings {}) (reset! @#'security/notice-state {}) - (with-redefs [email/configured? (constantly true)] + (with-redefs [email/configured? (constantly true) + branding/app-url "https://site.example"] (binding [errors/*error-prefix* "TEST_ERROR:"] (f))) (reset! @#'security/sightings {}))) @@ -158,7 +160,7 @@ text (body (:message (first notices)))] (is (= 1 (count notices)) "two attempts close together, one notice") (is (= "newcomer@test.com" (:to (first notices)))) - (is (str/includes? text "/login") "a way to sign in") + (is (str/includes? text "https://site.example/pages/login-page") "a way to sign in, on the configured site") (is (str/includes? text "send-password-reset") "and to reset the password") (doseq [secret ["hunter2hunter2" key "newcomer" "intruder"]] (is (not (str/includes? text secret)) (str "no " secret))) @@ -194,3 +196,62 @@ (deftest the-address-check-route-is-gone (is (not-any? #(= "/check-email" (:path %)) routes/routes)) (is (nil? (resolve 'orcpub.routes.auth/check-email)))) + +(deftest the-notice-links-to-the-configured-site-not-the-request-host + (let [conn (fresh-conn) + _ (sign-up conn "newcomer" "newcomer@test.com") + forged (-> (register-request conn) + (assoc :headers {"host" "evil.example" "x-forwarded-proto" "http"}) + (assoc-in [:json-params :username] "intruder") + (assoc-in [:json-params :email] "newcomer@test.com") + (assoc-in [:json-params :verify-email] "newcomer@test.com")) + _ (auth/register forged) + text (body (:message (first (filter #(= :signup-attempt (:kind %)) (queued conn)))))] + (is (str/includes? text "https://site.example/")) + (is (not (str/includes? text "evil.example")) "nothing the sender controls reaches the links"))) + +(deftest no-configured-site-means-no-notice + (let [conn (fresh-conn)] + (sign-up conn "newcomer" "newcomer@test.com") + (with-redefs [branding/app-url ""] + (is (= {:status 200} (sign-up conn "intruder" "newcomer@test.com")) "the answer is unchanged")) + (is (empty? (filter #(= :signup-attempt (:kind %)) (queued conn)))))) + +(deftest a-failed-enqueue-does-not-spend-the-notice + (let [conn (fresh-conn)] + (sign-up conn "newcomer" "newcomer@test.com") + (with-redefs [outbox/enqueue! (fn [& _] (throw (ex-info "db down" {})))] + (is (= {:status 200} (sign-up conn "intruder" "newcomer@test.com")))) + (sign-up conn "intruder2" "newcomer@test.com") + (is (= 1 (count (filter #(= :signup-attempt (:kind %)) (queued conn)))) + "the next attempt still gets the notice the failed one could not send"))) + +(deftest a-resend-does-not-unverify-an-account-verified-meanwhile + (let [conn (fresh-conn) + _ (auth/register (register-request conn)) + id (:db/id (find-user (d/db conn) "newcomer")) + stale {:db/id id :orcpub.user/verified? false}] + @(d/transact conn [[:db/add id :orcpub.user/verified? true]]) + (outbox/send-due! conn (constantly true) #(Date.)) + ;; the handler read `stale` at request start; the account verified before it wrote + (with-redefs [auth/user-for-email (constantly stale)] + (is (= {:status 200} (auth/re-verify (re-verify-request conn "newcomer@test.com"))))) + (let [after (find-user (d/db conn) "newcomer")] + (is (true? (:orcpub.user/verified? after)) "still verified") + (is (empty? (filter #(= :verification (:kind %)) (queued conn))) "and no mail was queued")))) + +(deftest the-verified-write-is-conditional-on-the-value-read + (let [conn (fresh-conn) + _ (auth/register (register-request conn)) + id (:db/id (find-user (d/db conn) "newcomer")) + reads (atom 0) + real-entity d/entity] + ;; verification lands between the fresh read inside do-verification and its transaction + (with-redefs [d/entity (fn [db e] + (let [r (real-entity db e)] + (when (= 1 (swap! reads inc)) + @(d/transact conn [[:db/add id :orcpub.user/verified? true]])) + r))] + (is (= {:status 200} (auth/do-verification (re-verify-request conn "newcomer@test.com") + {} conn {:db/id id})))) + (is (true? (:orcpub.user/verified? (find-user (d/db conn) "newcomer"))) "the swap refused to un-verify"))) diff --git a/test/clj/orcpub/routes_test.clj b/test/clj/orcpub/routes_test.clj index daba5422c..3232b12c7 100644 --- a/test/clj/orcpub/routes_test.clj +++ b/test/clj/orcpub/routes_test.clj @@ -406,6 +406,17 @@ (is (= {:status 200} (auth/send-password-reset {:query-params {:email "someone@example.com"} :db nil :conn nil :remote-addr "9.9.9.9"}))))) +(defn- await-count + "Waits up to `timeout-ms` for `posted` to hold `n` messages (the notice is queued on another + thread), polling rather than sleeping a fixed time. Returns the messages." + [posted n timeout-ms] + (let [deadline (+ (System/currentTimeMillis) timeout-ms)] + (loop [] + (when (and (< (count @posted) n) (< (System/currentTimeMillis) deadline)) + (Thread/sleep 5) + (recur))) + @posted)) + (defn- fail-from [ip typed request] (auth/bad-credentials-response nil typed ip request)) @@ -421,23 +432,20 @@ (with-redefs [auth/find-user-by-username-or-email (constantly account)] (fail-from "1.1.1.1" "kaylee" request) (fail-from "2.2.2.2" "kaylee" request) - (Thread/sleep 60) - (is (empty? @posted)))) + (is (empty? (await-count posted 1 100)) "nothing arrives inside a short bounded wait"))) (testing "an address with no account here is told nothing at all" (with-redefs [auth/find-user-by-username-or-email (constantly nil)] (dotimes [i 3] (fail-from (str "3.3.3." i) "nobody" request)) - (Thread/sleep 60) - (is (empty? @posted)))) + (is (empty? (await-count posted 1 100)) "nothing arrives inside a short bounded wait"))) (testing "three places at once reach the address on the account; the answer is bad credentials either way" (with-redefs [auth/find-user-by-username-or-email (constantly account)] (is (= errors/bad-credentials (-> (fail-from "3.3.3.3" "kaylee" request) :body :error))) - (let [message (do (Thread/sleep 100) (first @posted))] + (let [message (first (await-count posted 1 5000))] (is (= "kaylee@serenity.example" (:to message))) (is (re-find #"https://example\.test" (pr-str (:body message))) "linking to this site") (is (not (re-find #"more attempts" (pr-str (:body message)))) "the first says nothing of a count")) (fail-from "4.4.4.4" "kaylee" request) - (Thread/sleep 100) - (is (= 1 (count @posted)) "a further attempt inside the gap sends nothing more")))))) + (is (= 1 (count (await-count posted 2 200))) "a further attempt inside the gap sends nothing more")))))) (deftest a-follow-up-notice-says-how-many-attempts-came-in (doseq [[label message] diff --git a/test/clj/orcpub/security_test.clj b/test/clj/orcpub/security_test.clj index 75862e611..1c3fa3868 100644 --- a/test/clj/orcpub/security_test.clj +++ b/test/clj/orcpub/security_test.clj @@ -2,6 +2,7 @@ (:require [clojure.string :as str] [clojure.test :refer [deftest is testing use-fixtures]] [datomic.api :as d] + [clj-http.client :as client] [orcpub.config :as config] [orcpub.email :as email] [orcpub.errors :as errors] @@ -135,9 +136,33 @@ (is (= :pass (s/turnstile-verify "t" "1.2.3.4")))) (with-redefs [s/post-siteverify (fn [& _] {:success false :error-codes ["x"]})] (is (= :fail (s/turnstile-verify "t" "1.2.3.4")))) - (with-redefs [s/post-siteverify (fn [& _] (throw (ex-info "siteverify non-2xx" {:status 500})))] + (with-redefs [s/post-siteverify (fn [& _] (throw (ex-info "siteverify unavailable" {:status 500})))] (is (= :unreachable (s/turnstile-verify "t" "1.2.3.4"))))) +(defn- verify-with-http + "turnstile-verify against a stubbed HTTP client answering `response` (a map, or a function that throws)." + [response] + (with-redefs [config/turnstile-secret-key (constantly secret) + client/post (fn [& _] (if (fn? response) (response) response))] + (s/turnstile-verify "t" "1.2.3.4"))) + +(deftest only-a-transport-failure-or-a-server-error-fails-open + (is (= :fail (verify-with-http {:status 400 :body {:success false :error-codes ["invalid-input-response"]}})) + "Cloudflare refusing the token is a refusal") + (is (= :fail (verify-with-http {:status 400 :body "bad"})) "even with a body that is not JSON") + (is (= :fail (verify-with-http {:status 403 :body nil}))) + (is (= :unreachable (verify-with-http {:status 500 :body {}})) "Cloudflare being down") + (is (= :unreachable (verify-with-http {:status 503 :body nil}))) + (is (= :unreachable (verify-with-http #(throw (java.net.SocketTimeoutException. "slow"))))) + (is (= :pass (verify-with-http {:status 200 :body {:success true}})))) + +(deftest a-token-that-is-not-text-is-a-missing-token + (let [calls (atom 0)] + (with-redefs [s/post-siteverify (fn [& _] (swap! calls inc) {:success true})] + (doseq [t [42 {:a 1} ["x"] true]] + (is (= :fail (s/turnstile-verify t "1.2.3.4")) (pr-str t))) + (is (zero? @calls) "no HTTP call")))) + (deftest only-both-keys-enable-it (doseq [[site secret-key expected] [[nil nil false] ["s" nil false] [nil "k" false] ["s" "k" true]]] (with-redefs [config/turnstile-site-key (constantly site) @@ -197,6 +222,10 @@ (pos? n) (#{:minute :hour} window))) (:limits p))) (is (#{:always :after-failure nil} (:turnstile p))) + (when (:turnstile p) + (let [[scope n window] (:challenge-limit p)] + (is (and (= :per-host scope) (pos? n) (#{:minute :hour} window)) + "a challenge needs a bound on the checks it makes"))) (is (#{:uniform :message :error} (:answer p))) (is (or (not= :message (:answer p)) (seq (:message p))) "a message to show"))))))) @@ -323,6 +352,36 @@ answer))] [(f) @calls]))) +(defn- challenge-ctx [route i] + {:ip "5.5.5.5" :address (str "u" i "@example.com") :typed-name "same-name" :token "tok"}) + +(deftest the-checks-a-host-can-make-are-bounded-before-cloudflare-is-called + (doseq [[route p] s/auth-guards + :let [[_ n window] (:challenge-limit p)] + :when n] + (testing (str route " " n) + (reset! @#'s/sightings {}) + (reset! @#'s/login-challenges {}) + (let [calls (atom 0)] + (with-redefs [s/turnstile-enabled? (constantly true) + s/post-siteverify (fn [& _] (swap! calls inc) {:success true})] + (when (= :after-failure (:turnstile p)) + (s/mark-login-challenge! "same-name" "5.5.5.5")) + (let [results (vec (for [i (range (inc n))] (s/guard route (challenge-ctx route i))))] + (is (= n @calls) "the N+1th attempt made no call") + (is (= {:reason :limit :limit (keyword (str (name route) "-challenge"))} (peek results)) + "and is refused as a limit")) + (testing "another host is unaffected" + (is (not= :limit (:reason (s/guard route (assoc (challenge-ctx route 0) :ip "6.6.6.6"))))))))))) + +(deftest a-failed-challenge-spends-no-allowance-but-counts-as-a-check + (reset! @#'s/sightings {}) + (with-redefs [s/turnstile-enabled? (constantly true) + s/post-siteverify (fn [& _] {:success false})] + (is (= :turnstile (:reason (s/guard :orcpub.routes.auth/register {:ip "9.9.9.9" :token "bad"})))) + (is (nil? (get @@#'s/sightings [:orcpub.routes.auth/register-per-host "9.9.9.9"]))) + (is (= 1 (count (get @@#'s/sightings [:register-challenge "9.9.9.9"])))))) + (defn- lookups-fail-the-test [& _] (throw (AssertionError. "looked the address up before the challenge"))) (deftest the-challenge-is-checked-before-any-allowance-or-lookup @@ -337,7 +396,8 @@ (is (str/includes? (first (get-in resp [:body :general])) "not a bot")) (is (= [:general] (keys (:body resp))) "a :general error, no field key") (is (= 1 calls)) - (is (empty? @@#'s/sightings) "no allowance was spent") + (is (empty? (remove (fn [[k]] (str/ends-with? (name (first k)) "-challenge")) @@#'s/sightings)) + "no allowance was spent (the check itself is counted apart)") (is (zero? @worked)))))) (testing (str route ": a missing token says the script is blocked, without calling Cloudflare") (in-world @@ -500,3 +560,70 @@ (for [i (range 5)] (do (at (* i 61)) (some? (s/claim-notice! :k "x")))))) (at (+ (* 24 60) 1)) (is (= {:since-last 2} (s/claim-notice! :k "x")) "the first notice has left the day"))))) + +;; ---- memory bounds ---- + +(defn- ts-ago [minutes] (.minus (time/now) (time/minutes minutes))) + +(deftest each-key-is-pruned-by-its-own-window + (let [fresh (atom {})] + (reset! @#'s/sightings + {[:short "a"] (with-meta [[(ts-ago 5) nil]] {:window (time/minutes 1)}) + [:long "b"] (with-meta [[(ts-ago 5) nil]] {:window (time/hours 1)})}) + (#'s/sight! [:other "c"] (time/minutes 1) nil) + (is (nil? (get @@#'s/sightings [:short "a"])) "past its own minute, though inside any global horizon") + (is (some? (get @@#'s/sightings [:long "b"])) "still inside its hour") + (is (some? fresh)))) + +(deftest the-sightings-map-has-a-ceiling-on-keys + (with-redefs-fn {#'s/sighting-key-cap 10} + (fn [] + (dotimes [i 40] (#'s/sight! [:flood (str "k" i)] (time/hours 1) nil)) + (is (<= (count @@#'s/sightings) 10)) + (is (some? (get @@#'s/sightings [:flood "k39"])) "the key just recorded is always kept") + (is (nil? (get @@#'s/sightings [:flood "k0"])) "the oldest went first") + (testing "limiting still works for the current key at the ceiling" + (dotimes [_ 3] (#'s/sight! [:flood "mine"] (time/hours 1) nil)) + (is (= 3 (count (#'s/sight! [:flood "mine"] (time/hours 1) nil)))))))) + +(deftest login-marks-are-bounded-without-clearing-live-ones + (with-redefs [s/turnstile-enabled? (constantly true)] + (with-redefs-fn {#'s/login-challenge-cap 3} + (fn [] + (doseq [n ["a" "b" "c"]] (s/mark-login-challenge! n "1.1.1.1")) + (s/mark-login-challenge! "d" "1.1.1.1") + (is (= 3 (count @@#'s/login-challenges)) "full of live marks: no growth") + (is (every? #(s/login-challenge-required? % "1.1.1.1") ["a" "b" "c"]) "and none cleared") + (is (false? (s/login-challenge-required? "d" "1.1.1.1")) "the newcomer is simply unmarked") + (testing "expired marks make room first" + (swap! @#'s/login-challenges assoc (#'s/login-challenge-key "a" "1.1.1.1") 0) + (s/mark-login-challenge! "d" "1.1.1.1") + (is (true? (s/login-challenge-required? "d" "1.1.1.1"))) + (is (true? (s/login-challenge-required? "b" "1.1.1.1")))) + (testing "a pair already marked is refreshed even when full" + (s/mark-login-challenge! "b" "1.1.1.1") + (is (= 3 (count @@#'s/login-challenges)))))))) + +(deftest busiest-counts-only-the-last-hour + (reset! @#'s/sightings + {[:x "1"] (with-meta (vec (repeat 5 [(ts-ago 90) nil])) {:window (time/hours 24)}) + [:y "1"] (with-meta (vec (repeat 2 [(ts-ago 5) nil])) {:window (time/hours 1)})}) + (is (= {:x 0 :y 2} (s/busiest)))) + +(deftest a-notice-whose-mail-could-not-be-queued-is-given-back + (let [claim #(s/claim-notice! :taken-signup "x@y.z")] + (let [first-notice (claim)] + (is (= {} first-notice)) + (s/release-notice! :taken-signup "x@y.z" first-notice) + (is (= {} (claim)) "due again at once, as a first notice")) + (reset! @#'s/notice-state {}) + (let [[now-fn at] (clock-from t0)] + (with-redefs [time/now now-fn] + (claim) + (at 1) + (is (nil? (claim)) "one more attempt waits") + (at (* 7 60)) + (let [later (claim)] + (is (= {:since-last 2} later)) + (s/release-notice! :taken-signup "x@y.z" later) + (is (= {:since-last 3} (claim)) "and the attempts that were waiting are not lost")))))) diff --git a/test/cljs/orcpub/dnd/e5/events_test.cljs b/test/cljs/orcpub/dnd/e5/events_test.cljs index 40db850eb..89d636c2c 100644 --- a/test/cljs/orcpub/dnd/e5/events_test.cljs +++ b/test/cljs/orcpub/dnd/e5/events_test.cljs @@ -2229,3 +2229,11 @@ ::char5e/rest-result {:id "7" :before {:orcpub.entity/values {}}}}) (effects-of [::char5e/toggle-feature-used "7" ::units5e/dawn "Javelin of Lightning"] [::char5e/save-character-throttled]) (is (nil? (::char5e/rest-result @app-db)) "so Undo cannot overwrite the edit")) + +(deftest a-resend-carries-the-turnstile-token + ;; The server refuses a resend with no token when Turnstile is on, so :re-verify must keep the + ;; challenge-request interceptor that copies the widget's token into the query. + (reset! app-db {:turnstile-token "tok-resend"}) + (let [fx (effects-of [:re-verify {:email "a@b.com"}] [:http])] + (is (= "tok-resend" (get-in fx [:http :query-params :turnstile-token]))) + (is (= "a@b.com" (get-in fx [:http :query-params :email])) "next to the address it was typed with"))) From ede36a0888639abad0a01c616a2f4d31beea1af0 Mon Sep 17 00:00:00 2001 From: codeGlaze Date: Wed, 4 Nov 2026 23:43:04 +0000 Subject: [PATCH 23/27] Build account-mail links from the configured site URL Verification, password-reset, password-changed, sign-in-attempts and email-change mails now use APP_URL when set (mail-base-url), falling back to the request's Host only when it is not. The boot report warns once when APP_URL is unset. --- docs/ENVIRONMENT.md | 2 +- src/clj/orcpub/config.clj | 12 +++++--- src/clj/orcpub/routes/auth.clj | 21 +++++++++---- test/clj/orcpub/config_report_test.clj | 6 ++++ test/clj/orcpub/registration_email_test.clj | 33 +++++++++++++++++++++ 5 files changed, 63 insertions(+), 11 deletions(-) diff --git a/docs/ENVIRONMENT.md b/docs/ENVIRONMENT.md index 21cfb4fc6..1611e6e9b 100644 --- a/docs/ENVIRONMENT.md +++ b/docs/ENVIRONMENT.md @@ -202,7 +202,7 @@ the table in half. Plain ASCII, no colour: it is read in aggregators as often as | Variable | Default | Description | |----------|---------|-------------| | `PORTRAIT_ARTISTS` | — | JSON of artist credits and accounts (see `ARTISTS.md`). An `account` email gets an artist account and a welcome email at startup. | -| `APP_URL` | — | The site's address, used for links in artist emails (sent at startup, with no request to read it from). | +| `APP_URL` | — | The site's address, used for links in artist emails (sent at startup, with no request to read it from) and in every account email (verification, password reset, notices). Set it in production: unset, those links follow the request's Host header, which a sender can forge, and the boot report warns. | | `EMAIL_ADMIN_TO` | `EMAIL_ERRORS_TO`, then `APP_SUPPORT_EMAIL` | Who hears about artist account and credit changes. | | `PORTRAIT_STORE_DIR` | `orcpub-portraits` in the system temp directory | Where the server keeps its drawings of shared-link portraits, one file per character. A shared volume lets several containers draw each portrait once; without one each container draws it on first request and keeps the file. In Docker, mount a shared volume at `/var/lib/orcpub/portraits` (the image creates it for the app's user) and set this to that path. A failed write is logged and the drawing is still served. Derived files: losing them only means drawing again. | diff --git a/src/clj/orcpub/config.clj b/src/clj/orcpub/config.clj index bd020d230..7397227f7 100644 --- a/src/clj/orcpub/config.clj +++ b/src/clj/orcpub/config.clj @@ -652,12 +652,15 @@ "The boot report's DEPLOYMENT block, as lines. Takes `:crash-dir` and `:alert-dir`, the resolved folders for crash files and unsent alerts (either nil when unknown), `:max-heap-bytes`, the most memory Java may use (nil leaves the line out), and `:admin`, `alert-address`'s answer - (the line appears when the key is given). Says where those files land, flags a folder - inside the container with the mount that moves it, gives the memory limit, and ends with - `deployment-notes`." + (the line appears when the key is given), `:app-url` (a warning when given and empty). Says where + those files land, flags a folder inside the container with the mount that moves it, gives the + memory limit, and ends with `deployment-notes`." [{:keys [crash-dir alert-dir max-heap-bytes admin] :as dirs}] (let [inside? #(and % (str/starts-with? % "/var/lib/orcpub/"))] (concat + ;; The one startup warning about APP_URL: printed with the boot report, not per request. + (when (and (contains? dirs :app-url) (str/blank? (:app-url dirs))) + ["Warning: APP_URL is not set, so links in account emails follow the request's Host header. Set APP_URL in production."]) (when (contains? dirs :admin) [(if admin (str "Admin email: " (:address admin) " (from " (:from admin) ")") @@ -733,7 +736,8 @@ lines (vec (report-lines (report) actual @branding/ignored (deployment-lines (assoc dirs :max-heap-bytes (.maxMemory (Runtime/getRuntime)) - :admin (alert-address))))) + :admin (alert-address) + :app-url branding/app-url)))) saved (some-> (report-dir dirs) (save-report! lines))] ;; One write, then flush. Printed line by line, Jetty's own logging interleaved with it ;; and cut the table in half -- buffered stdout against unbuffered stderr in the same diff --git a/src/clj/orcpub/routes/auth.clj b/src/clj/orcpub/routes/auth.clj index 447015699..795756c3d 100644 --- a/src/clj/orcpub/routes/auth.clj +++ b/src/clj/orcpub/routes/auth.clj @@ -196,6 +196,15 @@ [] (some-> branding/app-url not-empty (s/replace #"/+$" ""))) +(defn mail-base-url + "The address links in account mail are built on: the configured site URL (APP_URL) when set, else + the request's own scheme and Host (`base-url`). Every mail link goes through here. GOTCHA: the + request fallback exists so an install without APP_URL still works; those headers are the + sender's to choose, so a production site sets APP_URL (the boot report says so when it is + not). The taken-address notice does NOT fall back: it uses `site-url` and sends nothing without it." + [request] + (or (site-url) (base-url request))) + (def ^:private turnstile-failed-message "We couldn't confirm you're not a bot. Please try the check again.") @@ -237,7 +246,7 @@ (try (outbox/enqueue! (:conn request) :sign-in-attempts (email/sign-in-attempts-message - (base-url request) + (mail-base-url request) (merge notice {:email (:orcpub.user/email user-for-username) :first-and-last-name (:orcpub.user/first-and-last-name user-for-username) @@ -374,7 +383,7 @@ :orcpub.user/verification-sent (java.util.Date.)} (when-not existing-id {:orcpub.user/verified? false})) (outbox/email-tx :verification - (email/verification-message (base-url request) params verification-key))] + (email/verification-message (mail-base-url request) params verification-key))] existing-id (conj [:db/cas existing-id :orcpub.user/verified? verified-now false]))) true (catch Exception e @@ -634,7 +643,7 @@ :orcpub.user/password-reset-sent (java.util.Date.)} (outbox/email-tx :password-reset (email/reset-message - (base-url request) + (mail-base-url request) {:first-and-last-name (preferred-name-of (d/entity (d/db conn) user-id)) :email email} key))] @@ -714,7 +723,7 @@ (and request (:orcpub.user/email user)) (conj (notice-tx :password-changed #(email/password-changed-message - (base-url request) + (mail-base-url request) {:email (:orcpub.user/email user) :first-and-last-name (:orcpub.user/first-and-last-name user) :user-agent (get (:headers request) "user-agent")}))) @@ -878,7 +887,7 @@ (try (outbox/enqueue! conn :email-change-verification (email/email-change-verification-message - (base-url request) + (mail-base-url request) {:email new-email :username username :preferred-name (preferred-name-of user)} (:orcpub.user/verification-key user))) @@ -898,7 +907,7 @@ :orcpub.user/verification-sent now} (outbox/email-tx :email-change-verification (email/email-change-verification-message - (base-url request) + (mail-base-url request) {:email new-email :username username :preferred-name (preferred-name-of user)} verification-key)) diff --git a/test/clj/orcpub/config_report_test.clj b/test/clj/orcpub/config_report_test.clj index 8238b4778..adbe56c26 100644 --- a/test/clj/orcpub/config_report_test.clj +++ b/test/clj/orcpub/config_report_test.clj @@ -360,3 +360,9 @@ (testing "a /host-log folder is named as the host's /var/log" (is (= "This report is saved in /var/log/orcpub/startup-report.txt on the host" (config/saved-line "/host-log/orcpub/startup-report.txt"))))) + +(deftest the-report-warns-once-when-app-url-is-unset + (let [warns #(filter (fn [l] (str/includes? l "APP_URL is not set")) (config/deployment-lines %))] + (is (= 1 (count (warns {:app-url ""})))) + (is (empty? (warns {:app-url "https://site.test"}))) + (is (empty? (warns {})) "callers that do not pass it get no warning"))) diff --git a/test/clj/orcpub/registration_email_test.clj b/test/clj/orcpub/registration_email_test.clj index d35c31a99..d4b4674ca 100644 --- a/test/clj/orcpub/registration_email_test.clj +++ b/test/clj/orcpub/registration_email_test.clj @@ -255,3 +255,36 @@ (is (= {:status 200} (auth/do-verification (re-verify-request conn "newcomer@test.com") {} conn {:db/id id})))) (is (true? (:orcpub.user/verified? (find-user (d/db conn) "newcomer"))) "the swap refused to un-verify"))) + +;; Links in mail are built on APP_URL when it is set; the request's Host and X-Forwarded-Proto are +;; the sender's to choose, so they are only a fallback for an install that has not set it. +(def ^:private forged + {:scheme :http :headers {"host" "evil.example" "x-forwarded-proto" "https"}}) + +(defn- reset-link-base + "The base address the password-reset mail for a new account is built on, for forged `request`." + [request] + (let [conn (fresh-conn) + _ (auth/register (register-request conn)) + id (:db/id (find-user (d/db conn) "newcomer")) + base (atom nil)] + (with-redefs [email/reset-message (fn [b _ _] (reset! base b) {:to "newcomer@test.com" :subject "r" :body []})] + (auth/do-send-password-reset id "newcomer@test.com" conn request)) + @base)) + +(deftest reset-mail-links-to-the-configured-site-not-the-forged-host + (is (= "https://site.example" (reset-link-base forged))) + (with-redefs [branding/app-url "https://site.example/"] + (is (= "https://site.example" (reset-link-base forged)) "a trailing slash is trimmed"))) + +(deftest verification-mail-links-to-the-configured-site-not-the-forged-host + (let [conn (fresh-conn)] + (auth/register (-> (register-request conn) (merge forged))) + (let [text (body (:message (first (filter #(= :verification (:kind %)) (queued conn)))))] + (is (str/includes? text "https://site.example/")) + (is (not (str/includes? text "evil.example")))))) + +(deftest without-a-configured-site-mail-follows-the-request + (with-redefs [branding/app-url ""] + (is (= "https://evil.example" (reset-link-base forged))) + (is (= "https://example.test" (reset-link-base {:scheme :https :headers {"host" "example.test"}}))))) From 8aedfe9b60e70248e75e1c46d34e9db95a2c9e8e Mon Sep 17 00:00:00 2001 From: codeGlaze Date: Wed, 4 Nov 2026 23:55:41 +0000 Subject: [PATCH 24/27] Put the abuse limits' state behind a LimitStore, with an optional shared Redis store Sightings, sign-in challenge marks and notice claims go through one small protocol. Memory stays the default and behaves as before. With REDIS_URL set, a Redis store (carmine 3.4.1, loaded only then) shares them between app containers; any call that fails or times out is answered from memory, warned about at most once a minute, so limits never switch off. --- .env.example | 4 + docker-compose.yaml | 2 + docs/ENVIRONMENT.md | 1 + project.clj | 2 + scripts/swarm.sh | 1 + src/clj/orcpub/config.clj | 10 +- src/clj/orcpub/security.clj | 240 +++++++++++++++++------- src/clj/orcpub/security/redis_store.clj | 120 ++++++++++++ test/clj/orcpub/security_store_test.clj | 231 +++++++++++++++++++++++ 9 files changed, 543 insertions(+), 68 deletions(-) create mode 100644 src/clj/orcpub/security/redis_store.clj create mode 100644 test/clj/orcpub/security_store_test.clj diff --git a/.env.example b/.env.example index e8a28442c..1b92dbe37 100644 --- a/.env.example +++ b/.env.example @@ -214,6 +214,10 @@ PROFILE_ENCRYPTION_KEYS= # site key 1x00000000000000000000AA secret 1x0000000000000000000000000000000AA # TURNSTILE_SITE_KEY= # TURNSTILE_SECRET_KEY= +# Where the abuse limits are counted. Optional: leave unset to count in each app container's own +# memory. Set it when MORE THAN ONE app container serves the site, so the limits are shared +# (redis://[:password@]host:6379). If Redis fails, each container counts in memory meanwhile. +# REDIS_URL= # --- Branding (optional) --- # The site's name, logos, links and email identity. Each has a default in fork/branding.clj; diff --git a/docker-compose.yaml b/docker-compose.yaml index a22fac238..eaf160a69 100644 --- a/docker-compose.yaml +++ b/docker-compose.yaml @@ -109,6 +109,8 @@ services: ORCPUB_PWNED_CHECK: ${ORCPUB_PWNED_CHECK:-} TURNSTILE_SITE_KEY: ${TURNSTILE_SITE_KEY:-} TURNSTILE_SECRET_KEY: ${TURNSTILE_SECRET_KEY:-} + # Optional: share the abuse limits between app containers (no Redis service is added here) + REDIS_URL: ${REDIS_URL:-} # Branding (docs/BRANDING-AND-INTEGRATIONS.md). Set, these override the branding file's defaults APP_NAME: ${APP_NAME:-} APP_TAGLINE: ${APP_TAGLINE:-} diff --git a/docs/ENVIRONMENT.md b/docs/ENVIRONMENT.md index 1611e6e9b..10a595014 100644 --- a/docs/ENVIRONMENT.md +++ b/docs/ENVIRONMENT.md @@ -215,6 +215,7 @@ the table in half. Plain ASCII, no colour: it is read in aggregators as often as | `ORCPUB_PWNED_CHECK` | `on` | Screen new passwords against the Have I Been Pwned corpus. Accepts `on`/`off`, `true`/`false`, `1`/`0`, `yes`/`no`. | | `TURNSTILE_SITE_KEY` | unset | Cloudflare Turnstile site key (public; sent to the browser). The managed-mode check appears on sign-up, password reset, resend verification, and sign-in after a failed attempt, only when **both** this and `TURNSTILE_SECRET_KEY` are set; otherwise the feature is entirely off. Adds `https://challenges.cloudflare.com` to the CSP `frame-src` (and, under `CSP_POLICY=permissive`, `script-src`). Fails open: if Cloudflare cannot be reached (or answers with a server error), the request goes through; a refusal from Cloudflare (4xx) or a missing token does not. For testing, Cloudflare's dummy keys always pass: site key `1x00000000000000000000AA`, secret `1x0000000000000000000000000000000AA`. | | `TURNSTILE_SECRET_KEY` | unset | Turnstile secret key; server-side only, never logged or shown (the startup report says only set / NOT SET). See `TURNSTILE_SITE_KEY`. | +| `REDIS_URL` | unset | Optional. Where sign-in, sign-up and reset limits, sign-in challenge marks and notice cadences are counted. Unset, each app container counts in its own memory (right for one container). Set it (`redis://[:password@]host:6379`) when more than one app container serves the site, so the limits are shared. The URL may carry a password, so the startup report says only set / NOT SET. If Redis cannot be reached (200 ms timeout), that call is counted in memory instead and a warning is logged at most once a minute: limits never switch off. No Redis service is added to the compose files; the admin provides one. | | `TRUST_CLOUDFLARE` | unset | Set to `true` only when the site is served through Cloudflare. The sign-in, sign-up and reset limits and the security log then see each player's real address instead of Cloudflare's. Leave it unset otherwise: anyone can send requests from Cloudflare's addresses, so trusting them on a site not behind Cloudflare would let a visitor pick their own address. | | `TRUSTED_PROXIES` | unset | Other proxies in front of the app, as comma-separated addresses or ranges (`203.0.113.10,198.51.100.0/24`). Private networks, where Docker, Swarm, Traefik and nginx proxies sit, are always trusted. | | `PROFILE_ENCRYPTION_KEYS` | — | Encrypts preferred names at rest: comma-separated `id:base64` keys of 32 bytes; the first encrypts, all decrypt. Also read from the Docker secret `profile_encryption_keys`. Unset = preferred names cannot be saved. Losing it makes stored names unreadable. `./run` generates one. | diff --git a/project.clj b/project.clj index 6e1041c72..8581b17ae 100644 --- a/project.clj +++ b/project.clj @@ -25,6 +25,8 @@ [org.clojure/clojurescript "1.12.134"] [org.clojure/core.async "1.8.741"] [org.postgresql/postgresql "42.7.3"] + ;; Redis client, used only when REDIS_URL is set (orcpub.security.redis-store). + [com.taoensso/carmine "3.4.1"] ;; React 18 + Reagent 2.0 (Concurrent Mode) [cljsjs/react "18.3.1-1"] [cljsjs/react-dom "18.3.1-1"] diff --git a/scripts/swarm.sh b/scripts/swarm.sh index 6b91ee308..467a2e5ab 100644 --- a/scripts/swarm.sh +++ b/scripts/swarm.sh @@ -445,6 +445,7 @@ generate_swarm_compose() { "ORCPUB_PWNED_CHECK:\${ORCPUB_PWNED_CHECK:-}" "TURNSTILE_SITE_KEY:\${TURNSTILE_SITE_KEY:-}" "TURNSTILE_SECRET_KEY:\${TURNSTILE_SECRET_KEY:-}" + "REDIS_URL:\${REDIS_URL:-}" "APP_NAME:\${APP_NAME:-}" "APP_TAGLINE:\${APP_TAGLINE:-}" "APP_PAGE_TITLE:\${APP_PAGE_TITLE:-}" diff --git a/src/clj/orcpub/config.clj b/src/clj/orcpub/config.clj index 7397227f7..9ded2aabd 100644 --- a/src/clj/orcpub/config.clj +++ b/src/clj/orcpub/config.clj @@ -226,6 +226,12 @@ [] (env/flag? :trust-cloudflare)) +(defn redis-url + "REDIS_URL, where the abuse limits are counted when several app containers share them, or nil + for this server's own memory. May carry a password: never print it." + [] + (env/value :redis-url)) + (defn copy-name "This server's name among several copies: HOSTNAME (Docker and Swarm set it per container), else the machine's host name, else \"server\". Names its alert spool file and its alerts." @@ -393,6 +399,8 @@ :note "true when the site is served through Cloudflare"} {:group "security" :var "TRUSTED_PROXIES" :since current-release :note "proxies to trust besides private networks; comma-separated"} + {:group "security" :var "REDIS_URL" :since current-release :secret? true + :note "shared abuse limits; unset counts in memory"} {:group "security" :var "CSP_POLICY" :since "2.5" :note "strict, permissive or none"} {:group "email" :var "EMAIL_SERVER_URL" :since "2.5" :critical? true :fix email-missing-message :note "SMTP host; sign-up and password reset need it"} @@ -471,7 +479,7 @@ (repeat :required)) (zipmap ["APP_URL" "PROFILE_ENCRYPTION_KEYS" "EMAIL_ACCESS_KEY" "EMAIL_SECRET_KEY" "TRUST_CLOUDFLARE"] (repeat :recommended)) - (zipmap ["PORT" "DEV_MODE" "TRUSTED_PROXIES" "CSP_POLICY" "EMAIL_SERVER_PORT" "EMAIL_SSL" "EMAIL_TLS" + (zipmap ["PORT" "DEV_MODE" "TRUSTED_PROXIES" "CSP_POLICY" "REDIS_URL" "EMAIL_SERVER_PORT" "EMAIL_SSL" "EMAIL_TLS" "EMAIL_REQUIRED" "ALLOW_UNVERIFIED_REGISTRATION" "EMAIL_ERRORS_TO" "EMAIL_ADMIN_TO" "ALERT_SPOOL_DIR" "ALERT_MAX_PER_HOUR" "LOAD_HOMEBREW_URL" "PORTRAIT_ARTISTS" "ORCPUB_HTTP_MAX_THREADS" "ORCPUB_PDF_CONCURRENCY" "ORCPUB_PDF_QUEUE_TIMEOUT_MS" diff --git a/src/clj/orcpub/security.clj b/src/clj/orcpub/security.clj index 67410114c..97b22ee5c 100644 --- a/src/clj/orcpub/security.clj +++ b/src/clj/orcpub/security.clj @@ -140,6 +140,33 @@ [] @password-changes) +;; --------------------------------------------------------------------------- +;; Where the mutable state lives. Everything the limits remember -- sightings, sign-in challenge +;; marks, notice claims -- goes through this protocol, so the memory of ONE app container can be +;; swapped for a store shared by several (Redis, when REDIS_URL is set) without touching the +;; policy code. To add a store, implement these seven operations; nothing else reads the state. +;; --------------------------------------------------------------------------- + +(defprotocol LimitStore + (-recent [store k window] + "The sightings of `k` inside `window`, oldest first, as [instant who]; records nothing.") + (-sight! [store k window who] + "Records one sighting of `k` by `who`, and returns those inside `window` from BEFORE it. The + record and the read are ONE atomic step, so simultaneous callers cannot both be told yes on + the last slot. `k` is a vector [limit-name subject]; `window` a Duration.") + (-busiest [store window] + "{limit-name highest-count-of-any-one-key inside window} over everything recorded.") + (-mark! [store k ttl-ms] + "Marks `k` for `ttl-ms` milliseconds.") + (-marked? [store k] + "Whether `k` is marked and the mark has not run out.") + (-unmark! [store k] + "Removes the mark on `k`.") + (-update-notice! [store k ttl-ms f] + "Replaces notice entry `k` with (f entry), `entry` being nil when there is none, and returns + the new entry; a nil from `f` leaves things as they were. The read, `f` and the write happen + as one step. An entry nobody touched for `ttl-ms` is forgotten.")) + ;; Every recorded event is [instant who]: `who` is what a distinct-count limit counts (the typed ;; name behind a connection, or the connection behind a typed name); nil when nothing needs it. (def ^:private sightings (atom {})) @@ -170,24 +197,133 @@ newest (fn [[_ ts]] (.toEpochMilli ^java.time.Instant (first (peek ts))))] (into {} (take-last keep-n (sort-by newest m)))))) +;; Bounds memory against a flood of invented names from many connections. +(def ^:private login-challenge-cap 50000) + +;; key -> the millisecond its mark runs out +(def ^:private login-challenges (atom {})) + +;; entry key -> notice cadence entry (see claim-notice!); times are epoch milliseconds +(def ^:private notice-state (atom {})) + +(defn- mark-in-memory! [m k ttl-ms now] + (let [m (if (>= (count m) login-challenge-cap) + (into {} (remove (fn [[_ until]] (< until now))) m) + m)] + ;; Still full of LIVE marks: leave them all and skip this one. Clearing them would + ;; let a flood of invented names lift every real challenge. Skipping is safe: an + ;; unmarked pair gets the one unchallenged try a fresh connection already gets. + (if (and (>= (count m) login-challenge-cap) (not (contains? m k))) + m + (assoc m k (+ now ttl-ms))))) + +(defrecord MemoryStore [] + LimitStore + (-recent [_ k window] + (live-entries (get @sightings k) (ago window))) + (-sight! [_ k window who] + (let [cutoff (ago window) + at (time/now) + [before _] (swap-vals! sightings + (fn [m] + (let [mine (live-entries (get m k) cutoff) + m (-> m (dissoc k) prune cap-keys)] + (assoc m k (with-meta (conj mine [at who]) {:window window})))))] + (live-entries (get before k) cutoff))) + (-busiest [_ window] + (let [cutoff (ago window)] + (reduce (fn [acc [k ts]] + (let [limit (if (vector? k) (first k) k)] + (update acc limit (fnil max 0) (count (live-entries ts cutoff))))) + {} @sightings))) + (-mark! [_ k ttl-ms] + (swap! login-challenges mark-in-memory! k ttl-ms (System/currentTimeMillis)) + nil) + (-marked? [_ k] + (when-let [until (get @login-challenges k)] + (> until (System/currentTimeMillis)))) + (-unmark! [_ k] + (swap! login-challenges dissoc k) + nil) + (-update-notice! [_ k ttl-ms f] + (let [stale-before (- (.toEpochMilli ^java.time.Instant (time/now)) ttl-ms)] + (get (swap! notice-state + (fn [m] + (let [m (into {} (remove (fn [[_ e]] (< (:seen e) stale-before))) m) + e (f (get m k))] + (if (nil? e) m (assoc m k e))))) + k)))) + +(def memory-store + "The default store: this process's own memory, which is all one app container needs." + (->MemoryStore)) + +;; A shared store can fail, and a limit that stops limiting when it does is worse than a limit +;; that counts per container for a while. So the shared store is wrapped: any call that throws +;; (or times out -- the store sets short socket timeouts) is answered by the memory store +;; instead, and the failure is logged at most once a minute. +(def ^:private store-warn-window-ms 60000) +(def ^:private store-last-warned (atom 0)) + +(defn- store-failed! [e] + (let [now (System/currentTimeMillis) + [before _] (swap-vals! store-last-warned #(if (> (- now %) store-warn-window-ms) now %))] + (when (> (- now before) store-warn-window-ms) + (println "limits: shared store failed, counting in this server's memory meanwhile -" + (.. e getClass getSimpleName))))) + +(defn- with-fallback [primary f] + (try (f primary) + (catch Throwable e + (store-failed! e) + (f memory-store)))) + +(defrecord FallbackStore [primary] + LimitStore + (-recent [_ k window] (with-fallback primary #(-recent % k window))) + (-sight! [_ k window who] (with-fallback primary #(-sight! % k window who))) + (-busiest [_ window] (with-fallback primary #(-busiest % window))) + (-mark! [_ k ttl-ms] (with-fallback primary #(-mark! % k ttl-ms))) + (-marked? [_ k] (with-fallback primary #(-marked? % k))) + (-unmark! [_ k] (with-fallback primary #(-unmark! % k))) + (-update-notice! [_ k ttl-ms f] (with-fallback primary #(-update-notice! % k ttl-ms f)))) + +(defn- build-store + "The store in use: Redis when REDIS_URL is set (namespace loaded only then, so a deployment + without it never touches the client), else memory." + [] + (if-let [url (config/redis-url)] + (try + (let [redis ((requiring-resolve 'orcpub.security.redis-store/redis-store) url)] + (println "limits: counted in Redis (REDIS_URL set), shared by every app container") + (->FallbackStore redis)) + (catch Throwable e + (println "limits: Redis store could not start, counting in memory -" (.. e getClass getSimpleName)) + memory-store)) + memory-store)) + +(def ^:private configured-store (delay (build-store))) + +;; Tests put a store here; nil means the configured one. +(def ^:private store-override (atom nil)) + +(defn use-store! + "Uses `s` as the limit store from now on; nil returns to the configured one. For tests." + [s] + (reset! store-override s) + nil) + +(defn- store [] (or @store-override @configured-store)) + (defn- recent "The sightings of `k` inside `window`, without recording anything." [k window] - (live-entries (get @sightings k) (ago window))) + (-recent (store) k window)) (defn- sight! - "Records one sighting of `k` by `who` and returns those inside `window` from BEFORE it. The - record and the read are one swap, so simultaneous callers cannot both be told yes on the last - slot." + "Records one sighting of `k` by `who` and returns those inside `window` from BEFORE it." [k window who] - (let [cutoff (ago window) - at (time/now) - [before _] (swap-vals! sightings - (fn [m] - (let [mine (live-entries (get m k) cutoff) - m (-> m (dissoc k) prune cap-keys)] - (assoc m k (with-meta (conj mine [at who]) {:window window})))))] - (live-entries (get before k) cutoff))) + (-sight! (store) k window who)) (defn under-limit? "True while `k` has been seen fewer than `limit` times inside `window`, and false once it has hit @@ -380,11 +516,6 @@ (def login-challenge-ms (* 15 60 1000)) -;; Bounds memory against a flood of invented names from many connections. -(def ^:private login-challenge-cap 50000) - -(def ^:private login-challenges (atom {})) - (defn- login-challenge-key [typed-name remote-ip] [(normalise (str typed-name)) remote-ip]) @@ -393,31 +524,18 @@ Does nothing while Turnstile is off." [typed-name remote-ip] (when (turnstile-enabled?) - (let [now (System/currentTimeMillis)] - (swap! login-challenges - (fn [m] - (let [k (login-challenge-key typed-name remote-ip) - m (if (>= (count m) login-challenge-cap) - (into {} (remove (fn [[_ until]] (< until now))) m) - m)] - ;; Still full of LIVE marks: leave them all and skip this one. Clearing them would - ;; let a flood of invented names lift every real challenge. Skipping is safe: an - ;; unmarked pair gets the one unchallenged try a fresh connection already gets. - (if (and (>= (count m) login-challenge-cap) (not (contains? m k))) - m - (assoc m k (+ now login-challenge-ms)))))))) + (-mark! (store) (login-challenge-key typed-name remote-ip) login-challenge-ms)) nil) (defn clear-login-challenge! [typed-name remote-ip] - (swap! login-challenges dissoc (login-challenge-key typed-name remote-ip)) + (-unmark! (store) (login-challenge-key typed-name remote-ip)) nil) (defn login-challenge-required? "True while Turnstile is on and `typed-name` from `remote-ip` failed a sign-in in the last 15 minutes." [typed-name remote-ip] (boolean (and (turnstile-enabled?) - (when-let [until (get @login-challenges (login-challenge-key typed-name remote-ip))] - (> until (System/currentTimeMillis)))))) + (-marked? (store) (login-challenge-key typed-name remote-ip))))) ;; --------------------------------------------------------------------------- ;; The one guard. A handler calls `guard` before it does the work and, for a form that counts @@ -539,12 +657,7 @@ trips anything and so never appears in the refusals at all -- this is the only place it shows up." [] - (let [cutoff (ago (hours 1))] - (->> @sightings - (reduce (fn [acc [k ts]] - (let [limit (if (vector? k) (first k) k)] - (update acc limit (fnil max 0) (count (live-entries ts cutoff))))) - {})))) + (-busiest (store) (hours 1))) (defn- caps "What each hourly limit allows, read off the policy table (plus the image probe)." @@ -588,7 +701,7 @@ {:sign-in-attempts {:first :immediate :min-gap-hours 6 :max-per-day 4} :taken-signup {:first :immediate :min-gap-hours 6 :max-per-day 4}}) -(def ^:private notice-state (atom {})) +(def ^:private day-ms (* 24 60 60 1000)) (defn claim-notice! "Counts one attempt for `kind` (a key of `notices`) against `k` (the account or address) and says @@ -596,27 +709,22 @@ follow-up, n being the attempts since the previous notice, this one included." [kind k] (let [{:keys [min-gap-hours max-per-day]} (notices kind) - at (time/now) - day-ago (.minus ^java.time.Instant at (hours 24)) - gap-ago (.minus ^java.time.Instant at (hours min-gap-hours)) - entry-key [kind k] - claimed (fn [m] - (let [{:keys [pending sent notified?] :or {pending 0 sent []}} (get m entry-key) - sent (filterv #(.isAfter ^java.time.Instant % day-ago) sent) + at (.toEpochMilli ^java.time.Instant (time/now)) + day-ago (- at day-ms) + gap-ago (- at (* min-gap-hours 60 60 1000)) + claimed (fn [entry] + (let [{:keys [pending sent notified?] :or {pending 0 sent []}} entry + sent (filterv #(> % day-ago) sent) pending (inc pending) due? (if (empty? sent) (or notified? (= :immediate (:first (notices kind)))) - (and (not (.isAfter ^java.time.Instant (peek sent) gap-ago)) + (and (<= (peek sent) gap-ago) (< (count sent) max-per-day)))] - (assoc m entry-key - (if due? - {:pending 0 :sent (conj sent at) :seen at :notified? true - :claimed (if notified? {:since-last pending} {})} - {:pending pending :sent sent :seen at :notified? notified?})))) - after (swap! notice-state - (fn [m] - (claimed (into {} (remove (fn [[_ e]] (.isBefore ^java.time.Instant (:seen e) day-ago))) m))))] - (:claimed (get after entry-key)))) + (if due? + {:pending 0 :sent (conj sent at) :seen at :notified? true + :claimed (if notified? {:since-last pending} {})} + {:pending pending :sent sent :seen at :notified? notified?})))] + (:claimed (-update-notice! (store) [kind k] day-ms claimed)))) (defn release-notice! "Gives back a claim from `claim-notice!` whose mail could not be queued, so the notice is not @@ -624,14 +732,12 @@ attempts that were waiting (`notice` is what the claim returned) and, for a first notice, the not-yet-notified state." [kind k notice] - (swap! notice-state - (fn [m] - (if-let [e (get m [kind k])] - (assoc m [kind k] - (-> e - (update :sent #(if (seq %) (pop %) %)) - (assoc :pending (:since-last notice 1)) - (assoc :notified? (contains? notice :since-last)) - (dissoc :claimed))) - m))) + (-update-notice! (store) [kind k] day-ms + (fn [e] + (when e + (-> e + (update :sent #(if (seq %) (pop %) %)) + (assoc :pending (:since-last notice 1)) + (assoc :notified? (contains? notice :since-last)) + (dissoc :claimed))))) nil) diff --git a/src/clj/orcpub/security/redis_store.clj b/src/clj/orcpub/security/redis_store.clj new file mode 100644 index 000000000..a74e70c95 --- /dev/null +++ b/src/clj/orcpub/security/redis_store.clj @@ -0,0 +1,120 @@ +(ns orcpub.security.redis-store + "The abuse limits' state in Redis, so every app container counts against the same numbers. + Loaded only when REDIS_URL is set (see orcpub.security/build-store). Same contract as the + memory store: sightings are a sorted set per key (score = millisecond), marks are keys that + expire, notice cadences are one expiring value per key. Every key starts with `prefix`, so a + Redis shared with something else is safe. Socket timeouts are short: a slow Redis must not slow + sign-in; orcpub.security answers any call that throws from memory instead." + (:require [clojure.edn :as edn] + [clojure.string :as str] + [orcpub.security :as security] + [orcpub.time :as time] + [taoensso.carmine :as car :refer [wcar]])) + +(def prefix "orcpub:limits:") + +(def timeout-ms 200) + +(defn- short-id + "`v` as text for a key: itself, or its SHA-256 when long, since typed names are the sender's to + make as long as they like." + [v] + (let [text (str v)] + (if (<= (count text) 100) + text + (->> (.digest (java.security.MessageDigest/getInstance "SHA-256") (.getBytes text "UTF-8")) + (map #(format "%02x" %)) + (apply str))))) + +(defn- limit-text [limit] + (if (keyword? limit) (subs (str limit) 1) (str limit))) + +(defn- sighting-key [k] + (let [[limit subject] (if (vector? k) k [k nil])] + (str prefix "s:" (limit-text limit) ":" (short-id subject)))) + +(defn- mark-key [k] (str prefix "m:" (short-id (pr-str k)))) + +(defn- notice-key [k] (str prefix "n:" (short-id (pr-str k)))) + +;; Drops what left the window, reads what is still inside, adds this sighting, renews the key's +;; expiry -- as one script, so two containers cannot both take the last slot. +;; ARGV: cutoff ms, now ms, ttl ms, member. +(def ^:private sight-script + "redis.call('ZREMRANGEBYSCORE', KEYS[1], '-inf', '(' .. ARGV[1]) + local before = redis.call('ZRANGE', KEYS[1], 0, -1, 'WITHSCORES') + redis.call('ZADD', KEYS[1], ARGV[2], ARGV[4]) + redis.call('PEXPIRE', KEYS[1], ARGV[3]) + return before") + +;; Writes ARGV[2] only if the key still holds what the caller read (ARGV[1], empty for none). +(def ^:private swap-script + "local cur = redis.call('GET', KEYS[1]) + if (cur == false and ARGV[1] == '') or cur == ARGV[1] then + redis.call('SET', KEYS[1], ARGV[2], 'PX', ARGV[3]) + return 1 + end + return 0") + +;; A sighting is [instant who]; `who` rides in the member after a nonce that keeps equal +;; sightings apart. "n" is nil, "s" a string. +(defn- member [who] + (str (random-uuid) "|" (if (nil? who) "n" (str "s" who)))) + +(defn- entries + "[instant who] pairs from a flat [member score member score ...] reply." + [flat] + (mapv (fn [[m score]] + (let [tag (subs m (inc (str/index-of m "|")))] + [(java.time.Instant/ofEpochMilli (long (Double/parseDouble score))) + (when (= \s (first tag)) (subs tag 1))])) + (partition 2 flat))) + +(defn- millis [^java.time.Instant i] (.toEpochMilli i)) + +(defrecord RedisStore [conn] + security/LimitStore + (-recent [_ k window] + (let [cutoff (- (millis (time/now)) (.toMillis ^java.time.Duration window))] + (entries (wcar conn (car/zrangebyscore (sighting-key k) cutoff "+inf" "WITHSCORES"))))) + (-sight! [_ k window who] + (let [at (millis (time/now)) + ttl (.toMillis ^java.time.Duration window)] + (entries (wcar conn (car/eval* sight-script 1 (sighting-key k) + (- at ttl) at ttl (member who)))))) + (-busiest [_ window] + (let [cutoff (- (millis (time/now)) (.toMillis ^java.time.Duration window))] + (loop [cursor "0" acc {}] + (let [[next-cursor ks] (wcar conn (car/scan cursor :match (str prefix "s:*") :count 500)) + counts (when (seq ks) + (wcar conn :as-pipeline (doseq [k ks] (car/zcount k cutoff "+inf")))) + acc (reduce (fn [acc [k n]] + (let [limit (keyword (first (str/split (subs k (count (str prefix "s:"))) #":" 2)))] + (update acc limit (fnil max 0) (long n)))) + acc (map vector ks counts))] + (if (= "0" (str next-cursor)) acc (recur next-cursor acc)))))) + (-mark! [_ k ttl-ms] + (wcar conn (car/set (mark-key k) "1" "PX" ttl-ms)) + nil) + (-marked? [_ k] + (= 1 (wcar conn (car/exists (mark-key k))))) + (-unmark! [_ k] + (wcar conn (car/del (mark-key k))) + nil) + (-update-notice! [_ k ttl-ms f] + (let [rk (notice-key k)] + ;; Optimistic: read, compute, write only if nobody else wrote in between; try again if so (a notice is claimed rarely, so this seldom loops). + (loop [attempts 20] + (let [old (wcar conn (car/get rk)) + entry (f (some-> old edn/read-string))] + (cond + (nil? entry) nil + (= 1 (wcar conn (car/eval* swap-script 1 rk (or old "") (pr-str entry) ttl-ms))) entry + (pos? (dec attempts)) (recur (dec attempts)) + :else (throw (ex-info "notice entry kept changing" {})))))))) + +(defn redis-store + "A store on the Redis at `url` (redis://[:password@]host:port; rediss:// for TLS)." + [url] + (->RedisStore {:pool {} + :spec {:uri url :conn-timeout-ms timeout-ms :read-timeout-ms timeout-ms}})) diff --git a/test/clj/orcpub/security_store_test.clj b/test/clj/orcpub/security_store_test.clj new file mode 100644 index 000000000..7196faee9 --- /dev/null +++ b/test/clj/orcpub/security_store_test.clj @@ -0,0 +1,231 @@ +(ns orcpub.security-store-test + "The limits' state behind `LimitStore`: one contract, run against the memory store always and + against a real Redis when one is available. Redis is a server given by REDIS_TEST_URL (not + REDIS_URL: that would also switch every other test's limits to Redis), else a throwaway + `redis-server` started on a free port, else the Redis tests are SKIPPED and say so." + (:require [clojure.string :as str] + [clojure.test :refer [deftest is testing use-fixtures]] + [orcpub.env :as env] + [orcpub.security :as s] + [orcpub.security.redis-store :as redis] + [orcpub.time :as time] + [taoensso.carmine :as car :refer [wcar]])) + +;; ---- a Redis for the run, or none ---- + +(def ^:private redis-conn (atom nil)) + +(defn- free-port [] + (with-open [ss (java.net.ServerSocket. 0)] (.getLocalPort ss))) + +(defn- reachable? [url] + (try (= "PONG" (wcar {:pool {} :spec {:uri url :conn-timeout-ms 500 :read-timeout-ms 500}} (car/ping))) + (catch Throwable _ false))) + +(defn- start-redis! + "A throwaway redis-server, as {:url :process}, or nil when there is none to run." + [] + (try + (let [port (free-port) + pb (ProcessBuilder. ^java.util.List ["redis-server" "--port" (str port) "--bind" "127.0.0.1" + "--save" "" "--appendonly" "no"]) + p (.start (.redirectErrorStream pb true)) + url (str "redis://127.0.0.1:" port)] + (loop [tries 30] + (cond (reachable? url) {:url url :process p} + (zero? tries) (do (.destroy p) nil) + :else (do (Thread/sleep 100) (recur (dec tries)))))) + (catch Throwable _ nil))) + +(defn- with-redis [f] + (let [given (env/value :redis-test-url) + started (when-not (and given (reachable? given)) (start-redis!)) + url (or (when (and given (reachable? given)) given) (:url started))] + (reset! redis-conn (when url (redis/redis-store url))) + (when-not url + (println "SKIPPED: Redis tests (no REDIS_TEST_URL and no redis-server to start)")) + (try (f) + (finally + (reset! redis-conn nil) + (some-> (:process started) .destroy))))) + +(use-fixtures :once with-redis) + +(defn- clear-redis! [store] + (let [conn (:conn store)] + (loop [cursor "0"] + (let [[nxt ks] (wcar conn (car/scan cursor :match (str redis/prefix "*") :count 500))] + (doseq [k ks] (wcar conn (car/del k))) + (when-not (= "0" (str nxt)) (recur nxt)))))) + +(defn- on-each-store + "Runs (f name) once against memory and, when there is one, against Redis, each from empty." + [f] + (doseq [[nm store] [["memory" s/memory-store] ["redis" @redis-conn]] :when store] + (reset! @#'s/sightings {}) + (reset! @#'s/login-challenges {}) + (reset! @#'s/notice-state {}) + (when (= "redis" nm) (clear-redis! store)) + (s/use-store! store) + (try (testing nm (f nm)) + (finally (s/use-store! nil))))) + +(defn- clock-from [t0] + (let [clock (atom t0)] + [(fn [] @clock) (fn [minutes] (reset! clock (.plusSeconds t0 (* 60 minutes))))])) + +(def ^:private t0 (.toInstant #inst "2026-01-01T00:00:00Z")) + +;; ---- the guard table ---- + +(defn- ctx + "Varies in every way but `scope`'s subject, so only that limit can fill up." + [scope i] + {:address (if (= :per-address scope) "same@example.com" (str "u" i "@example.com")) + :ip (if (#{:per-host :names-per-host} scope) "5.5.5.5" (str "10.0." i ".1")) + :typed-name (if (= :per-name scope) "Same-Name" (str "name" i)) + :actionable (delay true)}) + +(deftest every-limit-of-the-table-refuses-at-its-number + (on-each-store + (fn [_] + (doseq [[route p] s/auth-guards + :when (and (not (:none p)) (not= :failure (:counted-on p))) + [scope n] (:limits p)] + (testing (str route " " scope " " n) + (let [results (vec (for [i (range 1 (+ n 2))] (some? (s/guard route (ctx scope i)))))] + (is (= (concat (repeat n false) [true]) results) "n pass, the next is refused"))))))) + +(deftest a-failing-form-refuses-the-failing-attempt-and-names-the-spread + (on-each-store + (fn [_] + (let [route :orcpub.routes.auth/login + [_ n] (first (filter #(= :per-name (first %)) (:limits (s/policy route)))) + [_ distinct-n] [nil (get-in s/auth-guards [route :notify :distinct])] + from (fn [i] {:ip (str "10.1." i ".1") :typed-name "Victim"}) + outcomes (vec (for [i (range 1 (inc n))] (s/record! route :failure (from i))))] + (is (nil? (:refusal (first outcomes)))) + (is (= :limit (:reason (:refusal (peek outcomes)))) "the n-th failing attempt is refused") + (is (= [nil :sign-in-attempts] [(:notify (first outcomes)) (:notify (nth outcomes (dec distinct-n)))]) + "and the owner is told once enough addresses have tried"))))) + +(deftest sightings-count-inside-their-window-only + (on-each-store + (fn [_] + (let [k [:probe "x"] + short-window (java.time.Duration/ofMillis 200)] + (is (empty? (#'s/sight! k short-window "a"))) + (is (= ["a"] (map second (#'s/sight! k short-window nil)))) + (is (= 2 (count (#'s/recent k short-window))) "looking records nothing") + (is (= 2 (count (#'s/recent k short-window)))) + (Thread/sleep 300) + (is (empty? (#'s/recent k short-window)) "gone with the window"))))) + +(deftest busiest-is-the-heaviest-key-of-each-limit + (on-each-store + (fn [_] + (dotimes [_ 3] (#'s/sight! [:a "1"] (time/hours 1) nil)) + (dotimes [_ 5] (#'s/sight! [:a "2"] (time/hours 1) nil)) + (#'s/sight! [:b "1"] (time/hours 1) nil) + (is (= {:a 5 :b 1} (select-keys (s/busiest) [:a :b])))))) + +;; ---- marks and notices ---- + +(deftest a-failed-sign-in-marks-the-next-attempt-until-cleared + (with-redefs [s/turnstile-enabled? (constantly true)] + (on-each-store + (fn [_] + (is (false? (s/login-challenge-required? "Ann " "1.1.1.1"))) + (s/mark-login-challenge! "ann" "1.1.1.1") + (is (true? (s/login-challenge-required? "Ann " "1.1.1.1")) "the typed text is trimmed and lowercased") + (is (false? (s/login-challenge-required? "ann" "2.2.2.2")) "another connection is unmarked") + (s/clear-login-challenge! "ann" "1.1.1.1") + (is (false? (s/login-challenge-required? "ann" "1.1.1.1"))))))) + +(deftest a-mark-runs-out + (on-each-store + (fn [_] + (let [store (#'s/store)] + (s/-mark! store ["short" "ip"] 100) + (is (s/-marked? store ["short" "ip"])) + (Thread/sleep 250) + (is (not (s/-marked? store ["short" "ip"]))))))) + +(deftest notices-follow-their-cadence-and-can-be-given-back + (on-each-store + (fn [_] + (let [[now-fn at] (clock-from t0) + gap (* 60 (:min-gap-hours (s/notices :sign-in-attempts))) + claim #(s/claim-notice! :sign-in-attempts 42)] + (with-redefs [time/now now-fn] + (is (= {} (claim)) "the first attempt is told at once") + (is (nil? (claim)) "a second inside the gap is not") + (at (inc gap)) + (is (= {:since-last 2} (claim)) "after the gap, with how many came in") + (s/release-notice! :sign-in-attempts 42 {:since-last 2}) + (is (= {:since-last 3} (claim)) "a claim given back is due again, the attempt since counted")))))) + +(deftest concurrent-claims-tell-the-owner-once + (on-each-store + (fn [_] + (let [told (->> (repeatedly 16 #(future (s/claim-notice! :taken-signup "a@b.c"))) + doall (map deref) (filter some?))] + (is (= 1 (count told))))))) + +(deftest simultaneous-sightings-cannot-both-take-the-last-slot + (on-each-store + (fn [_] + (let [seen (->> (repeatedly 20 #(future (count (#'s/sight! [:race "k"] (time/hours 1) nil)))) + doall (map deref))] + (is (= (range 20) (sort seen)) "each caller saw exactly the ones before it"))))) + +(deftest keys-are-prefixed-and-long-subjects-are-bounded + (when-let [store @redis-conn] + (s/use-store! store) + (try + (clear-redis! store) + (#'s/sight! [:img (apply str (repeat 5000 "x"))] (time/hours 1) nil) + (let [ks (wcar (:conn store) (car/keys "*")) + mine (filter #(str/starts-with? % redis/prefix) ks)] + (is (seq mine)) + (is (every? #(< (count %) 200) mine) "a sender's long text cannot make a long key")) + (finally (clear-redis! store) (s/use-store! nil))))) + +;; ---- a failing shared store never switches limits off ---- + +(def ^:private broken + (reify s/LimitStore + (-recent [_ _ _] (throw (java.net.SocketTimeoutException. "slow"))) + (-sight! [_ _ _ _] (throw (java.net.SocketTimeoutException. "slow"))) + (-busiest [_ _] (throw (java.net.SocketTimeoutException. "slow"))) + (-mark! [_ _ _] (throw (java.net.SocketTimeoutException. "slow"))) + (-marked? [_ _] (throw (java.net.SocketTimeoutException. "slow"))) + (-unmark! [_ _] (throw (java.net.SocketTimeoutException. "slow"))) + (-update-notice! [_ _ _ _] (throw (java.net.SocketTimeoutException. "slow"))))) + +(deftest a-throwing-store-falls-back-to-memory-and-limits-still-hold + (reset! @#'s/sightings {}) + (reset! @#'s/login-challenges {}) + (reset! @#'s/notice-state {}) + (reset! @#'s/store-last-warned 0) + (s/use-store! (s/->FallbackStore broken)) + (try + (let [out (java.io.StringWriter.)] + (binding [*out* out] + (let [route :orcpub.routes.auth/register + [_ n] (first (:limits (s/policy route))) + results (vec (for [_ (range (inc n))] (some? (s/guard route {:ip "9.9.9.9"}))))] + (is (= (concat (repeat n false) [true]) results) "the limit still refuses at its number") + (with-redefs [s/turnstile-enabled? (constantly true)] + (s/mark-login-challenge! "ann" "1.1.1.1") + (is (true? (s/login-challenge-required? "ann" "1.1.1.1")))) + (is (= {} (s/claim-notice! :taken-signup "x@y.z"))) + (is (nil? (s/claim-notice! :taken-signup "x@y.z"))) + (is (map? (s/busiest))))) + (is (= 1 (count (re-seq #"limits: shared store failed" (str out)))) + "one warning, however many calls failed")) + (finally (s/use-store! nil)))) + +(deftest without-redis-url-the-memory-store-is-used + (is (nil? (env/value :redis-url)) "this suite runs on the memory store") + (is (identical? s/memory-store (#'s/store)))) From debc73aceaf37482406887e8d3afc15777a0dcb8 Mon Sep 17 00:00:00 2001 From: codeGlaze Date: Thu, 5 Nov 2026 00:52:20 +0000 Subject: [PATCH 25/27] Close the verified-account oracle in re-verify and tidy auth follow-ups re-verify answers a verified account with the same bare 200 as an unknown address. The per-host allowance test now reads the key guard writes. The Turnstile notes name every form it covers, an absolute APP_OG_IMAGE is kept as is, the character page's X-Frame-Options lands in :headers, and the widget reset clears the blocked flag only when a widget exists. --- src/clj/orcpub/config.clj | 9 +++++---- src/clj/orcpub/index.clj | 8 ++++++-- src/clj/orcpub/routes.clj | 2 +- src/clj/orcpub/routes/auth.clj | 8 ++++---- src/cljs/orcpub/dnd/e5/views/auth.cljs | 2 +- .../orcpub/portrait_artists_endpoint_test.clj | 16 ++++++++++++++++ test/clj/orcpub/security_test.clj | 10 +++++++--- 7 files changed, 40 insertions(+), 15 deletions(-) diff --git a/src/clj/orcpub/config.clj b/src/clj/orcpub/config.clj index 9ded2aabd..fe7a6a880 100644 --- a/src/clj/orcpub/config.clj +++ b/src/clj/orcpub/config.clj @@ -368,8 +368,9 @@ (env-raw "TURNSTILE_SECRET_KEY")) (defn turnstile-enabled? - "Whether the sign-up form asks for a Cloudflare Turnstile check: only when BOTH - TURNSTILE_SITE_KEY and TURNSTILE_SECRET_KEY are set." + "Whether the sign-up, password-reset and resend-verification forms (and sign-in after a + failure) ask for a Cloudflare Turnstile check: only when BOTH TURNSTILE_SITE_KEY and + TURNSTILE_SECRET_KEY are set." [] (boolean (and (turnstile-site-key) (turnstile-secret-key)))) @@ -463,9 +464,9 @@ :expects "on or off" :note "checks new passwords against known breaches"} {:group "security" :var "TURNSTILE_SITE_KEY" :since current-release :get #(turnstile-site-key) - :note "Turnstile on sign-up; needs the secret key too"} + :note "Turnstile on sign-up/reset/resend/sign-in; needs secret key"} {:group "security" :var "TURNSTILE_SECRET_KEY" :since current-release :secret? true - :note "Turnstile on sign-up; needs the site key too"} + :note "Turnstile on sign-up/reset/resend/sign-in; needs site key"} {:group "retention" :var "ORCPUB_SHARE_PRUNE_DAYS" :since current-release :get #(get-share-prune-days) :accepts #(some-> % str/trim parse-long (>= 0)) :expects "a whole number of days, 0 or more" :note "days before an unused share link is deleted; 0 never"}])) diff --git a/src/clj/orcpub/index.clj b/src/clj/orcpub/index.clj index 78b0a3899..7a683f0b9 100644 --- a/src/clj/orcpub/index.clj +++ b/src/clj/orcpub/index.clj @@ -332,9 +332,13 @@ html { (def default-description branding/app-tagline) (defn default-image-url - "OG meta image URL. Uses https:// for social sharing compatibility." + "OG meta image URL. Uses https:// for social sharing compatibility. An APP_OG_IMAGE that is + already an absolute http(s) URL is returned as it is; a site path gets the host in front." [host] - (str "https://" host branding/og-image-filename)) + (let [image branding/og-image-filename] + (if (re-find #"(?i)^https?://" (str image)) + image + (str "https://" host image)))) (defn index-page-response [{:keys [headers uri csp-nonce] :as request} {:keys [title description image-url]} diff --git a/src/clj/orcpub/routes.clj b/src/clj/orcpub/routes.clj index 9ed53b513..074cd5942 100644 --- a/src/clj/orcpub/routes.clj +++ b/src/clj/orcpub/routes.clj @@ -1706,7 +1706,7 @@ description (when credit (str " · " credit))) :image-url share-image} - {"X-Frame-Options" "ALLOW-FROM https://www.worldanvil.com/"}))) + {:headers {"X-Frame-Options" "ALLOW-FROM https://www.worldanvil.com/"}}))) (defn artists-page "The list of portrait artists. The page itself is the SPA's; this only diff --git a/src/clj/orcpub/routes/auth.clj b/src/clj/orcpub/routes/auth.clj index 795756c3d..0953e1657 100644 --- a/src/clj/orcpub/routes/auth.clj +++ b/src/clj/orcpub/routes/auth.clj @@ -600,10 +600,10 @@ :db/id] :as user} (when-not refusal @user)] (cond refusal (refusal-response ::re-verify refusal) - verified? (redirect route-map/verify-success-route) - ;; No account for this address: answer like a resend and create nothing. Passing - ;; {:db/id nil} on would register a key-only record and email a link to any address typed. - (nil? id) {:status 200} + ;; No account, or one already verified: the same bare 200 as a resend, sending nothing, so + ;; the answer does not say which addresses have verified accounts. (Passing {:db/id nil} on + ;; would register a key-only record and email a link to any address typed.) + (or verified? (nil? id)) {:status 200} :else (do-verification request (merge query-params diff --git a/src/cljs/orcpub/dnd/e5/views/auth.cljs b/src/cljs/orcpub/dnd/e5/views/auth.cljs index e11631606..68553b4a4 100644 --- a/src/cljs/orcpub/dnd/e5/views/auth.cljs +++ b/src/cljs/orcpub/dnd/e5/views/auth.cljs @@ -62,8 +62,8 @@ "Tokens are single use: asks the widget for a fresh one. No-op without a widget." [] (dispatch [:turnstile-token nil]) - (dispatch [:turnstile-blocked false]) (when-let [id @widget-id] + (dispatch [:turnstile-blocked false]) (try (call-api "reset" id) (catch :default _ nil)))) ;; The :turnstile-reset event (events/auth) returns this effect, so it need not require this diff --git a/test/clj/orcpub/portrait_artists_endpoint_test.clj b/test/clj/orcpub/portrait_artists_endpoint_test.clj index 1e82bbc8b..04b0676a2 100644 --- a/test/clj/orcpub/portrait_artists_endpoint_test.clj +++ b/test/clj/orcpub/portrait_artists_endpoint_test.clj @@ -5,6 +5,7 @@ [orcpub.db.schema :as schema] [orcpub.dnd.e5.portrait-assets :as pa] [orcpub.routes :as routes] + [orcpub.fork.branding] [orcpub.index :as index] [orcpub.route-map] [cheshire.core]) @@ -41,6 +42,21 @@ (is (string? html)) (is (not (re-find #"MARK" html)) "artist-editable text reaches the browser as data, not page source")))) +(deftest the-og-image-url-keeps-an-absolute-setting-and-prefixes-a-site-path + (with-redefs [orcpub.fork.branding/og-image-filename "https://cdn.example.test/card.png"] + (is (= "https://cdn.example.test/card.png" (index/default-image-url "example.test")))) + (with-redefs [orcpub.fork.branding/og-image-filename "http://cdn.example.test/card.png"] + (is (= "http://cdn.example.test/card.png" (index/default-image-url "example.test")))) + (with-redefs [orcpub.fork.branding/og-image-filename "/image/card.png"] + (is (= "https://example.test/image/card.png" (index/default-image-url "example.test"))))) + +(deftest the-character-page-carries-the-worldanvil-frame-header + (with-redefs [routes/character-summary-for-id (constantly {})] + (let [resp (routes/character-page {:headers {"host" "example.test"} :uri "/" :path-params {:id "1"}})] + (is (= "ALLOW-FROM https://www.worldanvil.com/" (get-in resp [:headers "X-Frame-Options"]))) + (is (= "text/html" (get-in resp [:headers "Content-Type"])) "the default header is kept") + (is (not (contains? resp "X-Frame-Options")) "and no stray top-level key")))) + (deftest the-endpoint-serves-the-saved-credit-as-json (with-conn conn (artist! conn) diff --git a/test/clj/orcpub/security_test.clj b/test/clj/orcpub/security_test.clj index 1c3fa3868..67ac7dedd 100644 --- a/test/clj/orcpub/security_test.clj +++ b/test/clj/orcpub/security_test.clj @@ -332,12 +332,16 @@ (let [resps (vec (for [_ (range attempts)] (call {:address "a@example.com" :ip "6.6.6.6"})))] [(set resps) @worked])))) [known-responses known-work] (run {:db/id 17}) - [unknown-responses unknown-work] (run {})] + [unknown-responses unknown-work] (run {}) + [verified-responses verified-work] (run {:db/id 17 :orcpub.user/verified? true})] (is (= known-responses unknown-responses) "one answer, limited or not, known or not") (is (= 1 (count known-responses))) (is (pos? known-work)) (is (< known-work attempts) "and the known address was in fact limited") - (is (zero? unknown-work) "nothing is done for an address with no account"))))) + (is (zero? unknown-work) "nothing is done for an address with no account") + (when (= :orcpub.routes.auth/re-verify route) + (is (= unknown-responses verified-responses) "a verified account answers the same too") + (is (zero? verified-work) "and sends nothing")))))) (defn- verify-calls "Runs `f` with Turnstile on and siteverify answering `answer` (a map, or :throw); returns @@ -379,7 +383,7 @@ (with-redefs [s/turnstile-enabled? (constantly true) s/post-siteverify (fn [& _] {:success false})] (is (= :turnstile (:reason (s/guard :orcpub.routes.auth/register {:ip "9.9.9.9" :token "bad"})))) - (is (nil? (get @@#'s/sightings [:orcpub.routes.auth/register-per-host "9.9.9.9"]))) + (is (nil? (get @@#'s/sightings [:register-per-host "9.9.9.9"]))) (is (= 1 (count (get @@#'s/sightings [:register-challenge "9.9.9.9"])))))) (defn- lookups-fail-the-test [& _] (throw (AssertionError. "looked the address up before the challenge"))) From c9dbe1e325cfa8ff9488d0ed418c096eda397874 Mon Sep 17 00:00:00 2001 From: codeGlaze Date: Thu, 5 Nov 2026 02:43:16 +0000 Subject: [PATCH 26/27] Drop the dead X-Frame-Options ALLOW-FROM header from character pages Every current browser ignores ALLOW-FROM, and the CSP's frame-ancestors 'self' already decides framing on every page, so the header did nothing. Whether World Anvil should embed sheets again is tracked in docs/TODO.md on agents/develop. --- src/clj/orcpub/routes.clj | 3 +-- test/clj/orcpub/portrait_artists_endpoint_test.clj | 9 +++++---- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/clj/orcpub/routes.clj b/src/clj/orcpub/routes.clj index 074cd5942..fe1424d8d 100644 --- a/src/clj/orcpub/routes.clj +++ b/src/clj/orcpub/routes.clj @@ -1705,8 +1705,7 @@ ". " description (when credit (str " · " credit))) - :image-url share-image} - {:headers {"X-Frame-Options" "ALLOW-FROM https://www.worldanvil.com/"}}))) + :image-url share-image}))) (defn artists-page "The list of portrait artists. The page itself is the SPA's; this only diff --git a/test/clj/orcpub/portrait_artists_endpoint_test.clj b/test/clj/orcpub/portrait_artists_endpoint_test.clj index 04b0676a2..60c15d5e0 100644 --- a/test/clj/orcpub/portrait_artists_endpoint_test.clj +++ b/test/clj/orcpub/portrait_artists_endpoint_test.clj @@ -50,12 +50,13 @@ (with-redefs [orcpub.fork.branding/og-image-filename "/image/card.png"] (is (= "https://example.test/image/card.png" (index/default-image-url "example.test"))))) -(deftest the-character-page-carries-the-worldanvil-frame-header +(deftest the-character-page-sends-no-frame-header + ;; Framing is decided by the CSP's frame-ancestors on every page; the old X-Frame-Options + ;; ALLOW-FROM line was ignored by every current browser and has been removed. (with-redefs [routes/character-summary-for-id (constantly {})] (let [resp (routes/character-page {:headers {"host" "example.test"} :uri "/" :path-params {:id "1"}})] - (is (= "ALLOW-FROM https://www.worldanvil.com/" (get-in resp [:headers "X-Frame-Options"]))) - (is (= "text/html" (get-in resp [:headers "Content-Type"])) "the default header is kept") - (is (not (contains? resp "X-Frame-Options")) "and no stray top-level key")))) + (is (nil? (get-in resp [:headers "X-Frame-Options"]))) + (is (= "text/html" (get-in resp [:headers "Content-Type"])) "the default header is kept")))) (deftest the-endpoint-serves-the-saved-credit-as-json (with-conn conn From d1440cd88898297b352d5244fa1fc8868e6e7029 Mon Sep 17 00:00:00 2001 From: codeGlaze Date: Thu, 5 Nov 2026 03:16:18 +0000 Subject: [PATCH 27/27] Fold the fix/auth-abuse changelog into the Summer Patch --- CHANGELOG.md | 7 +++++++ docs/branch-changelog.md | 30 ------------------------------ 2 files changed, 7 insertions(+), 30 deletions(-) delete mode 100644 docs/branch-changelog.md diff --git a/CHANGELOG.md b/CHANGELOG.md index 5fad58941..8a59a1207 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -104,6 +104,8 @@ Homebrew can be moved, switched off and repaired instead of lost, and a characte - **Characters:** the portrait credit links to the artist's page. - **Accounts:** artists choose on My Account whether they have a page, and whether it shows their example portraits, their links and how many pieces they drew. +- **Accounts:** an optional Cloudflare Turnstile check on sign-up, password reset and resend verification, and on sign-in after a failed attempt. Off unless `TURNSTILE_SITE_KEY` and `TURNSTILE_SECRET_KEY` are set; if Cloudflare can't be reached, requests go through. +- **Accounts:** when the security check can't load, the form says so and suggests allowing challenges.cloudflare.com in an ad blocker. ### Changed - **Server:** a deployed server will not start without a mail server unless `EMAIL_REQUIRED=false` says that is intended, and the message names the setting to add. Development mode is exempt; `./run` and `./run --upgrade` set the opt-out for installs that run without email, so none stops on upgrade. (#716) @@ -139,6 +141,10 @@ Homebrew can be moved, switched off and repaired instead of lost, and a characte for repair. - **Homebrew:** checking homebrew after an import or a Restore takes a fraction of the time for classes: each shared part of a class is checked once, not once per level. +- **Accounts:** sign-up no longer says when an email is already in use. It answers as for a new address and emails the account's owner instead. Without a mail server, a taken address gets a plain refusal. +- **Accounts:** warnings about sign-in attempts on your account now follow up while attempts continue (at most every 6 hours, with a count), instead of once a day. +- **Server:** links in account emails use `APP_URL` when it is set (set it in production; the startup report warns when it is not). +- **Server:** an optional `REDIS_URL` shares the sign-in and email limits across app containers; without it each container keeps its own. ### Fixed @@ -253,6 +259,7 @@ Homebrew can be moved, switched off and repaired instead of lost, and a characte - Sign-in, password reset, share links, image fetching and PDF export are hardened against misuse, and secrets are no longer printed at startup. - **Site:** pages no longer load fonts from Google, so visiting the site no longer sends your address to Google. (#721) - **Site:** other sites a page links to are told only this site's domain, never the page's address. +- **Accounts:** account emails can no longer be triggered in bulk from one form that had no limit. ## [breaking/2026-stack-modernization] diff --git a/docs/branch-changelog.md b/docs/branch-changelog.md deleted file mode 100644 index c017a352b..000000000 --- a/docs/branch-changelog.md +++ /dev/null @@ -1,30 +0,0 @@ - - -# Branch changelog — `fix/auth-abuse` - -## Why this branch exists - -The live site was hit with password-reset spam on 2026-11-03. An audit of the account forms found -resend-verification had no limit, sign-up told anyone whether an email had an account, and the -limits were written per form, so a new form could ship unguarded. This branch puts every account -form under one policy table and one guard (with a test that fails if a route is missing from it), -adds an optional Cloudflare Turnstile check (off unless both keys are set), and moves the account -code out of `routes.clj`, `views.cljs` and `events.cljs` into `routes/auth`, `views/auth` and -`events/auth`. - -## Added - -- **Accounts:** an optional Cloudflare Turnstile check on sign-up, password reset and resend verification, and on sign-in after a failed attempt. Off unless `TURNSTILE_SITE_KEY` and `TURNSTILE_SECRET_KEY` are set; if Cloudflare can't be reached, requests go through. -- **Accounts:** when the security check can't load, the form says so and suggests allowing challenges.cloudflare.com in an ad blocker. - -## Changed - -- **Accounts:** sign-up no longer says when an email is already in use. It answers as for a new address and emails the account's owner instead. Without a mail server, a taken address gets a plain refusal. -- **Accounts:** warnings about sign-in attempts on your account now follow up while attempts continue (at most every 6 hours, with a count), instead of once a day. - -## Fixed - -## Security - -- **Accounts:** account emails can no longer be triggered in bulk from one form that had no limit.