From b6870e05387648bd0557d0a0870c32b98313d3d7 Mon Sep 17 00:00:00 2001 From: "carpentry-heartbeat[bot]" Date: Sun, 7 Jun 2026 04:05:21 +0200 Subject: [PATCH 1/2] add HEAD method support and ETag-based conditional responses HEAD requests match GET routes and return identical headers with an empty body. Response.file and Response.sendfile compute SHA-1 ETags; requests with matching If-None-Match get 304 Not Modified. --- CHANGELOG.md | 18 +++++ test/web.carp | 182 ++++++++++++++++++++++++++++++++++++++++++++++- web.carp | 190 +++++++++++++++++++++++++++++++++++++++----------- 3 files changed, 350 insertions(+), 40 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index b3ec30c..963c6ba 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,20 @@ ### Added +- **HEAD method support** (RFC 7231). HEAD requests automatically match GET + routes and return the same headers (including `Content-Length`) but with an + empty body. For `sendfile` responses, the file size is computed for + `Content-Length` without transferring the file data. + +- **ETag-based conditional responses for static files.** `Response.file` and + `Response.sendfile` now compute an `ETag` header from the SHA-1 hash of + the file contents. When a request includes an `If-None-Match` header that + matches the response's `ETag`, the server returns `304 Not Modified` + with no body, eliminating redundant file transfers. + +- `SHA1.hex-digest` computes the SHA-1 digest of a byte array and returns + it as a 40-character lowercase hex string. + - **WebSocket subprotocol negotiation** (RFC 6455 §4.2.2). `App.WSP` registers a WebSocket route with a list of supported subprotocols. During the upgrade handshake, the server selects the first client-requested protocol that appears @@ -47,6 +61,10 @@ ### Fixed +- **`web-finalize-response` preserves explicit Content-Length.** When a response + already has a `Content-Length` header (e.g. HEAD responses), finalization no + longer overrides it with the body length. + - **Content-Length no longer sent with chunked encoding.** `web-finalize-response` now skips the `Content-Length` header when `Transfer-Encoding` is already set, fixing an RFC 7230 §3.3.2 violation. diff --git a/test/web.carp b/test/web.carp index 7fbe99d..f2e6b56 100644 --- a/test/web.carp +++ b/test/web.carp @@ -495,4 +495,184 @@ (Request.parse "GET / HTTP/1.1\r\nHost: x\r\n\r\n")) params (the (Map String String) {})] @(Response.code &(log-after &req ¶ms (Response.text @"ok")))) - "log-after does not crash without _start param")) + "log-after does not crash without _start param") + + ; --------------------------------------------------------------------------- + ; SHA1.hex-digest tests + ; --------------------------------------------------------------------------- + + ; hex-digest returns a 40-char lowercase hex string + (assert-true test + (= 40 (String.length &(SHA1.hex-digest &(the (Array Byte) [])))) + "SHA1 hex-digest returns 40 chars") + + ; hex-digest is deterministic (same input -> same output) + (assert-true test + (= + &(SHA1.hex-digest &(String.to-bytes "hello")) + &(SHA1.hex-digest &(String.to-bytes "hello"))) + "SHA1 hex-digest is deterministic") + + ; different inputs produce different digests + (assert-true test + (/= + &(SHA1.hex-digest &(String.to-bytes "hello")) + &(SHA1.hex-digest &(String.to-bytes "world"))) + "SHA1 hex-digest differs for different inputs") + + ; --------------------------------------------------------------------------- + ; HEAD method routing tests + ; --------------------------------------------------------------------------- + + ; -- HEAD matches GET routes -- + (assert-true test + (let [app (-> (App.create) + (App.GET @"/hello" (fn [r p] (Response.text @"hi")))) + req (Result.unsafe-from-success + (Request.parse "HEAD /hello HTTP/1.1\r\nHost: x\r\n\r\n"))] + (Maybe.just? &(web-find-handler (App.routes &app) &req))) + "HEAD matches GET route") + + ; -- HEAD does not match POST routes -- + (assert-true test + (let [app (-> (App.create) + (App.POST @"/data" (fn [r p] (Response.text @"ok")))) + req (Result.unsafe-from-success + (Request.parse "HEAD /data HTTP/1.1\r\nHost: x\r\n\r\n"))] + (Maybe.nothing? &(web-find-handler (App.routes &app) &req))) + "HEAD does not match POST route") + + ; -- HEAD response strips body -- + (assert-true test + (let [app (-> (App.create) + (App.GET @"/hello" (fn [r p] (Response.text @"hi")))) + req @"HEAD /hello HTTP/1.1\r\nHost: x\r\n\r\n" + bh (the + (Array (Fn [&Request &(Map String String)] (Maybe Response))) + []) + ah (the + (Array (Fn [&Request &(Map String String) Response] Response)) + []) + pair (web-build-response &app &bh &ah &(String.to-bytes &req))] + (String.empty? (Response.body (Pair.a &pair)))) + "HEAD response has empty body") + + ; -- HEAD preserves Content-Length from GET body -- + (assert-true test + (let [app (-> (App.create) + (App.GET @"/hello" (fn [r p] (Response.text @"hi")))) + req @"HEAD /hello HTTP/1.1\r\nHost: x\r\n\r\n" + bh (the + (Array (Fn [&Request &(Map String String)] (Maybe Response))) + []) + ah (the + (Array (Fn [&Request &(Map String String) Response] Response)) + []) + pair (web-build-response &app &bh &ah &(String.to-bytes &req)) + resp @(Pair.a &pair) + cl-vals (Map.get-with-default (Response.headers &resp) + "Content-Length" + &[@"0"])] + (= (Array.unsafe-first &cl-vals) "2")) + "HEAD preserves Content-Length from GET body") + + ; --------------------------------------------------------------------------- + ; ETag / If-None-Match tests + ; --------------------------------------------------------------------------- + + ; -- web-etag-match? returns false without If-None-Match -- + (assert-false test + (let [req (Result.unsafe-from-success + (Request.parse "GET / HTTP/1.1\r\nHost: x\r\n\r\n")) + resp (Response.with-header (Response.text @"hi") @"ETag" @"\"abc\"")] + (web-etag-match? &req &resp)) + "etag-match? false without If-None-Match") + + ; -- web-etag-match? returns true on match -- + (assert-true test + (let [req (Result.unsafe-from-success + (Request.parse + "GET / HTTP/1.1\r\nHost: x\r\nIf-None-Match: \"abc\"\r\n\r\n")) + resp (Response.with-header (Response.text @"hi") @"ETag" @"\"abc\"")] + (web-etag-match? &req &resp)) + "etag-match? true when ETags match") + + ; -- web-etag-match? returns false on mismatch -- + (assert-false test + (let [req (Result.unsafe-from-success + (Request.parse + "GET / HTTP/1.1\r\nHost: x\r\nIf-None-Match: \"xyz\"\r\n\r\n")) + resp (Response.with-header (Response.text @"hi") @"ETag" @"\"abc\"")] + (web-etag-match? &req &resp)) + "etag-match? false when ETags differ") + + ; -- 304 Not Modified on matching ETag -- + (assert-equal test + 304 + (let [app (-> (App.create) + (App.GET @"/" + (fn [r p] + (Response.with-header (Response.text @"hi") + @"ETag" + @"\"abc\"")))) + req @"GET / HTTP/1.1\r\nHost: x\r\nIf-None-Match: \"abc\"\r\n\r\n" + bh (the + (Array (Fn [&Request &(Map String String)] (Maybe Response))) + []) + ah (the + (Array (Fn [&Request &(Map String String) Response] Response)) + []) + pair (web-build-response &app &bh &ah &(String.to-bytes &req))] + @(Response.code (Pair.a &pair))) + "matching If-None-Match returns 304") + + ; -- 304 preserves ETag header -- + (assert-true test + (let [app (-> (App.create) + (App.GET @"/" + (fn [r p] + (Response.with-header (Response.text @"hi") + @"ETag" + @"\"abc\"")))) + req @"GET / HTTP/1.1\r\nHost: x\r\nIf-None-Match: \"abc\"\r\n\r\n" + bh (the + (Array (Fn [&Request &(Map String String)] (Maybe Response))) + []) + ah (the + (Array (Fn [&Request &(Map String String) Response] Response)) + []) + pair (web-build-response &app &bh &ah &(String.to-bytes &req)) + resp @(Pair.a &pair)] + (Map.contains? (Response.headers &resp) "ETag")) + "304 response preserves ETag header") + + ; -- No 304 when ETags differ -- + (assert-equal test + 200 + (let [app (-> (App.create) + (App.GET @"/" + (fn [r p] + (Response.with-header (Response.text @"hi") + @"ETag" + @"\"abc\"")))) + req @"GET / HTTP/1.1\r\nHost: x\r\nIf-None-Match: \"xyz\"\r\n\r\n" + bh (the + (Array (Fn [&Request &(Map String String)] (Maybe Response))) + []) + ah (the + (Array (Fn [&Request &(Map String String) Response] Response)) + []) + pair (web-build-response &app &bh &ah &(String.to-bytes &req))] + @(Response.code (Pair.a &pair))) + "mismatched If-None-Match returns 200") + + ; -- finalize preserves explicit Content-Length -- + (assert-true test + (let [resp (-> (Response.text @"") + (Response.with-header @"Content-Length" @"42")) + final (web-finalize-response resp true) + cl (Map.get-with-default (Response.headers &final) + "Content-Length" + &[@"0"])] + (= (Array.unsafe-first &cl) "42")) + "finalize preserves explicit Content-Length")) diff --git a/web.carp b/web.carp index e072003..55a3b47 100644 --- a/web.carp +++ b/web.carp @@ -152,7 +152,20 @@ (* (Long.from-int (- 3 j)) 8l)) 255l))))))) - result))))) + result)))) + + (doc hex-digest "computes the SHA-1 digest of a byte array and returns it +as a 40-character lowercase hex string.") + (defn hex-digest [data] + (let-do [d (digest data) + hex @"0123456789abcdef" + out (Array.replicate 40 &\0)] + (for [i 0 20] + (let-do [b (Byte.to-int @(Array.unsafe-nth &d i))] + (Array.aset! &out (* i 2) (String.char-at &hex (bit-shift-right b 4))) + (Array.aset! &out (+ (* i 2) 1) (String.char-at &hex (bit-and b 15))))) + (String.from-chars &out)))) +; end defmodule SHA1 ; --------------------------------------------------------------------------- ; Base64 encoding (RFC 4648) @@ -325,7 +338,8 @@ based on its extension. Unknown extensions return `application/octet-stream`.") (doc file "creates a 200 OK response by reading `path` from disk. Returns a 404 Not Found response if the file is missing or unreadable. The `Content-Type` header is inferred from the file extension via -[`content-type-for`](#content-type-for).") +[`content-type-for`](#content-type-for). An `ETag` header is computed +from the SHA-1 hash of the file contents.") (defn file [path] (match (File.open-with path "r") (Result.Error _) (not-found) @@ -333,11 +347,15 @@ a 404 Not Found response if the file is missing or unreadable. The (match (File.read-all &f) (Result.Error _) (do (File.close f) (not-found)) (Result.Success contents) - (let [k @"Content-Type" - v [(content-type-for path)]] - (do - (File.close f) - (init 200 @"OK" @"HTTP/1.1" [] (Map.put {} &k &v) contents)))))) + (let-do [ct-k @"Content-Type" + ct-v [(content-type-for path)] + etag (fmt "\"%s\"" + &(SHA1.hex-digest &(String.to-bytes &contents))) + et-k @"ETag" + et-v [etag] + hdrs (Map.put (Map.put {} &ct-k &ct-v) &et-k &et-v)] + (File.close f) + (init 200 @"OK" @"HTTP/1.1" [] hdrs contents))))) (doc chunked "creates a response with `Transfer-Encoding: chunked`. @@ -373,11 +391,27 @@ avoiding the user-space copy. Falls back to [`file`](#file) if the server does not detect the `X-Sendfile` header. The `Content-Type` is inferred from the extension. The server sets -`Content-Length` from the file size.") +`Content-Length` from the file size. An `ETag` header is computed from +the SHA-1 hash of the file contents.") (defn sendfile [path] - (-> (init 200 @"OK" @"HTTP/1.1" [] {} @"") - (with-header @"Content-Type" (content-type-for path)) - (with-header @"X-Sendfile" @path)))) + (let [etag (match (File.open-with path "r") + (Result.Error _) @"" + (Result.Success f) + (match (File.read-all &f) + (Result.Error _) (do (File.close f) @"") + (Result.Success contents) + (let-do [h (fmt "\"%s\"" + &(SHA1.hex-digest &(String.to-bytes &contents)))] + (File.close f) + h)))] + (if (String.empty? &etag) + (-> (init 200 @"OK" @"HTTP/1.1" [] {} @"") + (with-header @"Content-Type" (content-type-for path)) + (with-header @"X-Sendfile" @path)) + (-> (init 200 @"OK" @"HTTP/1.1" [] {} @"") + (with-header @"Content-Type" (content-type-for path)) + (with-header @"X-Sendfile" @path) + (with-header @"ETag" etag)))))) ; --------------------------------------------------------------------------- ; Form parsing @@ -923,10 +957,11 @@ responses. The `protocols` field lists the subprotocols that this route supports (defn web-finalize-response [resp keep-alive] (let [body-len (String.length (Response.body &resp)) has-te (Map.contains? (Response.headers &resp) "Transfer-Encoding") + has-cl (Map.contains? (Response.headers &resp) "Content-Length") conn-k @"Connection" conn-v [(if keep-alive @"keep-alive" @"close")] h (let [base (Map.put @(Response.headers &resp) &conn-k &conn-v)] - (if has-te + (if (or has-te has-cl) base (let [cl-k @"Content-Length" cl-v [(Int.str body-len)]] @@ -971,10 +1006,14 @@ responses. The `protocols` field lists the subprotocols that this route supports (defn web-find-handler [routes req] (let-do [result (the (Maybe (Pair Int (Map String String))) (Maybe.Nothing)) - path (web-routable-path req)] + path (web-routable-path req) + verb (Request.verb req) + ; RFC 7231: HEAD must match GET routes when no explicit HEAD route + is-head (= verb "HEAD")] (for [i 0 (Array.length routes)] (let [r (Array.unsafe-nth routes i)] - (when (= (Route.method r) (Request.verb req)) + (when (or (= (Route.method r) verb) + (and is-head (= (Route.method r) "GET"))) (match (match-route (Route.pattern r) &path) (Maybe.Just params) (do (set! result (Maybe.Just (Pair.init i params))) (break)) @@ -1001,8 +1040,7 @@ responses. The `protocols` field lists the subprotocols that this route supports result (the (Array String) [])] (for [i 0 (Array.length parts)] (let [trimmed (String.trim (Array.unsafe-nth parts i))] - (when (> (String.length &trimmed) 0) - (Array.push-back! &result trimmed)))) + (when (> (String.length &trimmed) 0) (Array.push-back! &result trimmed)))) result)) ; Select the first client-requested protocol that appears in the server's @@ -1016,9 +1054,10 @@ responses. The `protocols` field lists the subprotocols that this route supports (for [j 0 (Array.length server-protos)] (when (= (Array.unsafe-nth client-protos i) (Array.unsafe-nth server-protos j)) - (do (set! result (Maybe.Just @(Array.unsafe-nth client-protos i))) - (set! found true) - (break)))) + (do + (set! result (Maybe.Just @(Array.unsafe-nth client-protos i))) + (set! found true) + (break)))) (when found (break)))) result)) @@ -1029,8 +1068,9 @@ responses. The `protocols` field lists the subprotocols that this route supports (hidden web-try-ws-upgrade) (defn web-try-ws-upgrade [buf ws-routes] (if (= 0 (Array.length ws-routes)) - (the (Maybe (Pair String (Pair Int (Pair (Maybe String) (Map String String))))) - (Maybe.Nothing)) + (the + (Maybe (Pair String (Pair Int (Pair (Maybe String) (Map String String))))) + (Maybe.Nothing)) (let [raw &(String.from-bytes buf)] (match (Request.parse raw) (Result.Error _) (Maybe.Nothing) @@ -1054,8 +1094,8 @@ responses. The `protocols` field lists the subprotocols that this route supports false) ; RFC 6455 §4.2.1: Sec-WebSocket-Protocol (optional) proto-vals (Map.get-with-default (Request.headers &req) - "Sec-WebSocket-Protocol" - &(the (Array String) [])) + "Sec-WebSocket-Protocol" + &(the (Array String) [])) client-protos (if (> (Array.length &proto-vals) 0) (ws-parse-protocols (Array.unsafe-first &proto-vals)) (the (Array String) []))] @@ -1064,24 +1104,25 @@ responses. The `protocols` field lists the subprotocols that this route supports ; Bad or missing version — signal with route-idx -1 (Maybe.Just (Pair.init @"" - (Pair.init -1 - (Pair.init (the (Maybe String) (Maybe.Nothing)) - (the (Map String String) {}))))) + (Pair.init -1 + (Pair.init (the (Maybe String) + (Maybe.Nothing)) + (the (Map String String) {}))))) (let [path (web-routable-path &req)] (match (web-find-ws-handler ws-routes &path) (Maybe.Just route-match) (let [ri @(Pair.a &route-match) params @(Pair.b &route-match) - server-protos (WSRoute.protocols - (Array.unsafe-nth ws-routes ri)) + server-protos (WSRoute.protocols (Array.unsafe-nth ws-routes + ri)) negotiated (if (> (Array.length &client-protos) 0) - (ws-negotiate-protocol &client-protos server-protos) + (ws-negotiate-protocol &client-protos + server-protos) (the (Maybe String) (Maybe.Nothing)))] (Maybe.Just (Pair.init (ws-accept-key (Array.unsafe-first &key-vals)) - (Pair.init ri - (Pair.init negotiated params))))) + (Pair.init ri (Pair.init negotiated params))))) (Maybe.Nothing) (Maybe.Nothing)))) (Maybe.Nothing))))))) @@ -1102,6 +1143,59 @@ responses. The `protocols` field lists the subprotocols that this route supports (set! r (~(Array.unsafe-nth hooks i) req params r))) r)) +; Strip the response body for HEAD requests while preserving Content-Length. +; For sendfile responses, computes Content-Length from the file and removes +; X-Sendfile so the server does not attempt a file transfer. +(hidden web-strip-head-body) +(defn web-strip-head-body [resp] + (match (web-sendfile-path &resp) + (Maybe.Just sf-path) + (let [ffd (IO.Raw.open &sf-path IO.Raw.O-RDONLY)] + (if (< ffd 0) + (Response.not-found) + (let-do [sz (IO.Raw.fstat-size ffd)] + (ignore (IO.Raw.close-fd ffd)) + (if (< sz 0l) + (Response.not-found) + (let [hdrs (Map.remove @(Response.headers &resp) &@"X-Sendfile") + cl-k @"Content-Length" + cl-v [(Long.str sz)]] + (-> resp + (Response.set-body @"") + (Response.set-headers (Map.put hdrs &cl-k &cl-v)))))))) + (Maybe.Nothing) + (let [body-len (String.length (Response.body &resp)) + hdrs @(Response.headers &resp) + cl-k @"Content-Length" + cl-v [(Int.str body-len)]] + (-> resp + (Response.set-body @"") + (Response.set-headers (Map.put hdrs &cl-k &cl-v)))))) + +; Check If-None-Match against a response's ETag header. +; Returns true if the request's If-None-Match matches the response's ETag. +(hidden web-etag-match?) +(defn web-etag-match? [req resp] + (match (Request.header req "If-None-Match") + (Maybe.Nothing) false + (Maybe.Just inm) + (match (Map.get-maybe (Response.headers resp) "ETag") + (Maybe.Nothing) false + (Maybe.Just vals) + (if (= (Array.length &vals) 0) + false + (= &inm (Array.unsafe-first &vals)))))) + +; Build a 304 Not Modified response, preserving the ETag header. +(hidden web-not-modified) +(defn web-not-modified [resp] + (let [etag-vals (Map.get-with-default (Response.headers &resp) "ETag" &[])] + (if (= (Array.length &etag-vals) 0) + (Response.init 304 @"Not Modified" @"HTTP/1.1" [] {} @"") + (let [k @"ETag" + v [@(Array.unsafe-first &etag-vals)]] + (Response.init 304 @"Not Modified" @"HTTP/1.1" [] (Map.put {} &k &v) @""))))) + ; Build the response for a complete request. Returns `(Pair Response Bool)`. (defn web-build-response [app before-hooks after-hooks buf] (let [raw &(String.from-bytes buf)] @@ -1109,6 +1203,7 @@ responses. The `protocols` field lists the subprotocols that this route supports (Result.Error _) (Pair.init (Response.bad-request) false) (Result.Success req) (let [ka (web-keep-alive? &req) + is-head (= (Request.verb &req) "HEAD") route-match (web-find-handler (App.routes app) &req) handler-idx (match-ref &route-match (Maybe.Just p) @(Pair.a p) @@ -1123,7 +1218,13 @@ responses. The `protocols` field lists the subprotocols that this route supports (~(App.error-handler app) &req 404 @"Not Found") (let [r (Array.unsafe-nth (App.routes app) handler-idx)] (~(Route.handler r) &req ¶ms)))) - final (web-run-after after-hooks &req ¶ms resp)] + after-resp (web-run-after after-hooks &req ¶ms resp) + ; ETag conditional: return 304 if If-None-Match matches + cond-resp (if (web-etag-match? &req &after-resp) + (web-not-modified after-resp) + after-resp) + ; HEAD: strip body, preserve Content-Length + final (if is-head (web-strip-head-body cond-resp) cond-resp)] (Pair.init final ka))))) ; Check if a response has an X-Sendfile header and extract the path. @@ -1399,14 +1500,25 @@ fallback.") (Array.push-back! wbuf @(Array.unsafe-nth frame j)))))) (hidden handle-ws-upgrade) - (defn handle-ws-upgrade [cs ws-routes poll fd stream accept route-idx proto params] + (defn handle-ws-upgrade [cs + ws-routes + poll + fd + stream + accept + route-idx + proto + params] (let-do [resp-str (match-ref proto (Maybe.Just p) - (fmt "HTTP/1.1 101 Switching Protocols\r\nUpgrade: websocket\r\nConnection: Upgrade\r\nSec-WebSocket-Accept: %s\r\nSec-WebSocket-Protocol: %s\r\n\r\n" - accept p) + (fmt + "HTTP/1.1 101 Switching Protocols\r\nUpgrade: websocket\r\nConnection: Upgrade\r\nSec-WebSocket-Accept: %s\r\nSec-WebSocket-Protocol: %s\r\n\r\n" + accept + p) (Maybe.Nothing) - (fmt "HTTP/1.1 101 Switching Protocols\r\nUpgrade: websocket\r\nConnection: Upgrade\r\nSec-WebSocket-Accept: %s\r\n\r\n" - accept)) + (fmt + "HTTP/1.1 101 Switching Protocols\r\nUpgrade: websocket\r\nConnection: Upgrade\r\nSec-WebSocket-Accept: %s\r\n\r\n" + accept)) wbuf (String.to-bytes &resp-str) ws (WebSocket.init fd @proto [])] (~(WSRoute.handler (Array.unsafe-nth ws-routes route-idx)) &(WSEvent.Connect) @@ -1904,8 +2016,8 @@ fallback.") (App.before-form? r) (list 'App.use-before (cadr r)) (App.after-form? r) (list 'App.use-after (cadr r)) (App.errors-form? r) (list 'App.set-error (cadr r)) - (App.wsp-form? r) (list 'App.WSP (list 'copy (cadr r)) (caddr r) - (car (cdr (cdr (cdr r))))) + (App.wsp-form? r) + (list 'App.WSP (list 'copy (cadr r)) (caddr r) (car (cdr (cdr (cdr r))))) (list (Symbol.prefix 'App (car r)) (list 'copy (cadr r)) (caddr r)))) ; ----------------------------------------------------------------------- From bba79098f0bd3a69b6bc8b6374aff0f08c79c477 Mon Sep 17 00:00:00 2001 From: "carpentry-heartbeat[bot]" Date: Sun, 7 Jun 2026 10:47:01 +0200 Subject: [PATCH 2/2] fix sendfile ETag and HEAD+chunked header conflict MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit sendfile: compute ETag from file metadata (mtime+size) instead of reading the entire file, preserving the zero-copy design. HEAD+chunked: when Transfer-Encoding is present, strip the body without adding Content-Length (RFC 7230 §3.3.2). --- CHANGELOG.md | 12 ++++++---- src/fstat_mtime.h | 12 ++++++++++ test/web.carp | 53 ++++++++++++++++++++++++++++++++++++++++++ web.carp | 59 +++++++++++++++++++++++++++++------------------ 4 files changed, 108 insertions(+), 28 deletions(-) create mode 100644 src/fstat_mtime.h diff --git a/CHANGELOG.md b/CHANGELOG.md index 963c6ba..4867e70 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,11 +9,13 @@ empty body. For `sendfile` responses, the file size is computed for `Content-Length` without transferring the file data. -- **ETag-based conditional responses for static files.** `Response.file` and - `Response.sendfile` now compute an `ETag` header from the SHA-1 hash of - the file contents. When a request includes an `If-None-Match` header that - matches the response's `ETag`, the server returns `304 Not Modified` - with no body, eliminating redundant file transfers. +- **ETag-based conditional responses for static files.** `Response.file` + computes an `ETag` from the SHA-1 hash of the file contents. + `Response.sendfile` computes an `ETag` from the file's modification time + and size, preserving its zero-copy design by avoiding a full file read. + When a request includes an `If-None-Match` header that matches the + response's `ETag`, the server returns `304 Not Modified` with no body, + eliminating redundant file transfers. - `SHA1.hex-digest` computes the SHA-1 digest of a byte array and returns it as a 40-character lowercase hex string. diff --git a/src/fstat_mtime.h b/src/fstat_mtime.h new file mode 100644 index 0000000..c8bd88e --- /dev/null +++ b/src/fstat_mtime.h @@ -0,0 +1,12 @@ +#include + +Long web_fstat_mtime(int fd) { +#ifdef _WIN32 + struct _stat64 st; + if (_fstat64(fd, &st) == -1) return -1; +#else + struct stat st; + if (fstat(fd, &st) == -1) return -1; +#endif + return (Long)st.st_mtime; +} diff --git a/test/web.carp b/test/web.carp index f2e6b56..f778399 100644 --- a/test/web.carp +++ b/test/web.carp @@ -576,6 +576,59 @@ (= (Array.unsafe-first &cl-vals) "2")) "HEAD preserves Content-Length from GET body") + ; -- HEAD + chunked omits Content-Length (RFC 7230 §3.3.2) -- + (assert-false test + (let [app (-> (App.create) + (App.GET @"/stream" + (fn [r p] + (Response.chunked 200 @"text/plain" &[@"hello"])))) + req @"HEAD /stream HTTP/1.1\r\nHost: x\r\n\r\n" + bh (the + (Array (Fn [&Request &(Map String String)] (Maybe Response))) + []) + ah (the + (Array (Fn [&Request &(Map String String) Response] Response)) + []) + pair (web-build-response &app &bh &ah &(String.to-bytes &req)) + resp @(Pair.a &pair)] + (Map.contains? (Response.headers &resp) "Content-Length")) + "HEAD + chunked omits Content-Length") + + ; -- HEAD + chunked preserves Transfer-Encoding -- + (assert-true test + (let [app (-> (App.create) + (App.GET @"/stream" + (fn [r p] + (Response.chunked 200 @"text/plain" &[@"hello"])))) + req @"HEAD /stream HTTP/1.1\r\nHost: x\r\n\r\n" + bh (the + (Array (Fn [&Request &(Map String String)] (Maybe Response))) + []) + ah (the + (Array (Fn [&Request &(Map String String) Response] Response)) + []) + pair (web-build-response &app &bh &ah &(String.to-bytes &req)) + resp @(Pair.a &pair)] + (Map.contains? (Response.headers &resp) "Transfer-Encoding")) + "HEAD + chunked preserves Transfer-Encoding") + + ; -- HEAD + chunked has empty body -- + (assert-true test + (let [app (-> (App.create) + (App.GET @"/stream" + (fn [r p] + (Response.chunked 200 @"text/plain" &[@"hello"])))) + req @"HEAD /stream HTTP/1.1\r\nHost: x\r\n\r\n" + bh (the + (Array (Fn [&Request &(Map String String)] (Maybe Response))) + []) + ah (the + (Array (Fn [&Request &(Map String String) Response] Response)) + []) + pair (web-build-response &app &bh &ah &(String.to-bytes &req))] + (String.empty? (Response.body (Pair.a &pair)))) + "HEAD + chunked has empty body") + ; --------------------------------------------------------------------------- ; ETag / If-None-Match tests ; --------------------------------------------------------------------------- diff --git a/web.carp b/web.carp index 55a3b47..578dde6 100644 --- a/web.carp +++ b/web.carp @@ -264,6 +264,15 @@ returns whatever `f` returns. If the key is missing, returns `default`.") (~f (Pair.b (Array.unsafe-nth (Bucket.entries bucket) i))) default))))) +; --------------------------------------------------------------------------- +; C helpers +; --------------------------------------------------------------------------- + +(relative-include "src/fstat_mtime.h") +(private web-fstat-mtime) +(hidden web-fstat-mtime) +(register web-fstat-mtime (Fn [Int] Long) "web_fstat_mtime") + ; --------------------------------------------------------------------------- ; Response helpers ; --------------------------------------------------------------------------- @@ -392,26 +401,26 @@ server does not detect the `X-Sendfile` header. The `Content-Type` is inferred from the extension. The server sets `Content-Length` from the file size. An `ETag` header is computed from -the SHA-1 hash of the file contents.") +the file's modification time and size, avoiding a full read of the +file contents.") (defn sendfile [path] - (let [etag (match (File.open-with path "r") - (Result.Error _) @"" - (Result.Success f) - (match (File.read-all &f) - (Result.Error _) (do (File.close f) @"") - (Result.Success contents) - (let-do [h (fmt "\"%s\"" - &(SHA1.hex-digest &(String.to-bytes &contents)))] - (File.close f) - h)))] - (if (String.empty? &etag) + (let [fd (IO.Raw.open path IO.Raw.O-RDONLY)] + (if (< fd 0) (-> (init 200 @"OK" @"HTTP/1.1" [] {} @"") (with-header @"Content-Type" (content-type-for path)) (with-header @"X-Sendfile" @path)) - (-> (init 200 @"OK" @"HTTP/1.1" [] {} @"") - (with-header @"Content-Type" (content-type-for path)) - (with-header @"X-Sendfile" @path) - (with-header @"ETag" etag)))))) + (let-do [sz (IO.Raw.fstat-size fd) + mt (web-fstat-mtime fd)] + (ignore (IO.Raw.close-fd fd)) + (if (or (< sz 0l) (< mt 0l)) + (-> (init 200 @"OK" @"HTTP/1.1" [] {} @"") + (with-header @"Content-Type" (content-type-for path)) + (with-header @"X-Sendfile" @path)) + (let [etag (fmt "\"%x-%x\"" mt sz)] + (-> (init 200 @"OK" @"HTTP/1.1" [] {} @"") + (with-header @"Content-Type" (content-type-for path)) + (with-header @"X-Sendfile" @path) + (with-header @"ETag" etag))))))))) ; --------------------------------------------------------------------------- ; Form parsing @@ -1146,6 +1155,8 @@ responses. The `protocols` field lists the subprotocols that this route supports ; Strip the response body for HEAD requests while preserving Content-Length. ; For sendfile responses, computes Content-Length from the file and removes ; X-Sendfile so the server does not attempt a file transfer. +; When Transfer-Encoding is present, strips the body without adding +; Content-Length (RFC 7230 Section 3.3.2). (hidden web-strip-head-body) (defn web-strip-head-body [resp] (match (web-sendfile-path &resp) @@ -1164,13 +1175,15 @@ responses. The `protocols` field lists the subprotocols that this route supports (Response.set-body @"") (Response.set-headers (Map.put hdrs &cl-k &cl-v)))))))) (Maybe.Nothing) - (let [body-len (String.length (Response.body &resp)) - hdrs @(Response.headers &resp) - cl-k @"Content-Length" - cl-v [(Int.str body-len)]] - (-> resp - (Response.set-body @"") - (Response.set-headers (Map.put hdrs &cl-k &cl-v)))))) + (if (Map.contains? (Response.headers &resp) "Transfer-Encoding") + (Response.set-body resp @"") + (let [body-len (String.length (Response.body &resp)) + hdrs @(Response.headers &resp) + cl-k @"Content-Length" + cl-v [(Int.str body-len)]] + (-> resp + (Response.set-body @"") + (Response.set-headers (Map.put hdrs &cl-k &cl-v))))))) ; Check If-None-Match against a response's ETag header. ; Returns true if the request's If-None-Match matches the response's ETag.