From 003264323252207eed20a81626590a550bea2efe Mon Sep 17 00:00:00 2001 From: "carpentry-heartbeat[bot]" Date: Fri, 12 Jun 2026 00:10:42 +0200 Subject: [PATCH] add configurable CORS middleware with defserver integration CORS.setup configures origin/methods/headers/max-age in one call. CORS.set-credentials! and CORS.set-expose-headers! control optional headers. The after-hook adds Vary: Origin for non-wildcard origins and conditionally adds credentials and expose-headers. A new (cors ...) form in defserver registers both hooks automatically, replacing the manual (before CORS.before-hook) / (after CORS.after-hook) pattern. CORS.configure is preserved for backward compatibility. --- CHANGELOG.md | 11 ++ test/cors_test.carp | 291 ++++++++++++++++++++++++++++++++++++++++++++ web.carp | 160 +++++++++++++++++------- 3 files changed, 420 insertions(+), 42 deletions(-) create mode 100644 test/cors_test.carp diff --git a/CHANGELOG.md b/CHANGELOG.md index 05608f5..34dc4ac 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,17 @@ ### Added +- **Configurable CORS middleware.** `CORS.setup` configures allowed origin, + methods, headers, and preflight max-age in one call. Individual setters + (`CORS.set-credentials!`, `CORS.set-expose-headers!`) control credentials + and exposed headers. The after-hook now adds `Vary: Origin` for non-wildcard + origins (correct cache behaviour) and optionally adds + `Access-Control-Allow-Credentials` and `Access-Control-Expose-Headers`. + A new `(cors ...)` form in `defserver` registers both hooks automatically: + `(cors @"*")` for defaults or + `(cors @"https://example.com" @"GET, POST" @"Content-Type" @"3600")` for + full configuration. + - **WebSocket fragment timeout and size limits.** Fragment accumulation now tracks per-connection timestamps via `ConnState.ws-frag-start`. `sweep-idle` closes connections where fragments have been accumulating diff --git a/test/cors_test.carp b/test/cors_test.carp new file mode 100644 index 0000000..7d8f8f2 --- /dev/null +++ b/test/cors_test.carp @@ -0,0 +1,291 @@ +(add-cflag "-Wno-incompatible-pointer-types-discards-qualifiers") +(load "Test.carp") +(load "../web.carp") +(use Test) + +; Helper: reset CORS to defaults +(defn cors-reset! [] + (do + (CORS.setup @"*" + @"GET, POST, PUT, DELETE, PATCH, OPTIONS" + @"Content-Type, Authorization" + @"86400") + (CORS.set-credentials! false) + (CORS.set-expose-headers! @""))) + +; Helper: get first header value or empty string +(defn get-header [resp key] + (let [vals (Map.get-with-default (Response.headers resp) key &[@""])] + @(Array.unsafe-first &vals))) + +(deftest test + ; --------------------------------------------------------------------------- + ; before-hook + ; --------------------------------------------------------------------------- + + ; -- passes through non-OPTIONS requests -- + (assert-true test + (do + (cors-reset!) + (let [req (Result.unsafe-from-success + (Request.parse "GET / HTTP/1.1\r\nHost: x\r\n\r\n")) + params (the (Map String String) {})] + (Maybe.nothing? &(CORS.before-hook &req ¶ms)))) + "CORS before-hook passes through non-OPTIONS requests") + + ; -- returns 204 for OPTIONS -- + (assert-equal test + 204 + (do + (cors-reset!) + (let [req (Result.unsafe-from-success + (Request.parse + "OPTIONS /api HTTP/1.1\r\nHost: x\r\nOrigin: http://example.com\r\n\r\n")) + params (the (Map String String) {})] + (match (CORS.before-hook &req ¶ms) + (Maybe.Just resp) @(Response.code &resp) + (Maybe.Nothing) 0))) + "CORS before-hook returns 204 for OPTIONS preflight") + + ; -- preflight includes configured methods -- + (assert-equal test + "GET, POST" + &(do + (CORS.setup @"*" @"GET, POST" @"Content-Type" @"86400") + (CORS.set-credentials! false) + (let [req (Result.unsafe-from-success + (Request.parse "OPTIONS / HTTP/1.1\r\nHost: x\r\n\r\n")) + params (the (Map String String) {})] + (match (CORS.before-hook &req ¶ms) + (Maybe.Just resp) (get-header &resp "Access-Control-Allow-Methods") + (Maybe.Nothing) @""))) + "CORS preflight includes configured methods") + + ; -- preflight includes configured headers -- + (assert-equal test + "X-Custom, Authorization" + &(do + (CORS.setup @"*" @"GET" @"X-Custom, Authorization" @"600") + (CORS.set-credentials! false) + (let [req (Result.unsafe-from-success + (Request.parse "OPTIONS / HTTP/1.1\r\nHost: x\r\n\r\n")) + params (the (Map String String) {})] + (match (CORS.before-hook &req ¶ms) + (Maybe.Just resp) (get-header &resp "Access-Control-Allow-Headers") + (Maybe.Nothing) @""))) + "CORS preflight includes configured headers") + + ; -- preflight includes configured max-age -- + (assert-equal test + "600" + &(do + (CORS.setup @"*" @"GET" @"Content-Type" @"600") + (CORS.set-credentials! false) + (let [req (Result.unsafe-from-success + (Request.parse "OPTIONS / HTTP/1.1\r\nHost: x\r\n\r\n")) + params (the (Map String String) {})] + (match (CORS.before-hook &req ¶ms) + (Maybe.Just resp) (get-header &resp "Access-Control-Max-Age") + (Maybe.Nothing) @""))) + "CORS preflight includes configured max-age") + + ; -- preflight includes credentials when enabled -- + (assert-equal test + "true" + &(do + (CORS.setup @"https://example.com" @"GET" @"Content-Type" @"86400") + (CORS.set-credentials! true) + (let [req (Result.unsafe-from-success + (Request.parse "OPTIONS / HTTP/1.1\r\nHost: x\r\n\r\n")) + params (the (Map String String) {})] + (match (CORS.before-hook &req ¶ms) + (Maybe.Just resp) + (get-header &resp "Access-Control-Allow-Credentials") + (Maybe.Nothing) @""))) + "CORS preflight includes credentials when enabled") + + ; -- preflight omits credentials when disabled -- + (assert-true test + (do + (CORS.setup @"*" @"GET" @"Content-Type" @"86400") + (CORS.set-credentials! false) + (let [req (Result.unsafe-from-success + (Request.parse "OPTIONS / HTTP/1.1\r\nHost: x\r\n\r\n")) + params (the (Map String String) {})] + (match (CORS.before-hook &req ¶ms) + (Maybe.Just resp) + (not + (Map.contains? (Response.headers &resp) + "Access-Control-Allow-Credentials")) + (Maybe.Nothing) false))) + "CORS preflight omits credentials when disabled") + + ; --------------------------------------------------------------------------- + ; after-hook + ; --------------------------------------------------------------------------- + + ; -- adds Allow-Origin -- + (assert-equal test + "https://example.com" + &(do + (CORS.setup @"https://example.com" @"GET" @"Content-Type" @"86400") + (CORS.set-credentials! false) + (CORS.set-expose-headers! @"") + (let [req (Result.unsafe-from-success + (Request.parse "GET / HTTP/1.1\r\nHost: x\r\n\r\n")) + params (the (Map String String) {}) + resp (CORS.after-hook &req ¶ms (Response.text @"ok"))] + (get-header &resp "Access-Control-Allow-Origin"))) + "CORS after-hook adds configured origin") + + ; -- adds Vary: Origin for non-wildcard origin -- + (assert-equal test + "Origin" + &(do + (CORS.setup @"https://example.com" @"GET" @"Content-Type" @"86400") + (CORS.set-credentials! false) + (CORS.set-expose-headers! @"") + (let [req (Result.unsafe-from-success + (Request.parse "GET / HTTP/1.1\r\nHost: x\r\n\r\n")) + params (the (Map String String) {}) + resp (CORS.after-hook &req ¶ms (Response.text @"ok"))] + (get-header &resp "Vary"))) + "CORS after-hook adds Vary: Origin for non-wildcard origin") + + ; -- omits Vary for wildcard origin -- + (assert-true test + (do + (CORS.setup @"*" @"GET" @"Content-Type" @"86400") + (CORS.set-credentials! false) + (CORS.set-expose-headers! @"") + (let [req (Result.unsafe-from-success + (Request.parse "GET / HTTP/1.1\r\nHost: x\r\n\r\n")) + params (the (Map String String) {}) + resp (CORS.after-hook &req ¶ms (Response.text @"ok"))] + (not (Map.contains? (Response.headers &resp) "Vary")))) + "CORS after-hook omits Vary for wildcard origin") + + ; -- adds credentials on normal response -- + (assert-equal test + "true" + &(do + (CORS.setup @"https://example.com" @"GET" @"Content-Type" @"86400") + (CORS.set-credentials! true) + (CORS.set-expose-headers! @"") + (let [req (Result.unsafe-from-success + (Request.parse "GET / HTTP/1.1\r\nHost: x\r\n\r\n")) + params (the (Map String String) {}) + resp (CORS.after-hook &req ¶ms (Response.text @"ok"))] + (get-header &resp "Access-Control-Allow-Credentials"))) + "CORS after-hook includes credentials when enabled") + + ; -- omits credentials when disabled -- + (assert-true test + (do + (CORS.setup @"*" @"GET" @"Content-Type" @"86400") + (CORS.set-credentials! false) + (CORS.set-expose-headers! @"") + (let [req (Result.unsafe-from-success + (Request.parse "GET / HTTP/1.1\r\nHost: x\r\n\r\n")) + params (the (Map String String) {}) + resp (CORS.after-hook &req ¶ms (Response.text @"ok"))] + (not + (Map.contains? (Response.headers &resp) + "Access-Control-Allow-Credentials")))) + "CORS after-hook omits credentials when disabled") + + ; -- adds expose-headers -- + (assert-equal test + "X-Request-Id, X-Total" + &(do + (CORS.setup @"*" @"GET" @"Content-Type" @"86400") + (CORS.set-credentials! false) + (CORS.set-expose-headers! @"X-Request-Id, X-Total") + (let [req (Result.unsafe-from-success + (Request.parse "GET / HTTP/1.1\r\nHost: x\r\n\r\n")) + params (the (Map String String) {}) + resp (CORS.after-hook &req ¶ms (Response.text @"ok"))] + (get-header &resp "Access-Control-Expose-Headers"))) + "CORS after-hook adds expose-headers when configured") + + ; -- omits expose-headers when empty -- + (assert-true test + (do + (CORS.setup @"*" @"GET" @"Content-Type" @"86400") + (CORS.set-credentials! false) + (CORS.set-expose-headers! @"") + (let [req (Result.unsafe-from-success + (Request.parse "GET / HTTP/1.1\r\nHost: x\r\n\r\n")) + params (the (Map String String) {}) + resp (CORS.after-hook &req ¶ms (Response.text @"ok"))] + (not + (Map.contains? (Response.headers &resp) + "Access-Control-Expose-Headers")))) + "CORS after-hook omits expose-headers when empty") + + ; --------------------------------------------------------------------------- + ; Integration: CORS hooks with build-response + ; --------------------------------------------------------------------------- + + ; -- normal request gets Allow-Origin through pipeline -- + (assert-equal test + "*" + &(do + (cors-reset!) + (let [app (-> (App.create) (App.GET @"/" (fn [r p] (Response.text @"hi")))) + bh [(fn [req params] (CORS.before-hook req params))] + ah [(fn [req params resp] (CORS.after-hook req params resp))] + pair (web-build-response &app + &bh + &ah + &(String.to-bytes "GET / HTTP/1.1\r\nHost: x\r\n\r\n")) + resp @(Pair.a &pair)] + (get-header &resp "Access-Control-Allow-Origin"))) + "CORS hooks integrate with build-response pipeline") + + ; -- OPTIONS preflight returns 204 through pipeline -- + (assert-equal test + 204 + (do + (cors-reset!) + (let [app (-> (App.create) (App.GET @"/" (fn [r p] (Response.text @"hi")))) + bh [(fn [req params] (CORS.before-hook req params))] + ah [(fn [req params resp] (CORS.after-hook req params resp))] + pair (web-build-response &app + &bh + &ah + &(String.to-bytes "OPTIONS / HTTP/1.1\r\nHost: x\r\n\r\n")) + resp @(Pair.a &pair)] + @(Response.code &resp))) + "CORS preflight returns 204 through build-response") + + ; -- preflight response also gets Allow-Origin from after-hook -- + (assert-true test + (do + (cors-reset!) + (let [app (-> (App.create) (App.GET @"/" (fn [r p] (Response.text @"hi")))) + bh [(fn [req params] (CORS.before-hook req params))] + ah [(fn [req params resp] (CORS.after-hook req params resp))] + pair (web-build-response &app + &bh + &ah + &(String.to-bytes "OPTIONS / HTTP/1.1\r\nHost: x\r\n\r\n")) + resp @(Pair.a &pair)] + (Map.contains? (Response.headers &resp) "Access-Control-Allow-Origin"))) + "CORS preflight gets Allow-Origin from after-hook") + + ; --------------------------------------------------------------------------- + ; CORS.configure backward compatibility + ; --------------------------------------------------------------------------- + + (assert-equal test + "https://old-api.example.com" + &(do + (cors-reset!) + (CORS.configure @"https://old-api.example.com") + (let [req (Result.unsafe-from-success + (Request.parse "GET / HTTP/1.1\r\nHost: x\r\n\r\n")) + params (the (Map String String) {}) + resp (CORS.after-hook &req ¶ms (Response.text @"ok"))] + (get-header &resp "Access-Control-Allow-Origin"))) + "CORS.configure still works for backward compatibility")) diff --git a/web.carp b/web.carp index 684908e..edf64d9 100644 --- a/web.carp +++ b/web.carp @@ -2136,6 +2136,9 @@ fallback.") (hidden wsp-form?) (defndynamic wsp-form? [f] (and (list? f) (= 'WSP (car f)))) + (hidden cors-form?) + (defndynamic cors-form? [f] (and (list? f) (= 'cors (car f)))) + (hidden route-form?) (defndynamic route-form? [f] (and (list? f) @@ -2149,7 +2152,8 @@ fallback.") (= 'static (car f)) (= 'before (car f)) (= 'after (car f)) - (= 'errors (car f))))) + (= 'errors (car f)) + (= 'cors (car f))))) (hidden route-call) (defndynamic route-call [r] @@ -2244,28 +2248,75 @@ For multi-core scaling, run several copies behind a TCP load balancer.") (def methods @"GET, POST, PUT, DELETE, PATCH, OPTIONS") (def headers @"Content-Type, Authorization") (def max-age @"86400") + (def credentials false) + (def expose-headers @"") + + (doc setup "configures CORS with the given origin, methods, headers, and +max-age. Call before the server starts, or use the `(cors ...)` form +in [`defserver`](#defserver) for a one-liner. + +``` +(CORS.setup @\"https://example.com\" + @\"GET, POST, OPTIONS\" + @\"Content-Type, Authorization\" + @\"86400\") +```") + (defn setup [o m h ma] + (do (set! origin o) (set! methods m) (set! headers h) (set! max-age ma))) - (doc configure "sets the allowed origin for CORS. Call before the server -starts. The default is `*` (all origins).") + (doc configure "sets the allowed origin for CORS. For full configuration +use [`setup`](#setup) or the `(cors ...)` form in `defserver`.") (defn configure [allowed-origin] (set! origin allowed-origin)) + (doc set-credentials! "enables or disables `Access-Control-Allow-Credentials`. +When enabled, the browser may send cookies and HTTP auth with cross-origin +requests. Note that `Access-Control-Allow-Origin` must not be `*` when +credentials are enabled.") + (defn set-credentials! [c] (set! credentials c)) + + (doc set-expose-headers! "sets the `Access-Control-Expose-Headers` value. +This controls which response headers the browser may access from JavaScript. +Pass an empty string to omit the header (the default).") + (defn set-expose-headers! [h] (set! expose-headers h)) + (doc before-hook "handles CORS preflight `OPTIONS` requests. Returns a `204 No Content` with the appropriate `Access-Control-*` headers. For -non-OPTIONS requests, continues to the handler.") +non-OPTIONS requests, returns `Nothing` so the request continues to the +route handler. The `Access-Control-Allow-Origin` header is added by +[`after-hook`](#after-hook) so it appears on both preflight and normal +responses.") (defn before-hook [req params] (if (= (Request.verb req) "OPTIONS") - ; Allow-Origin is added by after-hook; only set the other CORS headers here - (Maybe.Just - (-> (Response.text @"") - (Response.with-status 204 @"No Content") - (Response.with-header @"Access-Control-Allow-Methods" @&methods) - (Response.with-header @"Access-Control-Allow-Headers" @&headers) - (Response.with-header @"Access-Control-Max-Age" @&max-age))) + (let [r (-> (Response.text @"") + (Response.with-status 204 @"No Content") + (Response.with-header @"Access-Control-Allow-Methods" + @&methods) + (Response.with-header @"Access-Control-Allow-Headers" + @&headers) + (Response.with-header @"Access-Control-Max-Age" @&max-age))] + (Maybe.Just + (if credentials + (Response.with-header r @"Access-Control-Allow-Credentials" @"true") + r))) (Maybe.Nothing))) - (doc after-hook "adds `Access-Control-Allow-Origin` to every response.") + (doc after-hook "adds CORS response headers to every response. + +Always adds `Access-Control-Allow-Origin`. When the configured origin is +not `*`, also adds `Vary: Origin` so caches key on the request origin. +When credentials are enabled, adds `Access-Control-Allow-Credentials: true`. +When expose-headers is non-empty, adds `Access-Control-Expose-Headers`.") (defn after-hook [req params resp] - (Response.with-header resp @"Access-Control-Allow-Origin" @&origin))) + (let [r1 (Response.with-header resp @"Access-Control-Allow-Origin" @&origin) + r2 (if (= &origin "*") r1 (Response.with-header r1 @"Vary" @"Origin")) + r3 (if credentials + (Response.with-header r2 @"Access-Control-Allow-Credentials" @"true") + r2)] + (if (> (String.length &expose-headers) 0) + (Response.with-header r3 + @"Access-Control-Expose-Headers" + @&expose-headers) + r3)))) ; --------------------------------------------------------------------------- ; Cookie response helper @@ -2343,51 +2394,76 @@ Each route is `(METHOD \"/path\" handler)` where METHOD is one of `GET`, `POST`, `PUT`, `DELETE`, or `PATCH`. Any other form in the body is evaluated as a setup expression before the server starts, in source order. +Use `(cors origin)` or `(cors origin methods headers max-age)` to enable +CORS with automatic preflight handling. This registers +[`CORS.before-hook`](#before-hook) and [`CORS.after-hook`](#after-hook) +and configures the CORS module. + ``` (defserver \"0.0.0.0\" 3000 - (Item.create-table &db) + (cors @\"https://example.com\" @\"GET, POST\" @\"Content-Type\" @\"3600\") (GET \"/api/todos\" api-list) (POST \"/api/todos\" api-add) (DELETE \"/api/todos/:id\" api-delete)) -``` - -is equivalent to: - -``` -(defn main [] - (let [app (-> (App.create) (App.GET @\"/\" hello)) - bh (the (Array (Fn [&Request] (Maybe Response))) []) - ah (the (Array (Fn [&Request Response] Response)) [])] - (App.serve &app &bh &ah \"0.0.0.0\" 3000))) ```") (defmacro defserver [host port :rest body] - (let [; Separate routes, hooks, and setup expressions + (let [; Separate routes, hooks, cors, and setup expressions + cors-forms (filter App.cors-form? body) routes (filter (fn [f] (and (App.route-form? f) (not (App.before-form? f)) - (not (App.after-form? f)))) + (not (App.after-form? f)) + (not (App.cors-form? f)))) body) befores (filter App.before-form? body) afters (filter App.after-form? body) setup (filter (fn [f] (not (App.route-form? f))) body) ; Build the app with routes app-form (cons '-> (cons '(App.create) (map App.route-call routes))) + ; Generate CORS setup calls + cors-setup (map + (fn [f] + (if (= (length f) 2) + (list 'CORS.configure (cadr f)) + (list 'CORS.setup + (cadr f) + (caddr f) + (car (cdr (cdr (cdr f)))) + (car (cdr (cdr (cdr (cdr f)))))))) + cors-forms) + ; CORS hooks (prepend before, append after) + cors-bh (unless (empty? cors-forms) + (list (list 'fn ['req 'params] (list 'CORS.before-hook 'req 'params)))) + cors-ah (unless (empty? cors-forms) + (list + (list 'fn + ['req 'params 'resp] + (list 'CORS.after-hook 'req 'params 'resp)))) ; Build hook arrays as lambdas wrapping the user's functions - before-arr (collect-into - (map - (fn [f] (list 'fn ['req 'params] (list (cadr f) 'req 'params))) - befores) - array) - after-arr (collect-into - (map - (fn [f] - (list 'fn ['req 'params 'resp] (list (cadr f) 'req 'params 'resp))) - afters) - array) - body-forms (append setup - (list - (list 'let - ['app app-form 'bh before-arr 'ah after-arr] - (list 'App.serve '&app '&bh '&ah host port))))] + explicit-bh (map + (fn [f] (list 'fn ['req 'params] (list (cadr f) 'req 'params))) + befores) + explicit-ah (map + (fn [f] + (list 'fn ['req 'params 'resp] (list (cadr f) 'req 'params 'resp))) + afters) + before-arr (collect-into (append cors-bh explicit-bh) array) + after-arr (collect-into (append explicit-ah cors-ah) array) + body-forms (append cors-setup + (append setup + (list + (list 'let + ['app + app-form + 'bh + before-arr + 'ah + after-arr] + (list 'App.serve + '&app + '&bh + '&ah + host + port)))))] (eval (list 'defn 'main (array) (cons 'do body-forms)))))