From d879f7cdf155af06bfdafca3f3829ece08090907 Mon Sep 17 00:00:00 2001 From: stepandra Date: Tue, 6 Oct 2026 21:09:54 +0900 Subject: [PATCH 01/13] feat(http-client): add byte-level sendSecure/sendRaw for PUT/HEAD/DELETE Generalize the existing getSecure/getRaw GET path into one method-agnostic primitive: raw Bytes body, non-throwing status codes, response headers, same redirect/proxy/TLS/size defaults. getSecure and getRaw become Get specializations. Spec: docs/changes/016-http-client-byte-level-methods.md. --- .../016-http-client-byte-level-methods.md | 12 ++ core/http/Http/Client.hs | 79 +++++++++-- core/http/Http/Client/Internal.hs | 33 ++++- core/test/Http/ClientRawSpec.hs | 134 ++++++++++++++++++ .../016-http-client-byte-level-methods.md | 71 ++++++++++ 5 files changed, 311 insertions(+), 18 deletions(-) create mode 100644 .changes/016-http-client-byte-level-methods.md create mode 100644 docs/changes/016-http-client-byte-level-methods.md diff --git a/.changes/016-http-client-byte-level-methods.md b/.changes/016-http-client-byte-level-methods.md new file mode 100644 index 000000000..8cabf0336 --- /dev/null +++ b/.changes/016-http-client-byte-level-methods.md @@ -0,0 +1,12 @@ +--- +group: platform +component: Framework +impact: compatible +category: Added +--- + +## Summary + +`Http.Client` can now send PUT, HEAD, DELETE, POST and PATCH requests with a raw byte body and read the status code and headers of every response, including 4xx and 5xx. Use `Http.Client.sendSecure method request body` for HTTPS services and `Http.Client.Internal.sendRaw` for trusted loopback endpoints. `Http.getSecure` and `getRaw` keep working exactly as before. + +Existing applications do not need code changes. To verify locally, run `./dev test "Http.Client" nhcore-test-core` and confirm the `sendRaw` and `sendSecure` examples pass. diff --git a/core/http/Http/Client.hs b/core/http/Http/Client.hs index 6cbcf1452..304022c62 100644 --- a/core/http/Http/Client.hs +++ b/core/http/Http/Client.hs @@ -12,8 +12,12 @@ module Http.Client ( Response (..), -- * HTTP Methods + Method (..), + methodName, get, getSecure, + sendSecure, + applyMethodAndBody, secureTlsSupportedVersions, checkContentLengthHeaderLimit, -- ^ Enforces HTTPS (rejects http:// URLs). Use for all external API calls. @@ -185,6 +189,24 @@ withMaxResponseSize maxBytes options = panic [fmt|withMaxResponseSize requires positive bytes, got: #{maxBytes}|] +-- | HTTP method for byte-level requests ('sendSecure', 'Http.Client.Internal.sendRaw'). +-- A closed set: protocol clients (object stores, webhooks) pick a verb from here +-- instead of spelling the wire token themselves. +data Method = Get | Head | Post | Put | Patch | Delete + deriving (Eq, Show) + + +-- | The wire token of a 'Method' ("GET", "HEAD", ...). +methodName :: Method -> Text +methodName method = case method of + Get -> "GET" + Head -> "HEAD" + Post -> "POST" + Put -> "PUT" + Patch -> "PATCH" + Delete -> "DELETE" + + data Error = Error Text | InvalidUrl Text -- ^ The URL does not use HTTPS. Use getSecure only with https:// URLs. @@ -338,7 +360,24 @@ cachedSecureTlsManager = GhcUnsafe.unsafePerformIO secureTlsManager getSecure :: Request -> Task Error (Response Bytes) -getSecure options = do +getSecure options = sendSecure Get options Bytes.empty + + +-- | Performs a byte-level request with any 'Method', enforcing HTTPS and TLS 1.2+. +-- +-- Built for protocol clients (object stores, signed webhooks) that need the +-- status code and headers of every response, including 4xx/5xx: this never +-- throws on a non-2xx status, never follows redirects beyond 'maxRedirects', +-- and never decodes the body. The request body is sent as-is; set +-- @Content-Type@ with 'addHeader'. The response body is bounded by +-- 'maxResponseBytes' exactly like 'getSecure'. +-- Use 'Http.Client.Internal.sendRaw' only for trusted loopback endpoints. +sendSecure :: + Method -> + Request -> + Bytes -> + Task Error (Response Bytes) +sendSecure method options body = do let urlText = options.url |> Maybe.withDefault "" case Text.startsWith "https://" urlText of False -> @@ -346,30 +385,37 @@ getSecure options = do Task.throw (InvalidUrl (sanitizeUrlText urlText)) True -> do let host = requestHost options - Log.debug [fmt|HTTP GET (secure) #{host}|] |> Task.ignoreError - secureResult <- getSecureRawIO options |> Task.fromIO + let verb = methodName method + Log.debug [fmt|HTTP #{verb} (secure) #{host}|] |> Task.ignoreError + secureResult <- sendSecureRawIO method options body |> Task.fromIO case secureResult of Err error -> Task.throw error Ok response -> checkResponseSize options response --- | Internal IO action for secure raw GET request using TLS 1.2+ only. -getSecureRawIO :: Request -> GhcIO.IO (Result Error (Response Bytes)) -getSecureRawIO options = do +-- | Internal IO action for a secure byte-level request using TLS 1.2+ only. +sendSecureRawIO :: Method -> Request -> Bytes -> GhcIO.IO (Result Error (Response Bytes)) +sendSecureRawIO method options body = do httpResult <- case options.maxResponseBytes of Nothing -> GhcException.try @HttpClient.HttpException do - response <- getRawIO options + response <- sendRawIO method options body pure (Ok response) Just _ -> GhcException.try @HttpClient.HttpException do baseReq <- parseRequestUrl options let req = baseReq |> applyRequestOptions options + |> applyMethodAndBody method body |> setRequestIgnoreStatus rawResponse <- HttpClient.responseOpen req cachedSecureTlsManager - case checkContentLengthHeaderLimit options.maxResponseBytes (HttpClient.responseHeaders rawResponse) of + -- A HEAD response announces the body it does NOT send; only the + -- post-read check applies to it. + let declaredLimit = case method of + Head -> Nothing + _ -> checkContentLengthHeaderLimit options.maxResponseBytes (HttpClient.responseHeaders rawResponse) + case declaredLimit of Just maxBytes -> do HttpClient.responseClose rawResponse pure (Err (ResponseTooLarge maxBytes)) @@ -384,20 +430,31 @@ getSecureRawIO options = do GhcEither.Right responseResult -> pure responseResult --- | Internal IO action for secure raw GET request using TLS 1.2+ only. -getRawIO :: +-- | Internal IO action for an unbounded secure byte-level request using TLS 1.2+ only. +sendRawIO :: + Method -> Request -> + Bytes -> GhcIO.IO (Response Bytes) -getRawIO options = do +sendRawIO method options body = do baseReq <- parseRequestUrl options let req = baseReq |> applyRequestOptions options + |> applyMethodAndBody method body |> setRequestIgnoreStatus |> HttpSimple.setRequestManager cachedSecureTlsManager httpResponse <- HttpSimple.httpBS req pure (extractResponseBytes httpResponse) +-- | Set the wire method and the raw request body. Shared with 'Http.Client.Internal'. +applyMethodAndBody :: Method -> Bytes -> HttpClient.Request -> HttpClient.Request +applyMethodAndBody method body req = + req + |> HttpSimple.setRequestMethod (methodName method |> Text.convert) + |> HttpSimple.setRequestBodyLBS (Bytes.toLazyLegacy body) + + readBodyFully :: HttpClient.BodyReader -> GhcIO.IO ByteString readBodyFully reader = readBodyChunks reader GhcBSChar.empty diff --git a/core/http/Http/Client/Internal.hs b/core/http/Http/Client/Internal.hs index 19fa029a8..e002a7a2c 100644 --- a/core/http/Http/Client/Internal.hs +++ b/core/http/Http/Client/Internal.hs @@ -3,6 +3,7 @@ module Http.Client.Internal -- | WARNING: Does NOT enforce HTTPS. Use 'Http.Client.getSecure' for external APIs. -- This module is for internal use only (e.g., localhost OAuth2 discovery per ADR-0018). getRaw, + sendRaw, ) where @@ -14,7 +15,7 @@ import Bytes qualified import Data.ByteString (ByteString) import Data.CaseInsensitive qualified as CI import Data.Either qualified as GhcEither -import Http.Client (Request (..), Response (..)) +import Http.Client (Method, Request (..), Response (..)) import Http.Client qualified as Http import Log qualified import Map qualified @@ -41,9 +42,24 @@ import ToText (toText) getRaw :: Http.Request -> Task Http.Error (Http.Response Bytes) -getRaw options = do - Log.debug "HTTP GET (raw/internal)" |> Task.ignoreError - response <- getRawInternalIO options +getRaw options = sendRaw Http.Get options Bytes.empty + + +-- | Performs a byte-level request with any 'Method' without enforcing HTTPS. +-- The plain-HTTP twin of 'Http.Client.sendSecure': same non-throwing status +-- handling, same response-size limit, same redirect/proxy defaults. +-- +-- WARNING: Does NOT enforce HTTPS. Only for trusted loopback endpoints +-- (local object-store fixtures, OAuth2 discovery per ADR-0018). +sendRaw :: + Method -> + Http.Request -> + Bytes -> + Task Http.Error (Http.Response Bytes) +sendRaw method options body = do + let verb = Http.methodName method + Log.debug [fmt|HTTP #{verb} (raw/internal)|] |> Task.ignoreError + response <- sendRawInternalIO method options body |> Task.fromFailableIO @HttpClient.HttpException |> Task.mapError sanitizeInternalHttpError case options.maxResponseBytes of @@ -54,15 +70,18 @@ getRaw options = do False -> Task.yield response --- | Internal IO action for raw GET request -getRawInternalIO :: +-- | Internal IO action for a raw byte-level request +sendRawInternalIO :: + Method -> Http.Request -> + Bytes -> GhcIO.IO (Http.Response Bytes) -getRawInternalIO options = do +sendRawInternalIO method options body = do baseReq <- parseRequestUrl options let req = baseReq |> applyRequestOptions options + |> Http.applyMethodAndBody method body |> setRequestIgnoreStatus httpResponse <- HttpSimple.httpBS req pure (extractResponseBytes httpResponse) diff --git a/core/test/Http/ClientRawSpec.hs b/core/test/Http/ClientRawSpec.hs index 4f0dd2038..9ed9d57bc 100644 --- a/core/test/Http/ClientRawSpec.hs +++ b/core/test/Http/ClientRawSpec.hs @@ -7,6 +7,7 @@ import Core import Http.Client qualified as Http import Http.Client.Internal qualified as HttpInternal import Json qualified +import Maybe qualified import Task qualified import Test import Text qualified @@ -114,11 +115,116 @@ spec = do Err (Http.ResponseTooLarge _) -> fail "Unexpected ResponseTooLarge from Internal.getRaw" Ok _ -> fail "Expected error for unreachable host" + describe "Http.Client.Internal.sendRaw" do + it "sendRaw PUT delivers method, raw body and custom header" \_ -> do + withMockServer mockEchoApp \testPort -> do + response <- + Http.request + |> Http.withUrl [fmt|http://localhost:#{testPort}/bucket/key|] + |> Http.addHeader "X-Probe" "sigv4" + |> (\req -> HttpInternal.sendRaw Http.Put req (Text.toBytes "payload-bytes")) + |> Task.asResult + case response of + Ok resp -> do + resp.statusCode |> shouldBe 200 + headerValue "X-Echo-Method" resp |> shouldBe (Just "PUT") + headerValue "X-Echo-Probe" resp |> shouldBe (Just "sigv4") + resp.body |> Text.fromBytes |> shouldBe "payload-bytes" + Err err -> fail [fmt|Expected Ok, got Err: #{show err}|] + + it "sendRaw HEAD returns headers and an empty body without throwing" \_ -> do + withMockServer mockEchoApp \testPort -> do + response <- + Http.request + |> Http.withUrl [fmt|http://localhost:#{testPort}/bucket/key|] + |> (\req -> HttpInternal.sendRaw Http.Head req Bytes.empty) + |> Task.asResult + case response of + Ok resp -> do + resp.statusCode |> shouldBe 200 + headerValue "X-Echo-Method" resp |> shouldBe (Just "HEAD") + resp.body |> Bytes.length |> shouldBe 0 + Err err -> fail [fmt|Expected Ok, got Err: #{show err}|] + + it "sendRaw DELETE surfaces a 404 as a status code, not an error" \_ -> do + withMockServer (mockStatusApp GhcHTTP.status404) \testPort -> do + response <- + Http.request + |> Http.withUrl [fmt|http://localhost:#{testPort}/bucket/missing|] + |> (\req -> HttpInternal.sendRaw Http.Delete req Bytes.empty) + |> Task.asResult + case response of + Ok resp -> resp.statusCode |> shouldBe 404 + Err err -> fail [fmt|Expected Ok, got Err: #{show err}|] + + it "sendRaw PUT surfaces a 403 as a status code, not an error" \_ -> do + withMockServer (mockStatusApp GhcHTTP.status403) \testPort -> do + response <- + Http.request + |> Http.withUrl [fmt|http://localhost:#{testPort}/bucket/key|] + |> (\req -> HttpInternal.sendRaw Http.Put req (Text.toBytes "x")) + |> Task.asResult + case response of + Ok resp -> resp.statusCode |> shouldBe 403 + Err err -> fail [fmt|Expected Ok, got Err: #{show err}|] + + it "sendRaw enforces maxResponseBytes on the response body" \_ -> do + withMockServer mockEchoApp \testPort -> do + response <- + Http.request + |> Http.withUrl [fmt|http://localhost:#{testPort}/bucket/key|] + |> Http.withMaxResponseSize 4 + |> (\req -> HttpInternal.sendRaw Http.Put req (Text.toBytes "more-than-four")) + |> Task.asResult + case response of + Err (Http.ResponseTooLarge limit) -> limit |> shouldBe 4 + Err err -> fail [fmt|Expected ResponseTooLarge, got: #{show err}|] + Ok _ -> fail "Expected ResponseTooLarge, got Ok" + + describe "Http.Client.sendSecure" do + it "sendSecure rejects a plain http:// URL with InvalidUrl" \_ -> do + response <- + Http.request + |> Http.withUrl "http://localhost:59999/bucket/key?token=secret" + |> (\req -> Http.sendSecure Http.Put req Bytes.empty) + |> Task.asResult + case response of + Err (Http.InvalidUrl sanitized) -> Text.contains "secret" sanitized |> shouldBe False + Err err -> fail [fmt|Expected InvalidUrl, got: #{show err}|] + Ok _ -> fail "Expected InvalidUrl, got Ok" + + it "methodName spells every wire token" \_ -> do + [Http.Get, Http.Head, Http.Post, Http.Put, Http.Patch, Http.Delete] + |> Array.map Http.methodName + |> shouldBe ["GET", "HEAD", "POST", "PUT", "PATCH", "DELETE"] + -- ============================================================================ -- Test Helpers -- ============================================================================ +-- | Run a WAI application on a free loopback port for the duration of the test. +withMockServer :: GhcWai.Application -> (Int -> Task Text Unit) -> Task Text Unit +withMockServer app runTest = do + testPort <- getFreePort + serverThread <- GhcConcurrent.forkIO (GhcWarp.run testPort app) |> Task.fromIO + GhcConcurrent.threadDelay 50000 |> Task.fromIO + let cleanup = GhcConcurrent.killThread serverThread |> Task.fromIO + runTest testPort |> Task.finally cleanup + + +-- | Look up a response header case-insensitively. +headerValue :: Text -> Http.Response Bytes -> Maybe Text +headerValue name response = + response.headers + |> Array.find (\(headerName, _) -> Text.toLower headerName == Text.toLower name) + |> Maybe.map (\(_, value) -> value) + + +-- ============================================================================ +-- Test Helpers (ports) +-- ============================================================================ + -- | Allocate a free port dynamically to avoid collisions in parallel test runs. -- Binds to port 0 (OS assigns free port), reads the assigned port, then closes the socket. getFreePort :: Task _ Int @@ -178,6 +284,34 @@ mock200App _request respond = do ) +-- | Mock app that echoes the request method, the X-Probe header and the raw body. +mockEchoApp :: GhcWai.Application +mockEchoApp request respond = do + body <- GhcWai.strictRequestBody request + let probeHeader = + GhcWai.requestHeaders request + |> Array.fromLinkedList + |> Array.find (\(name, _) -> name == "X-Probe") + let probe = case probeHeader of + Nothing -> "" + Just (_, value) -> value + respond + ( GhcWai.responseLBS + GhcHTTP.status200 + [ (GhcHTTP.hContentType, "application/octet-stream"), + ("X-Echo-Method", GhcWai.requestMethod request), + ("X-Echo-Probe", probe) + ] + body + ) + + +-- | Mock app that answers every request with the given status and an empty body. +mockStatusApp :: GhcHTTP.Status -> GhcWai.Application +mockStatusApp status _request respond = + respond (GhcWai.responseLBS status [] GhcLBS.empty) + + -- | Mock app that returns valid JSON mockJsonApp :: GhcWai.Application mockJsonApp _request respond = do diff --git a/docs/changes/016-http-client-byte-level-methods.md b/docs/changes/016-http-client-byte-level-methods.md new file mode 100644 index 000000000..8d4c6f261 --- /dev/null +++ b/docs/changes/016-http-client-byte-level-methods.md @@ -0,0 +1,71 @@ +# Change 016: Add byte-level HTTP methods (PUT/HEAD/DELETE…) to Http.Client + +Protocol clients inside nhcore need to talk to object stores and similar REST +services: send a raw byte body with PUT, probe with HEAD, DELETE, read the +status code and headers (e.g. `ETag`) of every response including 4xx, and +never follow redirects. Today `Http.Client` offers byte-level, non-throwing +responses only for GET (`getSecure`, `Http.Client.Internal.getRaw`); the other +verbs decode JSON and throw on non-2xx. This change generalizes the existing +GET path into one method-agnostic primitive so the upcoming S3 `BlobStore` +(change 017) can use the Core HTTP client instead of raw `http-client`, as the +maintainer requested ("extend `Http.Client`" rather than adding a transport). + +```yaml spec +issue: adhoc:http-client-byte-level-methods +kind: feature +touches: [http-client] +breaking: false +new-dependency: false +new-capability: false +new-extension-point: false +``` + +## Contract delta + +`getSecure` and `getRaw` keep their signatures and become `Get` specializations +of the new functions. `sendSecure` enforces `https://` exactly like +`getSecure`; `sendRaw` is the loopback-only twin exported from +`Http.Client.Internal`, mirroring the existing `getRaw` split. Both reuse the +existing request options (headers, timeout, `maxRedirects = 0` default, proxy +disabled, `maxResponseBytes` limit) and the pinned TLS 1.2+ manager. + +```diff signatures ++ Http.Client: data Method = Get | Head | Post | Put | Patch | Delete ++ Http.Client: methodName :: Method -> Text ++ Http.Client: sendSecure :: Method -> Request -> Bytes -> Task Error (Response Bytes) ++ Http.Client.Internal: sendRaw :: Method -> Request -> Bytes -> Task Error (Response Bytes) +``` + +## Criteria + +| ID | Behavior | Proving test | Level | Boundary | +|----|----------|--------------|-------|----------| +| C1 | A PUT delivers the wire method, the raw body and caller headers unchanged | `hspec:nhcore-test-core:core/test/Http/ClientRawSpec.hs#sendRaw PUT delivers method, raw body and custom header` | unit | none | +| C2 | HEAD returns status and headers with an empty body and does not throw | `hspec:nhcore-test-core:core/test/Http/ClientRawSpec.hs#sendRaw HEAD returns headers and an empty body without throwing` | unit | none | +| C3 | Non-2xx statuses (404, 403) are returned as `statusCode`, never as `Err` | `hspec:nhcore-test-core:core/test/Http/ClientRawSpec.hs#sendRaw DELETE surfaces a 404 as a status code, not an error`
`hspec:nhcore-test-core:core/test/Http/ClientRawSpec.hs#sendRaw PUT surfaces a 403 as a status code, not an error` | unit | none | +| C4 | The response-size limit applies to every method | `hspec:nhcore-test-core:core/test/Http/ClientRawSpec.hs#sendRaw enforces maxResponseBytes on the response body` | unit | none | +| C5 | `sendSecure` rejects plain `http://` with a sanitized `InvalidUrl` | `hspec:nhcore-test-core:core/test/Http/ClientRawSpec.hs#sendSecure rejects a plain http:// URL with InvalidUrl` | unit | none | +| C6 | `methodName` spells every wire token of the closed `Method` set | `hspec:nhcore-test-core:core/test/Http/ClientRawSpec.hs#methodName spells every wire token` | unit | none | +| C7 | Existing GET behavior is unchanged (`getRaw` status/body/network-error cases) | `hspec:nhcore-test-core:core/test/Http/ClientRawSpec.hs#returns Ok with statusCode 401 on 401 response`
`hspec:nhcore-test-core:core/test/Http/ClientRawSpec.hs#returns Err on network error` | unit | none | + +The proving tests use the in-process Warp mock pattern already present in +`core/test/Http/ClientRawSpec.hs` (loopback, free port, no external service), +so they run in `nhcore-test-core` with boundary `none`. + +## User impact + +None breaking. `getSecure`/`getRaw` behave as before (GET, same errors, same +limits). New: `Http.Client.sendSecure` for HTTPS endpoints and +`Http.Client.Internal.sendRaw` for trusted loopback endpoints; both return the +status code instead of throwing on 4xx/5xx and never decode the body. Jess does +not need to change anything; integration authors gain PUT/HEAD/DELETE with raw +bodies without importing `Network.HTTP.Client`. + +## ADR + +Not required — no trigger (breaking / new-dependency / new-capability / +new-extension-point all false). Design note: the maintainer rule "if we can do +it ourselves without much complexity, do it ourselves; if too much, use a +Hackage package; for this one extend `Http.Client`" is satisfied by ≈90 lines +that reuse the existing `getSecure` machinery (`applyRequestOptions`, +`checkContentLengthHeaderLimit`, `readBodyFully`, `cachedSecureTlsManager`). From 2125679b24def433acff1dc002011fb9d474d15d Mon Sep 17 00:00:00 2001 From: stepandra Date: Wed, 7 Oct 2026 01:56:07 +0900 Subject: [PATCH 02/13] feat(core-primitives): add Crypto.sha256, hmacSha256 and toHex; document Http.Client helpers Protocol code inside nhcore (the S3 signer in change 017, FileUpload's content hash) needs the raw digest, a chainable HMAC and hex encoding, and today reaches for crypton/Data.ByteArray and Bytes.unwrap directly. Per the #748 review ("add it to the Bytes/Core module instead of unwrapping"), the primitives now live in Crypto, which already owns that boundary. signWith is re-expressed on hmacSha256 + toHex (one implementation; output unchanged, pinned by a test). Known-answer tests: FIPS 180-4 SHA-256 vectors, RFC 4231 HMAC case 2, hex. Spec: docs/changes/021-crypto-sha256-hmac-hex.md (touches core-primitives). Also adds the one-line Haddock the doc-ratchet wants on Http.Client's existing helpers and regenerates codemap: undocumented_exports 560 -> 545, undocumented_doctest_modules 315 -> 314. Gates: ./dev check 0; ./dev test Crypto 24/0; ./dev test Http.Client 37/0; ./dev doctest 0 failures; ./dev lint No hints; ./dev codemap-check OK; ./dev spec-check 021 OK; git diff --check 0. --- .changes/021-crypto-sha256-hmac-hex.md | 12 ++++ codemap/.doc-ratchet | 4 +- codemap/api-hot.md | 46 +++++++-------- codemap/phrasebook.md | 14 ++++- codemap/signatures/nhcore-core.txt | 16 ++++++ core/core/Crypto.hs | 65 +++++++++++++++++++--- core/http/Http/Client.hs | 15 +++++ core/test/CryptoSpec.hs | 41 ++++++++++++++ docs/changes/021-crypto-sha256-hmac-hex.md | 59 ++++++++++++++++++++ 9 files changed, 239 insertions(+), 33 deletions(-) create mode 100644 .changes/021-crypto-sha256-hmac-hex.md create mode 100644 docs/changes/021-crypto-sha256-hmac-hex.md diff --git a/.changes/021-crypto-sha256-hmac-hex.md b/.changes/021-crypto-sha256-hmac-hex.md new file mode 100644 index 000000000..055b5f7f2 --- /dev/null +++ b/.changes/021-crypto-sha256-hmac-hex.md @@ -0,0 +1,12 @@ +--- +group: platform +component: Framework +impact: compatible +category: Added +--- + +## Summary + +`Crypto` now offers the raw building blocks behind signatures: `Crypto.sha256` (32-byte digest), `Crypto.hmacSha256 key message` (raw HMAC that can be chained, any key length) and `Crypto.toHex` (lowercase hexadecimal). Use them when a protocol tells you exactly which bytes to hash or sign; keep using `Crypto.signWith` and `Crypto.verifyWith` for webhook secrets, which are unchanged. + +Existing applications do not need code changes. To verify locally, run `./dev test "Crypto" nhcore-test-core` and confirm the `sha256`, `hmacSha256` and `toHex` examples pass. diff --git a/codemap/.doc-ratchet b/codemap/.doc-ratchet index 8340fb92e..89588a5ba 100644 --- a/codemap/.doc-ratchet +++ b/codemap/.doc-ratchet @@ -1,5 +1,5 @@ # doc-ratchet: counters may DECREASE only (CI-enforced by check.py). # Source-derived (platform-independent) — see generate.py. undocumented_modules: 212 -undocumented_exports: 560 -undocumented_doctest_modules: 315 +undocumented_exports: 545 +undocumented_doctest_modules: 314 diff --git a/codemap/api-hot.md b/codemap/api-hot.md index c2b8e1dd7..e19133e6a 100644 --- a/codemap/api-hot.md +++ b/codemap/api-hot.md @@ -116,17 +116,17 @@ codemap/signatures/ · type-directed search: ./dev api "" ## Bytes -- `unwrap :: Bytes -> ByteString` -- `fromLegacy :: ByteString -> Bytes` -- `toLazyLegacy :: Bytes -> LazyByteString` +- `unwrap :: Bytes -> ByteString` +- `fromLegacy :: ByteString -> Bytes` +- `toLazyLegacy :: Bytes -> LazyByteString` - `length :: Bytes -> Int` - `>>> [1, 2, 3] |> Bytes.pack |> Bytes.length` → `3` - `pack :: [Word8] -> Bytes` - `toBase64 :: Bytes -> Bytes` - `dropEnd :: Int -> Bytes -> Bytes` +- `empty :: Bytes` - `isSuffixOf :: Bytes -> Bytes -> Bool` - `splitOnce :: Bytes -> Bytes -> Maybe (Bytes, Bytes)` -- `fromLazyLegacy :: LazyByteString -> Bytes` ## Maybe @@ -237,6 +237,19 @@ codemap/signatures/ · type-directed search: ./dev api "" - `selectEventBatch :: Var Int64 -> Maybe RelativePosition -> Maybe ReadDirection -> Maybe (Array EntityName) -> Task PostgresStoreError (Session (Array PostgresEventRecord))` - `selectEventByGlobalPositionSession :: Int64 -> Session (Maybe PostgresEventRecord)` +## Http.Client + +- `request :: Request` +- `withUrl :: Text -> Request -> Request` +- `withTimeout :: Int -> Request -> Request` +- `get :: FromJSON response => Request -> Task Error (Response response)` +- `postForm :: FromJSON response => Request -> Array (Text, Text) -> Task Error (Response response)` +- `addHeader :: Text -> Text -> Request -> Request` +- `patch :: (FromJSON response, ToJSON requestBody) => Request -> requestBody -> Task Error (Response response)` +- `post :: (FromJSON response, ToJSON requestBody) => Request -> requestBody -> Task Error (Response response)` +- `put :: (FromJSON response, ToJSON requestBody) => Request -> requestBody -> Task Error (Response response)` +- `applyMethodAndBody :: Method -> Bytes -> Request -> Request` + ## Stream - `fromArray :: Array value -> Task error (Stream value)` @@ -254,19 +267,6 @@ codemap/signatures/ · type-directed search: ./dev api "" - `fromEpochSeconds :: Int64 -> DateTime` - `addSeconds :: Int64 -> DateTime -> DateTime` -## Http.Client - -- `request :: Request` -- `withUrl :: Text -> Request -> Request` -- `withTimeout :: Int -> Request -> Request` -- `get :: FromJSON response => Request -> Task Error (Response response)` -- `postForm :: FromJSON response => Request -> Array (Text, Text) -> Task Error (Response response)` -- `addHeader :: Text -> Text -> Request -> Request` -- `patch :: (FromJSON response, ToJSON requestBody) => Request -> requestBody -> Task Error (Response response)` -- `post :: (FromJSON response, ToJSON requestBody) => Request -> requestBody -> Task Error (Response response)` -- `put :: (FromJSON response, ToJSON requestBody) => Request -> requestBody -> Task Error (Response response)` -- `delete :: FromJSON response => Request -> Task Error (Response response)` - ## Service.Transport.Mcp.JsonRpc - `errorResponse :: Maybe Value -> JsonRpcError -> JsonRpcResponse` @@ -296,19 +296,19 @@ when WRITING TESTS; they are not feature-code frequency signal. - `mapError :: (err1 -> err2) -> Task err1 value -> Task err2 value` - `yield :: value -> Task w value` -- `asResult :: Task err value -> Task err2 (Result err value)` +- `asResult :: Task err value -> Task err2 (Result err value)` - `mapArray :: (element -> Task err output) -> Array element -> Task err (Array output)` - `throw :: err -> Task err w` +- `fromIO :: IO value -> Task w value` - `andThen :: (input -> Task err output) -> Task err input -> Task err output` -- `fromIO :: IO value -> Task w value` - `map :: (input -> output) -> Task err input -> Task err output` ## Array - `length :: Array a -> Int` - `empty :: Array a` -- `fromLinkedList :: LinkedList a -> Array a` -- `map :: (a -> b) -> Array a -> Array b` +- `fromLinkedList :: LinkedList a -> Array a` +- `map :: (a -> b) -> Array a -> Array b` - `get :: Int -> Array a -> Maybe a` - `wrap :: a -> Array a` - `initialize :: Int -> (Int -> a) -> Array a` @@ -316,8 +316,8 @@ when WRITING TESTS; they are not feature-code frequency signal. ## Text -- `contains :: Text -> Text -> Bool` -- `toBytes :: Text -> Bytes` +- `contains :: Text -> Text -> Bool` +- `toBytes :: Text -> Bytes` - `fromLinkedList :: LinkedList Char -> Text` - `length :: Text -> Int` - `repeat :: Int -> Text -> Text` diff --git a/codemap/phrasebook.md b/codemap/phrasebook.md index 5710950a9..8d2301640 100644 --- a/codemap/phrasebook.md +++ b/codemap/phrasebook.md @@ -89,6 +89,18 @@ Array [0] [] ``` +### Crypto + +```haskell +>>> Bytes.pack [0, 15, 255] |> Crypto.toHex +"000fff" +``` + +```haskell +>>> Text.toBytes "abc" |> Crypto.sha256 |> Crypto.toHex +"ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" +``` + ### Float ```haskell @@ -237,4 +249,4 @@ True --- -*32 example sessions · modules with ZERO doctests: 315 (the documentation backlog — see codemap/.doc-ratchet)* +*34 example sessions · modules with ZERO doctests: 314 (the documentation backlog — see codemap/.doc-ratchet)* diff --git a/codemap/signatures/nhcore-core.txt b/codemap/signatures/nhcore-core.txt index acf6d8f47..9dcd65284 100644 --- a/codemap/signatures/nhcore-core.txt +++ b/codemap/signatures/nhcore-core.txt @@ -576,9 +576,12 @@ data HmacKey generateHmacKey :: Task err HmacKey hmacKeyFromBytes :: Bytes -> Result Text HmacKey hmacKeyFromText :: Text -> Result Text HmacKey +hmacSha256 :: Bytes -> Bytes -> Bytes instance GHC.Classes.Eq Crypto.HmacKey instance GHC.Show.Show Crypto.HmacKey +sha256 :: Bytes -> Bytes signWith :: HmacKey -> Bytes -> Text +toHex :: Bytes -> Text verifyWith :: HmacKey -> Text -> Bytes -> Bool module DateTime @@ -725,8 +728,14 @@ unchanged :: value -> value module Http module Http.Client +Delete :: Method Error :: Text -> Error +Get :: Method +Head :: Method InvalidUrl :: Text -> Error +Patch :: Method +Post :: Method +Put :: Method Request :: Maybe Text -> Map Text Text -> Maybe Int -> Int -> !Maybe Int -> Request Response :: Int -> Array (Text, Text) -> body -> Response body ResponseTooLarge :: Int -> Error @@ -739,18 +748,23 @@ ResponseTooLarge :: Int -> Error [timeoutSeconds] :: Request -> Maybe Int [url] :: Request -> Maybe Text addHeader :: Text -> Text -> Request -> Request +applyMethodAndBody :: Method -> Bytes -> Request -> Request checkContentLengthHeaderLimit :: Maybe Int -> [(CI ByteString, ByteString)] -> Maybe Int data Error +data Method data Request data Response body delete :: FromJSON response => Request -> Task Error (Response response) get :: FromJSON response => Request -> Task Error (Response response) getSecure :: Request -> Task Error (Response Bytes) instance Data.Default.Internal.Default Http.Client.Request +instance GHC.Classes.Eq Http.Client.Method instance GHC.Generics.Generic (Http.Client.Response body) instance GHC.Show.Show Http.Client.Error +instance GHC.Show.Show Http.Client.Method instance GHC.Show.Show Http.Client.Request instance GHC.Show.Show body => GHC.Show.Show (Http.Client.Response body) +methodName :: Method -> Text patch :: (FromJSON response, ToJSON requestBody) => Request -> requestBody -> Task Error (Response response) post :: (FromJSON response, ToJSON requestBody) => Request -> requestBody -> Task Error (Response response) postForm :: FromJSON response => Request -> Array (Text, Text) -> Task Error (Response response) @@ -758,6 +772,7 @@ postRaw :: FromJSON response => Request -> Text -> Text -> Task Error (Response put :: (FromJSON response, ToJSON requestBody) => Request -> requestBody -> Task Error (Response response) request :: Request secureTlsSupportedVersions :: [Version] +sendSecure :: Method -> Request -> Bytes -> Task Error (Response Bytes) withMaxResponseSize :: Int -> Request -> Request withRedirects :: Int -> Request -> Request withTimeout :: Int -> Request -> Request @@ -765,6 +780,7 @@ withUrl :: Text -> Request -> Request module Http.Client.Internal getRaw :: Request -> Task Error (Response Bytes) +sendRaw :: Method -> Request -> Bytes -> Task Error (Response Bytes) module IO andThen :: (a -> IO b) -> IO a -> IO b diff --git a/core/core/Crypto.hs b/core/core/Crypto.hs index 03fb6c83e..7e4667c76 100644 --- a/core/core/Crypto.hs +++ b/core/core/Crypto.hs @@ -45,6 +45,11 @@ module Crypto ( -- * Verification verifyWith, + + -- * Primitives + sha256, + hmacSha256, + toHex, ) where import Basics @@ -127,13 +132,10 @@ generateHmacKey = do -- |> Crypto.signWith key -- @ signWith :: HmacKey -> Bytes -> Text -signWith (HmacKey keyBytes) message = do - let messageBytes = Bytes.unwrap message - let hmacResult = HMAC.hmac keyBytes messageBytes :: HMAC.HMAC Hash.SHA256 - let signatureBytes = BA.convert hmacResult :: BS.ByteString - let encoded = Encoding.convertToBase Encoding.Base16 signatureBytes :: BS.ByteString - Bytes.fromLegacy encoded - |> Text.fromBytes +signWith (HmacKey keyBytes) message = + message + |> hmacSha256 (Bytes.fromLegacy keyBytes) + |> toHex -- | Verify an HMAC-SHA256 signature in constant time. @@ -152,3 +154,52 @@ verifyWith key signature message = do let expectedBytes = Text.toBytes expected |> Bytes.unwrap let providedBytes = Text.toBytes (Text.toLower signature) |> Bytes.unwrap BA.constEq providedBytes expectedBytes + + +-- | Raw SHA-256 digest (32 bytes) of the given bytes. +-- +-- This is the unkeyed hash. For message authentication use 'signWith' +-- or 'hmacSha256' instead. +-- +-- @ +-- payload +-- |> Crypto.sha256 +-- |> Crypto.toHex +-- @ +sha256 :: Bytes -> Bytes +sha256 message = do + let digest = Hash.hash (Bytes.unwrap message) :: Hash.Digest Hash.SHA256 + Bytes.fromLegacy (BA.convert digest :: BS.ByteString) + + +-- | Raw HMAC-SHA256 (32 bytes) of a message under an arbitrary key. +-- +-- Unlike 'signWith' this takes any key bytes and returns the raw MAC, so +-- it can be chained — protocols such as AWS Signature V4 derive a signing +-- key by feeding one HMAC result into the next. For a single webhook +-- signature with a fixed secret prefer 'signWith' and 'verifyWith', which +-- also enforce the 32-byte minimum key length and compare in constant +-- time. +-- +-- @ +-- message +-- |> Crypto.hmacSha256 key +-- @ +hmacSha256 :: Bytes -> Bytes -> Bytes +hmacSha256 key message = do + let mac = HMAC.hmac (Bytes.unwrap key) (Bytes.unwrap message) :: HMAC.HMAC Hash.SHA256 + Bytes.fromLegacy (BA.convert mac :: BS.ByteString) + + +-- | Lowercase hexadecimal text of the given bytes (two characters per byte). +-- +-- >>> Bytes.pack [0, 15, 255] |> Crypto.toHex +-- "000fff" +-- +-- >>> Text.toBytes "abc" |> Crypto.sha256 |> Crypto.toHex +-- "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" +toHex :: Bytes -> Text +toHex bytes = do + let encoded = Encoding.convertToBase Encoding.Base16 (Bytes.unwrap bytes) :: BS.ByteString + Bytes.fromLegacy encoded + |> Text.fromBytes diff --git a/core/http/Http/Client.hs b/core/http/Http/Client.hs index 304022c62..71b93830c 100644 --- a/core/http/Http/Client.hs +++ b/core/http/Http/Client.hs @@ -123,10 +123,12 @@ instance Default Request where } +-- | An empty request: no URL, no headers, default timeout and limits. request :: Request request = def +-- | Set the request URL. withUrl :: Text -> Request -> Request withUrl url options = options @@ -148,6 +150,7 @@ withTimeout seconds options = panic [fmt|withTimeout requires positive seconds, got: #{seconds}|] +-- | Add one header; later additions win on duplicate names. addHeader :: Text -> Text -> Request -> Request addHeader key value options = let newHeaders = options.headers |> Map.set key value @@ -178,6 +181,7 @@ withRedirects count options = -- | Set the maximum response body size in bytes. -- Default is 10MB. Use this to override for specific endpoints. {-# INLINE withMaxResponseSize #-} +-- | Cap the response body in bytes; larger bodies fail with a size error. withMaxResponseSize :: GhcInt.Int -> Request -> Request withMaxResponseSize maxBytes options = case maxBytes > 0 of @@ -307,6 +311,7 @@ requestHost :: Request -> Text requestHost options = options.url |> Maybe.map sanitizeUrlText |> Maybe.withDefault "" +-- | GET a JSON document from any URL (plain HTTP allowed; prefer getSecure). get :: (Json.FromJSON response) => Request -> @@ -339,6 +344,7 @@ getIO options = do secureTlsSupportedVersions :: [TLS.Version] secureTlsSupportedVersions = [TLS.TLS13, TLS.TLS12] +-- | Build the TLS 1.2+ connection manager shared by every secure request. secureTlsManager :: GhcIO.IO HttpClient.Manager secureTlsManager = do let tlsParams = @@ -353,10 +359,12 @@ secureTlsManager = do HttpClient.newManager managerSettings {-# NOINLINE cachedSecureTlsManager #-} +-- | The process-wide secure manager, built once. cachedSecureTlsManager :: HttpClient.Manager cachedSecureTlsManager = GhcUnsafe.unsafePerformIO secureTlsManager {-# INLINE getSecure #-} +-- | GET raw bytes over HTTPS only; returns the status code instead of throwing on 4xx/5xx. getSecure :: Request -> Task Error (Response Bytes) @@ -455,10 +463,12 @@ applyMethodAndBody method body req = |> HttpSimple.setRequestBodyLBS (Bytes.toLazyLegacy body) +-- | Read the whole body reader into memory, honouring the size limit. readBodyFully :: HttpClient.BodyReader -> GhcIO.IO ByteString readBodyFully reader = readBodyChunks reader GhcBSChar.empty +-- | Accumulate body chunks until EOF or the size limit. readBodyChunks :: HttpClient.BodyReader -> ByteString -> GhcIO.IO ByteString readBodyChunks reader accumulatedBody = do chunk <- HttpClient.brRead reader @@ -469,6 +479,7 @@ readBodyChunks reader accumulatedBody = do readBodyChunks reader nextBody +-- | Reject early when @Content-Length@ already exceeds the limit. checkContentLengthHeaderLimit :: Maybe GhcInt.Int -> [(CI.CI ByteString, ByteString)] -> Maybe GhcInt.Int checkContentLengthHeaderLimit maxResponseLimit responseHeaders = case maxResponseLimit of @@ -486,6 +497,7 @@ checkContentLengthHeaderLimit maxResponseLimit responseHeaders = False -> Nothing +-- | Parse a @Content-Length@ value, if well-formed. parseContentLengthHeader :: ByteString -> Maybe GhcInt.Int parseContentLengthHeader rawContentLength = case GhcBSChar.readInt rawContentLength of @@ -496,6 +508,7 @@ parseContentLengthHeader rawContentLength = False -> Nothing +-- | First value for a header name, if present. findHeaderValue :: CI.CI ByteString -> [(CI.CI ByteString, ByteString)] -> Maybe ByteString findHeaderValue headerName headers = case headers of @@ -506,6 +519,7 @@ findHeaderValue headerName headers = False -> findHeaderValue headerName remainingHeaders +-- | Drain an open response into bytes under the size limit. extractResponseBytesFromOpenResponse :: HttpClient.Response HttpClient.BodyReader -> ByteString -> Response Bytes extractResponseBytesFromOpenResponse rawResponse responseBody = Response { statusCode = rawResponse |> HttpClient.responseStatus |> HttpStatus.statusCode @@ -514,6 +528,7 @@ extractResponseBytesFromOpenResponse rawResponse responseBody = Response } +-- | Convert wire headers to @(name, value)@ text pairs. extractRawHeaders :: [(CI.CI ByteString, ByteString)] -> Array (Text, Text) extractRawHeaders rawHeaders = rawHeaders diff --git a/core/test/CryptoSpec.hs b/core/test/CryptoSpec.hs index c4168d131..eeeece5f9 100644 --- a/core/test/CryptoSpec.hs +++ b/core/test/CryptoSpec.hs @@ -1,5 +1,6 @@ module CryptoSpec where +import Bytes qualified import Core import Crypto (HmacKey) import Crypto qualified @@ -137,3 +138,43 @@ spec = parallel do let firstSignature = message |> Crypto.signWith firstKey let secondSignature = message |> Crypto.signWith secondKey firstSignature |> shouldNotBe secondSignature + + -- ========================================================================== + -- Primitives (known-answer vectors) + -- ========================================================================== + describe "sha256" do + it "hashes the empty input to the FIPS 180-4 vector" \_ -> do + let digest = Text.toBytes "" |> Crypto.sha256 |> Crypto.toHex + digest |> shouldBe "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" + + it "hashes \"abc\" to the FIPS 180-4 vector" \_ -> do + let digest = Text.toBytes "abc" |> Crypto.sha256 |> Crypto.toHex + digest |> shouldBe "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" + + describe "hmacSha256" do + it "matches RFC 4231 test case 2 (key \"Jefe\")" \_ -> do + let mac = + Text.toBytes "what do ya want for nothing?" + |> Crypto.hmacSha256 (Text.toBytes "Jefe") + |> Crypto.toHex + mac |> shouldBe "5bdcc146bf60754e6a042426089575c75a003f089d2739839dec58b964ec3843" + + it "accepts keys shorter than 32 bytes, unlike signWith" \_ -> do + let mac = Text.toBytes "m" |> Crypto.hmacSha256 (Text.toBytes "k") + Bytes.length mac |> shouldBe 32 + + it "agrees with signWith for a valid HmacKey" \_ -> do + let message = Text.toBytes "same message" + let viaSign = message |> Crypto.signWith knownKey + let viaRaw = + message + |> Crypto.hmacSha256 (Text.toBytes "0123456789abcdef0123456789abcdef") + |> Crypto.toHex + viaRaw |> shouldBe viaSign + + describe "toHex" do + it "encodes two lowercase characters per byte" \_ -> do + Crypto.toHex (Bytes.pack [0, 15, 16, 255]) |> shouldBe "000f10ff" + + it "encodes the empty input to the empty text" \_ -> do + Crypto.toHex (Text.toBytes "") |> shouldBe "" diff --git a/docs/changes/021-crypto-sha256-hmac-hex.md b/docs/changes/021-crypto-sha256-hmac-hex.md new file mode 100644 index 000000000..afbde3d74 --- /dev/null +++ b/docs/changes/021-crypto-sha256-hmac-hex.md @@ -0,0 +1,59 @@ +# Change 021: Add raw SHA-256, HMAC-SHA256 and hex primitives to Crypto + +Code inside nhcore that speaks a signed protocol needs the plain building +blocks: an unkeyed SHA-256 digest, a raw HMAC-SHA256 that can be chained +(one MAC result becomes the next key), and lowercase hex encoding. Today +`Crypto` exposes only the webhook-shaped `signWith`/`verifyWith` (hex text, +32-byte minimum `HmacKey`), so modules such as the S3 `BlobStore` signer +(change 017) and `FileUpload.Web`'s content hash import `crypton` and +`Data.ByteArray` directly and unwrap `Bytes`. The maintainer asked on #748 +to add the missing primitive to Core instead of unwrapping. This change does +that; `signWith` is re-expressed on top of the new functions so there is one +implementation. + +```yaml spec +issue: adhoc:crypto-sha256-hmac-hex +kind: feature +touches: [core-primitives] +breaking: false +new-dependency: false +new-capability: false +new-extension-point: false +``` + +## Contract delta + +Three pure, data-last functions on `Bytes`. `hmacSha256` deliberately takes an +arbitrary key (no 32-byte policy) because key-derivation chains need short +intermediate keys; `signWith`/`verifyWith` keep the policy and the +constant-time comparison and remain the right choice for a single webhook +secret. + +```diff signatures ++ Crypto: sha256 :: Bytes -> Bytes ++ Crypto: hmacSha256 :: Bytes -> Bytes -> Bytes ++ Crypto: toHex :: Bytes -> Text +``` + +## Criteria + +| ID | Criterion | Test | Level | Boundary | +|---|---|---|---|---| +| C1 | `sha256` matches the FIPS 180-4 vectors for `""` and `"abc"` | `hspec:nhcore-test-core:core/test/CryptoSpec.hs#hashes the empty input to the FIPS 180-4 vector`
`hspec:nhcore-test-core:core/test/CryptoSpec.hs#hashes "abc" to the FIPS 180-4 vector` | unit | none | +| C2 | `hmacSha256` matches RFC 4231 test case 2 | `hspec:nhcore-test-core:core/test/CryptoSpec.hs#matches RFC 4231 test case 2 (key "Jefe")` | unit | none | +| C3 | `hmacSha256` accepts keys shorter than 32 bytes | `hspec:nhcore-test-core:core/test/CryptoSpec.hs#accepts keys shorter than 32 bytes, unlike signWith` | unit | none | +| C4 | `signWith` is unchanged: it equals `hmacSha256` + `toHex` for a valid key | `hspec:nhcore-test-core:core/test/CryptoSpec.hs#agrees with signWith for a valid HmacKey` | unit | none | +| C5 | `toHex` is lowercase, two characters per byte, empty for empty | `hspec:nhcore-test-core:core/test/CryptoSpec.hs#encodes two lowercase characters per byte`
`hspec:nhcore-test-core:core/test/CryptoSpec.hs#encodes the empty input to the empty text` | unit | none | + +## User impact + +None breaking. `signWith` and `verifyWith` produce exactly the same output as +before (C4). New: `Crypto.sha256`, `Crypto.hmacSha256`, `Crypto.toHex` for +protocol code that needs the raw primitives. Jess does not need to change +anything. + +## ADR + +Not required — no trigger. Follow-up (not in this change): +`Service.FileUpload.Web.computeContentHash` can be rewritten on +`Crypto.sha256 |> Crypto.toHex` and drop its own `crypton` imports. From 70fecabfe8a99af95b2b2ab19df076c41619124e Mon Sep 17 00:00:00 2001 From: stepandra Date: Fri, 9 Oct 2026 01:38:44 +0900 Subject: [PATCH 03/13] docs(http-client): attest real-HTTP criteria of change 016 as integration ClientRawSpec's sendRaw and getRaw status examples send real loopback HTTP to an in-process Warp server, so they are integration / http:real with exact selector attestations in test-surfaces.json. The scheme check, methodName and the closed-port network error stay unit / none. Amp-Thread-ID: https://ampcode.com/threads/T-01a11c53-f9bd-70df-81b8-4369dbfd3e1b --- .../016-http-client-byte-level-methods.md | 23 +++++--- docs/changes/test-surfaces.json | 54 +++++++++++++++++++ 2 files changed, 69 insertions(+), 8 deletions(-) diff --git a/docs/changes/016-http-client-byte-level-methods.md b/docs/changes/016-http-client-byte-level-methods.md index 8d4c6f261..9280b72e2 100644 --- a/docs/changes/016-http-client-byte-level-methods.md +++ b/docs/changes/016-http-client-byte-level-methods.md @@ -40,17 +40,24 @@ disabled, `maxResponseBytes` limit) and the pinned TLS 1.2+ manager. | ID | Behavior | Proving test | Level | Boundary | |----|----------|--------------|-------|----------| -| C1 | A PUT delivers the wire method, the raw body and caller headers unchanged | `hspec:nhcore-test-core:core/test/Http/ClientRawSpec.hs#sendRaw PUT delivers method, raw body and custom header` | unit | none | -| C2 | HEAD returns status and headers with an empty body and does not throw | `hspec:nhcore-test-core:core/test/Http/ClientRawSpec.hs#sendRaw HEAD returns headers and an empty body without throwing` | unit | none | -| C3 | Non-2xx statuses (404, 403) are returned as `statusCode`, never as `Err` | `hspec:nhcore-test-core:core/test/Http/ClientRawSpec.hs#sendRaw DELETE surfaces a 404 as a status code, not an error`
`hspec:nhcore-test-core:core/test/Http/ClientRawSpec.hs#sendRaw PUT surfaces a 403 as a status code, not an error` | unit | none | -| C4 | The response-size limit applies to every method | `hspec:nhcore-test-core:core/test/Http/ClientRawSpec.hs#sendRaw enforces maxResponseBytes on the response body` | unit | none | +| C1 | A PUT delivers the wire method, the raw body and caller headers unchanged | `hspec:nhcore-test-core:core/test/Http/ClientRawSpec.hs#sendRaw PUT delivers method, raw body and custom header` | integration | http:real | +| C2 | HEAD returns status and headers with an empty body and does not throw | `hspec:nhcore-test-core:core/test/Http/ClientRawSpec.hs#sendRaw HEAD returns headers and an empty body without throwing` | integration | http:real | +| C3 | Non-2xx statuses (404, 403) are returned as `statusCode`, never as `Err` | `hspec:nhcore-test-core:core/test/Http/ClientRawSpec.hs#sendRaw DELETE surfaces a 404 as a status code, not an error`
`hspec:nhcore-test-core:core/test/Http/ClientRawSpec.hs#sendRaw PUT surfaces a 403 as a status code, not an error` | integration | http:real | +| C4 | The response-size limit applies to every method | `hspec:nhcore-test-core:core/test/Http/ClientRawSpec.hs#sendRaw enforces maxResponseBytes on the response body` | integration | http:real | | C5 | `sendSecure` rejects plain `http://` with a sanitized `InvalidUrl` | `hspec:nhcore-test-core:core/test/Http/ClientRawSpec.hs#sendSecure rejects a plain http:// URL with InvalidUrl` | unit | none | | C6 | `methodName` spells every wire token of the closed `Method` set | `hspec:nhcore-test-core:core/test/Http/ClientRawSpec.hs#methodName spells every wire token` | unit | none | -| C7 | Existing GET behavior is unchanged (`getRaw` status/body/network-error cases) | `hspec:nhcore-test-core:core/test/Http/ClientRawSpec.hs#returns Ok with statusCode 401 on 401 response`
`hspec:nhcore-test-core:core/test/Http/ClientRawSpec.hs#returns Err on network error` | unit | none | +| C7 | Existing GET behavior is unchanged: `getRaw` returns a non-2xx status as `statusCode` | `hspec:nhcore-test-core:core/test/Http/ClientRawSpec.hs#returns Ok with statusCode 401 on 401 response` | integration | http:real | +| C8 | Existing GET behavior is unchanged: `getRaw` reports a refused connection as `Err` | `hspec:nhcore-test-core:core/test/Http/ClientRawSpec.hs#returns Err on network error` | unit | none | -The proving tests use the in-process Warp mock pattern already present in -`core/test/Http/ClientRawSpec.hs` (loopback, free port, no external service), -so they run in `nhcore-test-core` with boundary `none`. +C1–C4 and C7 send real HTTP over loopback to an in-process Warp server +started by `core/test/Http/ClientRawSpec.hs` (free port, no external +service), so a broken wire path fails them: they are `integration` / +`http:real`, and `docs/changes/test-surfaces.json` attests each exact selector +with its `Http.Client.Internal.sendRaw` or `Http.Client.Internal.getRaw` +fixture group. C5 and C6 stay `unit` / `none`: the scheme check fails before +any connection and `methodName` is pure. C8 also stays `unit` / `none`: it +only proves that a connection attempt to a closed loopback port becomes `Err`, +and no fixture server ever answers it. ## User impact diff --git a/docs/changes/test-surfaces.json b/docs/changes/test-surfaces.json index 32fa31a81..4538a4cbb 100644 --- a/docs/changes/test-surfaces.json +++ b/docs/changes/test-surfaces.json @@ -208,6 +208,60 @@ "boundary": "postgres:real", "expected_examples": 1, "fixture": "Service.QueryObjectStore.Postgres" + }, + { + "kind": "hspec", + "suite": "nhcore-test-core", + "path": "core/test/Http/ClientRawSpec.hs", + "match": "sendRaw PUT delivers method, raw body and custom header", + "boundary": "http:real", + "expected_examples": 1, + "fixture": "Http.Client.Internal.sendRaw" + }, + { + "kind": "hspec", + "suite": "nhcore-test-core", + "path": "core/test/Http/ClientRawSpec.hs", + "match": "sendRaw HEAD returns headers and an empty body without throwing", + "boundary": "http:real", + "expected_examples": 1, + "fixture": "Http.Client.Internal.sendRaw" + }, + { + "kind": "hspec", + "suite": "nhcore-test-core", + "path": "core/test/Http/ClientRawSpec.hs", + "match": "sendRaw DELETE surfaces a 404 as a status code, not an error", + "boundary": "http:real", + "expected_examples": 1, + "fixture": "Http.Client.Internal.sendRaw" + }, + { + "kind": "hspec", + "suite": "nhcore-test-core", + "path": "core/test/Http/ClientRawSpec.hs", + "match": "sendRaw PUT surfaces a 403 as a status code, not an error", + "boundary": "http:real", + "expected_examples": 1, + "fixture": "Http.Client.Internal.sendRaw" + }, + { + "kind": "hspec", + "suite": "nhcore-test-core", + "path": "core/test/Http/ClientRawSpec.hs", + "match": "sendRaw enforces maxResponseBytes on the response body", + "boundary": "http:real", + "expected_examples": 1, + "fixture": "Http.Client.Internal.sendRaw" + }, + { + "kind": "hspec", + "suite": "nhcore-test-core", + "path": "core/test/Http/ClientRawSpec.hs", + "match": "returns Ok with statusCode 401 on 401 response", + "boundary": "http:real", + "expected_examples": 1, + "fixture": "Http.Client.Internal.getRaw" } ] } From 164ce3bf72ade6c5c89d65d68aeead682527fbee Mon Sep 17 00:00:00 2001 From: stepandra Date: Fri, 9 Oct 2026 02:41:20 +0900 Subject: [PATCH 04/13] test(core-primitives): drop literal quotes from two CryptoSpec titles so 021 selectors resolve The C1/C2 locators named "abc" and "Jefe" in quotes, but the hspec source escapes them, so the exact-title selector never matched. Rename the two example titles and their locators; every assertion is unchanged. Amp-Thread-ID: https://ampcode.com/threads/T-01a11c53-f9bd-70df-81b8-4369dbfd3e1b --- core/test/CryptoSpec.hs | 4 ++-- docs/changes/021-crypto-sha256-hmac-hex.md | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/core/test/CryptoSpec.hs b/core/test/CryptoSpec.hs index eeeece5f9..f4c4635a0 100644 --- a/core/test/CryptoSpec.hs +++ b/core/test/CryptoSpec.hs @@ -147,12 +147,12 @@ spec = parallel do let digest = Text.toBytes "" |> Crypto.sha256 |> Crypto.toHex digest |> shouldBe "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" - it "hashes \"abc\" to the FIPS 180-4 vector" \_ -> do + it "hashes abc to the FIPS 180-4 vector" \_ -> do let digest = Text.toBytes "abc" |> Crypto.sha256 |> Crypto.toHex digest |> shouldBe "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" describe "hmacSha256" do - it "matches RFC 4231 test case 2 (key \"Jefe\")" \_ -> do + it "matches RFC 4231 test case 2 (key Jefe)" \_ -> do let mac = Text.toBytes "what do ya want for nothing?" |> Crypto.hmacSha256 (Text.toBytes "Jefe") diff --git a/docs/changes/021-crypto-sha256-hmac-hex.md b/docs/changes/021-crypto-sha256-hmac-hex.md index afbde3d74..0fe8df255 100644 --- a/docs/changes/021-crypto-sha256-hmac-hex.md +++ b/docs/changes/021-crypto-sha256-hmac-hex.md @@ -39,8 +39,8 @@ secret. | ID | Criterion | Test | Level | Boundary | |---|---|---|---|---| -| C1 | `sha256` matches the FIPS 180-4 vectors for `""` and `"abc"` | `hspec:nhcore-test-core:core/test/CryptoSpec.hs#hashes the empty input to the FIPS 180-4 vector`
`hspec:nhcore-test-core:core/test/CryptoSpec.hs#hashes "abc" to the FIPS 180-4 vector` | unit | none | -| C2 | `hmacSha256` matches RFC 4231 test case 2 | `hspec:nhcore-test-core:core/test/CryptoSpec.hs#matches RFC 4231 test case 2 (key "Jefe")` | unit | none | +| C1 | `sha256` matches the FIPS 180-4 vectors for `""` and `"abc"` | `hspec:nhcore-test-core:core/test/CryptoSpec.hs#hashes the empty input to the FIPS 180-4 vector`
`hspec:nhcore-test-core:core/test/CryptoSpec.hs#hashes abc to the FIPS 180-4 vector` | unit | none | +| C2 | `hmacSha256` matches RFC 4231 test case 2 | `hspec:nhcore-test-core:core/test/CryptoSpec.hs#matches RFC 4231 test case 2 (key Jefe)` | unit | none | | C3 | `hmacSha256` accepts keys shorter than 32 bytes | `hspec:nhcore-test-core:core/test/CryptoSpec.hs#accepts keys shorter than 32 bytes, unlike signWith` | unit | none | | C4 | `signWith` is unchanged: it equals `hmacSha256` + `toHex` for a valid key | `hspec:nhcore-test-core:core/test/CryptoSpec.hs#agrees with signWith for a valid HmacKey` | unit | none | | C5 | `toHex` is lowercase, two characters per byte, empty for empty | `hspec:nhcore-test-core:core/test/CryptoSpec.hs#encodes two lowercase characters per byte`
`hspec:nhcore-test-core:core/test/CryptoSpec.hs#encodes the empty input to the empty text` | unit | none | From 45fba4a6419de6da185384dab81309cf6d65916a Mon Sep 17 00:00:00 2001 From: stepandra Date: Fri, 9 Oct 2026 02:41:20 +0900 Subject: [PATCH 05/13] ci(test): feed the criteria-runtime gate core and service reports Integration criteria may name nhcore-test-core locators (change 016), but the --criteria-runtime --report gate in test-service read only the service report, so every core locator failed report mode. test-core now tees its direct output to nhcore-test-core.report under pipefail and uploads it fail-closed; test-service needs test-core, downloads that artifact and gates on the concatenation of both reports. workflow-check contract 6 freezes the wiring with self-test regressions. Amp-Thread-ID: https://ampcode.com/threads/T-01a11c53-f9bd-70df-81b8-4369dbfd3e1b --- .github/workflows/test.yml | 29 ++++++++++-- scripts/workflow-check | 93 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 119 insertions(+), 3 deletions(-) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 236a529fe..a24e04692 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -190,8 +190,21 @@ jobs: with: name: dist-newstyle path: dist-newstyle + # Tee the direct per-example output: integration criteria whose locators + # live in nhcore-test-core are proven from this report by the criteria + # gate in test-service. Non-hidden filename: upload-artifact skips + # dotfiles by default. - name: Run nhcore-test-core - run: LOG_LEVEL=Warn nix develop --command cabal test nhcore-test-core + run: | + set -o pipefail + LOG_LEVEL=Warn nix develop --command cabal test nhcore-test-core \ + --test-show-details=direct | tee nhcore-test-core.report + - uses: actions/upload-artifact@v7 + with: + name: nhcore-test-core-report + path: nhcore-test-core.report + retention-days: 1 + if-no-files-found: error test-auth: needs: [build] @@ -234,7 +247,8 @@ jobs: run: LOG_LEVEL=Warn nix develop --command cabal test nhcore-test-integration test-service: - needs: [build] + # test-core supplies its report for the criteria gate below. + needs: [build, test-core] runs-on: ubuntu-latest timeout-minutes: 20 steps: @@ -277,12 +291,21 @@ jobs: set -o pipefail LOG_LEVEL=Warn nix develop --command cabal test nhcore-test-service \ --test-show-details=direct | tee .nhcore-test-service.report + - uses: actions/download-artifact@v8 + if: github.event_name == 'pull_request' + with: + name: nhcore-test-core-report + # One report across both suites: a missing core report fails `cat` + # (closed), never a silently service-only gate. - name: Prove integration criterion selectors and real fixtures if: github.event_name == 'pull_request' env: BASE_REF: ${{ github.base_ref }} POSTGRES_AVAILABLE: "true" - run: ./dev spec-check --criteria-runtime "origin/${BASE_REF}" --report .nhcore-test-service.report + run: | + set -euo pipefail + cat nhcore-test-core.report .nhcore-test-service.report > nhcore-criteria.report + ./dev spec-check --criteria-runtime "origin/${BASE_REF}" --report nhcore-criteria.report test-hurl: needs: [build] diff --git a/scripts/workflow-check b/scripts/workflow-check index 7d35bcd76..3b45157ed 100755 --- a/scripts/workflow-check +++ b/scripts/workflow-check @@ -44,6 +44,14 @@ Two contracts, both learned from real breakage: regression to a main/integration-only filter, or a dropped neo/** route, fails loudly. + 6. Criteria-runtime report (test.yml): integration criteria may name + locators in nhcore-test-core OR nhcore-test-service, but the + `--criteria-runtime --report` gate runs once, in test-service. test-core + must tee its direct output to a NON-hidden report under pipefail and + upload it fail-closed; test-service must need test-core, download that + artifact, and feed the gate the concatenation of both reports. A + service-only report silently fails every core locator. + Run: ./dev workflow-check CI: .github/workflows/checks.yml ./dev workflow-check --self-test (doctor/CI) """ @@ -429,6 +437,48 @@ def check_required_gate(name, text): return errs +CORE_REPORT = "nhcore-test-core.report" +CORE_REPORT_ARTIFACT = "nhcore-test-core-report" +SERVICE_REPORT = ".nhcore-test-service.report" + + +def check_criteria_report(name, text): + """Contract 6: the criteria-runtime gate reads core AND service reports.""" + errs = [] + E = errs.append + jobs = job_blocks(strip_comments(text)) + core, service = jobs.get("test-core", ""), jobs.get("test-service", "") + if is_hidden_path(CORE_REPORT): + E(f"{name}: core report `{CORE_REPORT}` is hidden; upload would be empty") + run_core = [s for s in _steps_of(core) if "cabal test nhcore-test-core" in s] + if not run_core or "set -o pipefail" not in run_core[0] \ + or f"tee {CORE_REPORT}" not in run_core[0] \ + or "--test-show-details=direct" not in run_core[0]: + E(f"{name}: test-core must tee direct output to `{CORE_REPORT}` under " + "`set -o pipefail`") + uploads = [s for s in _steps_of(core) if UPLOAD_RE.search(s) + and f"name: {CORE_REPORT_ARTIFACT}" in s] + if not uploads or f"path: {CORE_REPORT}" not in uploads[0] \ + or "if-no-files-found: error" not in uploads[0]: + E(f"{name}: test-core must upload `{CORE_REPORT}` as " + f"`{CORE_REPORT_ARTIFACT}` with `if-no-files-found: error`") + needs = re.search(r"^ needs:\s*\[([^\]]*)\]", service, re.M) + if not needs or "test-core" not in [n.strip() for n in needs.group(1).split(",")]: + E(f"{name}: test-service must need test-core to read its report") + if not any("actions/download-artifact" in s and f"name: {CORE_REPORT_ARTIFACT}" in s + for s in _steps_of(service)): + E(f"{name}: test-service must download `{CORE_REPORT_ARTIFACT}`") + gate = [s for s in _steps_of(service) if "--criteria-runtime" in s] + combined = re.search( + rf"cat {re.escape(CORE_REPORT)} {re.escape(SERVICE_REPORT)} > (\S+)", + gate[0] if gate else "") + if not gate or not combined or "set -euo pipefail" not in gate[0] \ + or f"--report {combined.group(1)}" not in gate[0]: + E(f"{name}: the criteria-runtime gate must read one report concatenated " + f"from `{CORE_REPORT}` and `{SERVICE_REPORT}` under `set -euo pipefail`") + return errs + + def check_component_gate(name, text): """neo-ci.yml is the Neo CLI component gate (contract 4). It must run on ARBITRARY PR bases (no base-branch allowlist, so stacked layers on any branch @@ -1019,6 +1069,7 @@ def run(root=WORKFLOWS): errs += check_codemap_regen(wf.name, text) if wf.name == REQUIRED_GATE: errs += check_required_gate(wf.name, text) + errs += check_criteria_report(wf.name, text) if wf.name == COMPONENT_GATE: errs += check_component_gate(wf.name, text) errs += check_consumer_contract(wf.name, text) @@ -1672,6 +1723,48 @@ def self_test(): good_slo.replace(" - uses: actions/checkout@v7.0.1\n", " - uses: actions/checkout@v7.0.1\n - uses: DeterminateSystems/determinate-nix-action@v3.21.7\n")) + good_report = ( + "jobs:\n" + " test-core:\n needs: [build]\n steps:\n" + " - name: Run nhcore-test-core\n run: |\n" + " set -o pipefail\n" + " cabal test nhcore-test-core --test-show-details=direct" + " | tee nhcore-test-core.report\n" + " - uses: actions/upload-artifact@v7\n with:\n" + " name: nhcore-test-core-report\n" + " path: nhcore-test-core.report\n" + " if-no-files-found: error\n" + " test-service:\n needs: [build, test-core]\n steps:\n" + " - uses: actions/download-artifact@v8\n with:\n" + " name: nhcore-test-core-report\n" + " - name: gate\n run: |\n set -euo pipefail\n" + " cat nhcore-test-core.report .nhcore-test-service.report > all.report\n" + " ./dev spec-check --criteria-runtime base --report all.report\n" + ) + + def cr_bad(name_, mutated): + check(name_, bool(check_criteria_report("test.yml", mutated))) + + check("well-wired criteria report passes", + not check_criteria_report("test.yml", good_report)) + cr_bad("service-only criteria report is flagged", + good_report.replace("--report all.report", "--report .nhcore-test-service.report")) + cr_bad("core report omitted from the concatenation is flagged", + good_report.replace("cat nhcore-test-core.report ", "cat ")) + cr_bad("test-core without a tee'd report is flagged", + good_report.replace(" | tee nhcore-test-core.report", "")) + cr_bad("test-core report without pipefail is flagged", + good_report.replace(" set -o pipefail\n", "")) + cr_bad("core report upload that tolerates a missing file is flagged", + good_report.replace(" if-no-files-found: error\n", "")) + cr_bad("test-service not needing test-core is flagged", + good_report.replace("needs: [build, test-core]", "needs: [build]")) + cr_bad("test-service not downloading the core report is flagged", + good_report.replace("actions/download-artifact@v8", "actions/cache@v6")) + cr_bad("commented-out core report download is flagged", + good_report.replace(" - uses: actions/download-artifact@v8\n", + " # - uses: actions/download-artifact@v8\n" + " - uses: actions/cache@v6\n")) print("workflow-check: self-test", "OK" if ok else "FAILED") return 0 if ok else 1 From fc33ecda33e7561f18d352645f78aac743890432 Mon Sep 17 00:00:00 2001 From: stepandra Date: Fri, 9 Oct 2026 02:58:38 +0900 Subject: [PATCH 06/13] docs(http-client): align method contract with generated signatures Amp-Thread-ID: https://ampcode.com/threads/T-01a11c53-f9bd-70df-81b8-4369dbfd3e1b --- docs/changes/016-http-client-byte-level-methods.md | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/docs/changes/016-http-client-byte-level-methods.md b/docs/changes/016-http-client-byte-level-methods.md index 9280b72e2..fcb33518e 100644 --- a/docs/changes/016-http-client-byte-level-methods.md +++ b/docs/changes/016-http-client-byte-level-methods.md @@ -30,7 +30,13 @@ existing request options (headers, timeout, `maxRedirects = 0` default, proxy disabled, `maxResponseBytes` limit) and the pinned TLS 1.2+ manager. ```diff signatures -+ Http.Client: data Method = Get | Head | Post | Put | Patch | Delete ++ Http.Client: data Method ++ Http.Client: Get :: Method ++ Http.Client: Head :: Method ++ Http.Client: Post :: Method ++ Http.Client: Put :: Method ++ Http.Client: Patch :: Method ++ Http.Client: Delete :: Method + Http.Client: methodName :: Method -> Text + Http.Client: sendSecure :: Method -> Request -> Bytes -> Task Error (Response Bytes) + Http.Client.Internal: sendRaw :: Method -> Request -> Bytes -> Task Error (Response Bytes) From 7cb724f3f38ecc4ad71ba47e0b0c9065140fd64c Mon Sep 17 00:00:00 2001 From: stepandra Date: Tue, 13 Oct 2026 03:13:22 +0900 Subject: [PATCH 07/13] test(http): specify transport remediation and prove EOF regression --- core/test/Http/ClientRawSpec.hs | 50 +++++++ .../016-http-client-byte-level-methods.md | 26 +++- docs/changes/021-crypto-sha256-hmac-hex.md | 2 +- .../022-http-byte-transport-guarantees.md | 127 ++++++++++++++++++ docs/changes/test-surfaces.json | 9 ++ 5 files changed, 208 insertions(+), 6 deletions(-) create mode 100644 docs/changes/022-http-byte-transport-guarantees.md diff --git a/core/test/Http/ClientRawSpec.hs b/core/test/Http/ClientRawSpec.hs index 9ed9d57bc..d4f8e2b62 100644 --- a/core/test/Http/ClientRawSpec.hs +++ b/core/test/Http/ClientRawSpec.hs @@ -116,6 +116,56 @@ spec = do Ok _ -> fail "Expected error for unreachable host" describe "Http.Client.Internal.sendRaw" do + it "sendRaw rejects an oversized chunk before source EOF" \_ -> do + sourceRelease <- GhcConcurrent.newEmptyMVar |> Task.fromIO + sourceFlushed <- GhcConcurrent.newEmptyMVar |> Task.fromIO + clientResult <- GhcConcurrent.newEmptyMVar |> Task.fromIO + let streamingApp request respond = + if GhcWai.rawPathInfo request == "/control" + then mock200App request respond + else respond (GhcWai.responseStream GhcHTTP.status200 [] \write flush -> do + write "12345" + flush + GhcConcurrent.putMVar sourceFlushed () + GhcConcurrent.takeMVar sourceRelease) + withMockServer streamingApp \testPort -> do + control <- + Http.request + |> Http.withUrl [fmt|http://127.0.0.1:#{testPort}/control|] + |> Http.withTimeout 10 + |> HttpInternal.getRaw + |> Task.asResult + case control of + Ok response -> response.statusCode |> shouldBe 200 + Err err -> fail [fmt|Fixture positive control failed: #{show err}|] + let requestTask :: Task Text (Result Http.Error (Http.Response Bytes)) + requestTask = + Http.request + |> Http.withUrl [fmt|http://127.0.0.1:#{testPort}/paced|] + |> Http.withMaxResponseSize 4 + |> Http.withTimeout 10 + |> (\req -> HttpInternal.sendRaw Http.Get req Bytes.empty) + |> Task.asResult + clientThread <- GhcConcurrent.forkIO (do + result <- Task.runOrPanic requestTask + GhcConcurrent.putMVar clientResult result) |> Task.fromIO + let checkBeforeEof = do + GhcConcurrent.threadDelay 2000000 |> Task.fromIO + flushed <- GhcConcurrent.tryTakeMVar sourceFlushed |> Task.fromIO + case flushed of + Nothing -> fail "Fixture did not flush its oversized chunk" + Just () -> Task.yield () + GhcConcurrent.threadDelay 2000000 |> Task.fromIO + observed <- GhcConcurrent.tryTakeMVar clientResult |> Task.fromIO + case observed of + Just (Err (Http.ResponseTooLarge limit)) -> limit |> shouldBe 4 + Just other -> fail [fmt|Expected ResponseTooLarge before EOF, got: #{show other}|] + Nothing -> fail "REGRESSION_ASSERT:sendRaw-awaits-source-EOF" + let cleanup = do + _ <- GhcConcurrent.tryPutMVar sourceRelease () |> Task.fromIO + GhcConcurrent.killThread clientThread |> Task.fromIO + checkBeforeEof |> Task.finally cleanup + it "sendRaw PUT delivers method, raw body and custom header" \_ -> do withMockServer mockEchoApp \testPort -> do response <- diff --git a/docs/changes/016-http-client-byte-level-methods.md b/docs/changes/016-http-client-byte-level-methods.md index fcb33518e..c6c1b4201 100644 --- a/docs/changes/016-http-client-byte-level-methods.md +++ b/docs/changes/016-http-client-byte-level-methods.md @@ -13,7 +13,7 @@ maintainer requested ("extend `Http.Client`" rather than adding a transport). ```yaml spec issue: adhoc:http-client-byte-level-methods kind: feature -touches: [http-client] +touches: [http-client, ci-cd, dev-pipeline] breaking: false new-dependency: false new-capability: false @@ -24,10 +24,26 @@ new-extension-point: false `getSecure` and `getRaw` keep their signatures and become `Get` specializations of the new functions. `sendSecure` enforces `https://` exactly like -`getSecure`; `sendRaw` is the loopback-only twin exported from -`Http.Client.Internal`, mirroring the existing `getRaw` split. Both reuse the -existing request options (headers, timeout, `maxRedirects = 0` default, proxy -disabled, `maxResponseBytes` limit) and the pinned TLS 1.2+ manager. +`getSecure`; `sendRaw` is the trusted-caller twin exported from +`Http.Client.Internal`, mirroring the existing `getRaw` split. It does not +validate that a host is loopback. Only the secure path uses the pinned TLS +1.2+ manager. Both accept request options for headers, response timeout, +redirect count (`maxRedirects = 0` by default), and `maxResponseBytes`. +Change 022 proposes executable proof and repair of the intended direct-only +transport and incremental byte-limit guarantees; the current implementation +does not yet establish them. The timeout is not a promised total-body deadline. + +Supporting CI changes capture the Core suite report, make the service job wait +for Core, and combine both reports for runtime-criterion validation. Missing +reports must fail, not silently remove the HTTP examples. `./dev workflow-check` +contains the positive and negative report-wiring controls. + +Pending explicit API decision: the existing public plumbing helper +`applyMethodAndBody :: Method -> Bytes -> Network.HTTP.Client.Request -> +Network.HTTP.Client.Request` is omitted from the original signature promise. +The smallest non-breaking choice is to declare it accurately here; hiding it +requires a separately approved removal/breaking declaration. No decision has +been recorded, so the signatures block below is not yet amended for the helper. ```diff signatures + Http.Client: data Method diff --git a/docs/changes/021-crypto-sha256-hmac-hex.md b/docs/changes/021-crypto-sha256-hmac-hex.md index 0fe8df255..5cff89f2e 100644 --- a/docs/changes/021-crypto-sha256-hmac-hex.md +++ b/docs/changes/021-crypto-sha256-hmac-hex.md @@ -42,7 +42,7 @@ secret. | C1 | `sha256` matches the FIPS 180-4 vectors for `""` and `"abc"` | `hspec:nhcore-test-core:core/test/CryptoSpec.hs#hashes the empty input to the FIPS 180-4 vector`
`hspec:nhcore-test-core:core/test/CryptoSpec.hs#hashes abc to the FIPS 180-4 vector` | unit | none | | C2 | `hmacSha256` matches RFC 4231 test case 2 | `hspec:nhcore-test-core:core/test/CryptoSpec.hs#matches RFC 4231 test case 2 (key Jefe)` | unit | none | | C3 | `hmacSha256` accepts keys shorter than 32 bytes | `hspec:nhcore-test-core:core/test/CryptoSpec.hs#accepts keys shorter than 32 bytes, unlike signWith` | unit | none | -| C4 | `signWith` is unchanged: it equals `hmacSha256` + `toHex` for a valid key | `hspec:nhcore-test-core:core/test/CryptoSpec.hs#agrees with signWith for a valid HmacKey` | unit | none | +| C4 | `signWith` preserves the independent known answers for nonempty and empty messages | `hspec:nhcore-test-core:core/test/CryptoSpec.hs#matches the HMAC-SHA256 known answer`
`hspec:nhcore-test-core:core/test/CryptoSpec.hs#matches the known answer for an empty message` | unit | none | | C5 | `toHex` is lowercase, two characters per byte, empty for empty | `hspec:nhcore-test-core:core/test/CryptoSpec.hs#encodes two lowercase characters per byte`
`hspec:nhcore-test-core:core/test/CryptoSpec.hs#encodes the empty input to the empty text` | unit | none | ## User impact diff --git a/docs/changes/022-http-byte-transport-guarantees.md b/docs/changes/022-http-byte-transport-guarantees.md new file mode 100644 index 000000000..b0938681e --- /dev/null +++ b/docs/changes/022-http-byte-transport-guarantees.md @@ -0,0 +1,127 @@ +# Change 022: Enforce the byte-level HTTP transport guarantees + +Proposed remediation for #905, not an approved implementation. Byte-level +clients must verify HTTPS peers, stop reading oversized bodies before EOF, +and bypass environment proxies. Existing JSON APIs are outside this change. + +```yaml spec +issue: adhoc:http-byte-transport-guarantees +kind: bug +touches: [http-client, core-primitives, ci-cd, dev-pipeline] +breaking: false +new-dependency: false +new-capability: false +new-extension-point: false +``` + +## Contract delta + +No new public HTTP type or method. Preserve the signatures and default values +of `sendSecure`, `getSecure`, `sendRaw` and `getRaw`. The helper export decision +is recorded in Change 016 and requires explicit maintainer choice; this draft +does not authorize removing it. Existing timeout semantics remain response +inactivity timeout, not a total-body deadline. Limits apply to byte-level +responses, not every JSON request. + +```diff signatures +``` + +## Criteria + +C1 is the minimal newly added repro. It sends five bytes on a real chunked +response with limit four, flushes them, and withholds EOF behind a latch. The +client must return `ResponseTooLarge 4` while the latch remains closed. An +actual HTTP200 positive control checks the same listening fixture first. A +separate source-flushed signal must be observed before the client observation +window begins; missing delivery fails as fixture setup, not the regression +identity. Two seconds is each test observation window, not a new product timeout. The test +releases its source and stops its client on either outcome. The existing +fixture's readiness sleep is inherited; failure to connect is not an accepted +red identity. Formal red evidence requires the exact assertion below. + +| ID | Behavior | Proving test | Level | Boundary | +|----|----------|--------------|-------|----------| +| C1 | Reject an oversized chunk before the source may finish | `hspec:nhcore-test-core:core/test/Http/ClientRawSpec.hs#sendRaw rejects an oversized chunk before source EOF` | integration | http:real | +| C2 | Preserve method, body, headers and raw non-2xx behavior | `hspec:nhcore-test-core:core/test/Http/ClientRawSpec.hs#sendRaw PUT delivers method, raw body and custom header`
`hspec:nhcore-test-core:core/test/Http/ClientRawSpec.hs#sendRaw DELETE surfaces a 404 as a status code, not an error` | integration | http:real | +| C3 | Preserve independent public Crypto compatibility vectors | `hspec:nhcore-test-core:core/test/CryptoSpec.hs#matches the HMAC-SHA256 known answer`
`hspec:nhcore-test-core:core/test/CryptoSpec.hs#matches the known answer for an empty message` | unit | none | +| C4 | Preserve combined Core/service report wiring and its missing-report controls | `script:scripts/workflow-check#--self-test` | unit | none | + +### Required additional criteria before implementation + +This bounded draft is NOT final Gate 1-ready. The following exact proposed +selector names must become real tests and typed criteria before formal approval; +no placeholder, skipped test, helper-only proof, or existing suite count can +stand in for them. Add to `core/test/Http/ClientRawSpec.hs`, suite +`nhcore-test-core`, attest `integration / http:real` in `test-surfaces.json`. + +- `sendSecure accepts a trusted TLS peer`: synthetic local CA via a test-only + trust seam through the same secure request path; verify status, header and + bytes. Preserve chain/hostname verification and TLS 1.2+. Also verify the + supported library/system trust-loading path separately without public egress + or installing a fixture CA globally. Stop if the chosen library cannot offer + an isolated test store without weakening the default manager. +- `sendSecure rejects an untrusted TLS peer` and + `sendSecure rejects a wrong TLS hostname`: separate CA and wrong-name + negatives against the otherwise working TLS fixture. Disabling verification + must make the negatives fail. TLS 1.1 must remain rejected. +- `sendSecure rejects an oversized chunk before source EOF`: the C1 contract + through real trusted TLS, plus socket-close observation. Raw C1 alone is not + proof of the secure path. +- `byte paths preserve exact zero unknown length and HEAD limits`: both paths; + zero/empty succeeds, zero/nonempty fails, exactly N succeeds, N+1 fails, + chunked and close-delimited unknown lengths stop early, oversized advertised + length rejects without a full body, HEAD succeeds with empty body despite + large advertised length. Count delivered/decompressed body bytes. A finite + paced tail and EOF latch must distinguish post-read checks; allow transport + buffer overshoot rather than requiring server writes equal N. +- `byte paths bypass a proven environment proxy trap`: fresh process per env + case, both cases of HTTP_PROXY/HTTPS_PROXY set before any cached manager, + empty NO_PROXY/no_proxy. Positive control reaches trap with absolute HTTP + request and HTTPS CONNECT. Actual byte paths then reach owned origins with + success and no trap events. Use only synthetic authorization. Assert direct + manager behavior, not merely `request.proxy = Nothing`. + +Use held loopback sockets/readiness signals for the expanded fixtures; do not +solve fixture races by increasing sleeps. The hard requirement is early +termination and response closure; no fixed RSS bound or universal buffer size +is invented. Test the actual boundary, not only the helper. Independent known +answers remain the Crypto oracle. These scoped principles are obligations of +this spec and its executable checks, not a new agent framework. + +## Implementation boundary and gates + +Localized sources: `core/http/Http/Client.hs` (`secureTlsManager`, +`sendSecureRawIO`, `readBodyFully`, `readBodyChunks`, `applyRequestOptions`), +`core/http/Http/Client/Internal.hs` (`sendRawInternalIO`, `applyRequestOptions`). +Copy/adapt tests from `core/test/Http/ClientRawSpec.hs`; preserve existing +expectations. Prefer a bounded incremental reader with prompt response close, +without a new public abstraction. Do not alter Crypto production code. + +Supporting scope: correct Change 016 CI/tooling ownership and inaccurate +loopback/shared-manager wording; point Change 021 C4 at existing independent +known answers. Preserve combined Core/service criteria reports. Correct API, +release and header/limit/timeout prose only as approved, with generated codemap +regeneration on the owner-approved base. Never hand-edit generated counters. + +Gate 1 requires a committed C1 failure, verified native red-evidence receipt, +final exact criteria, and explicit maintainer approval. No historical receipt +was recovered in this worktree. After approval, run `./dev spec-check --plan` +and required local security review before product edits; do not publish local +security notes. Performance review follows actual risk routing, not an invented +requirement. Full native tests and current-base CI remain future gates. + +## User impact + +Apps using byte-level HTTP should receive valid HTTPS responses, avoid proxy +environment routing, and reject oversized responses without downloading the +whole source. No app edits are proposed for existing intended APIs. `sendRaw` +remains a trusted-caller API: loopback is guidance, not an enforced host policy. +The undocumented public helper choice remains open. No release is claimed. + +## ADR + +Not required by mechanical flags at this draft stage. The existing public API +ADR rule and any helper removal require an explicit maintainer disposition; +choosing removal must update breaking metadata and the relevant ADR before +approval. The incremental limit implements the existing ADR-0036 obligation, +not a relaxed post-read promise. diff --git a/docs/changes/test-surfaces.json b/docs/changes/test-surfaces.json index 4538a4cbb..d6c615375 100644 --- a/docs/changes/test-surfaces.json +++ b/docs/changes/test-surfaces.json @@ -33,6 +33,15 @@ } }, "boundaries": [ + { + "kind": "hspec", + "suite": "nhcore-test-core", + "path": "core/test/Http/ClientRawSpec.hs", + "match": "sendRaw rejects an oversized chunk before source EOF", + "boundary": "http:real", + "expected_examples": 1, + "fixture": "Http.Client.Internal.sendRaw" + }, { "kind": "script", "path": "testbed/scripts/cold-start-readiness.sh", From 6a9a6e5c1dc31d6eb52ff505cf4542a1b0c6bd1c Mon Sep 17 00:00:00 2001 From: stepandra Date: Tue, 13 Oct 2026 03:53:19 +0900 Subject: [PATCH 08/13] test(http): add real TLS proxy and streaming regression controls --- core/test/Http/transport_fixture.py | 277 ++++++++++++++++++ .../022-http-byte-transport-guarantees.md | 21 +- docs/changes/test-surfaces.json | 7 + 3 files changed, 302 insertions(+), 3 deletions(-) create mode 100755 core/test/Http/transport_fixture.py diff --git a/core/test/Http/transport_fixture.py b/core/test/Http/transport_fixture.py new file mode 100755 index 000000000..b3560a8ab --- /dev/null +++ b/core/test/Http/transport_fixture.py @@ -0,0 +1,277 @@ +#!/usr/bin/env python3 +"""Synthetic loopback transport regressions. Invoke from the repository root. + +Adapted from the PR905 audit server/probes. This executable uses the repository's +native ./dev toolchain, never an external provider or globally installed CA. +The TLS control injects trust into a test manager, not the public cached manager. +""" +import argparse +import contextlib +import http.server +import json +import os +from pathlib import Path +import ssl +import subprocess +import tempfile +import threading +import time + +ROOT = Path(__file__).resolve().parents[3] + + +class Fixture: + def __init__(self, directory): + self.directory = directory + self.events = [] + self.lock = threading.Lock() + self.release = threading.Event() + self.servers = [] + self.threads = [] + + def event(self, **entry): + with self.lock: + self.events.append(entry) + + def start(self, kind, context=None): + owner = self + + class Handler(http.server.BaseHTTPRequestHandler): + protocol_version = "HTTP/1.1" + + def log_message(self, *args): + pass + + def do_CONNECT(self): + owner.event(kind=kind, method="CONNECT", path=self.path) + self.send_error(502) + + def do_HEAD(self): + self.respond() + + def do_GET(self): + self.respond() + + def do_PUT(self): + self.respond() + + def respond(self): + self.rfile.read(int(self.headers.get("Content-Length", "0"))) + owner.event(kind=kind, method=self.command, path=self.path) + if self.path.startswith("/paced"): + self.send_response(200) + if self.path.endswith("chunked"): + self.send_header("Transfer-Encoding", "chunked") + data = b"5\r\n12345\r\n" + else: + self.send_header("Connection", "close") + self.close_connection = True + data = b"12345" + self.end_headers() + self.wfile.write(data) + self.wfile.flush() + owner.event(kind=kind, method="FLUSHED", path=self.path) + owner.release.wait(15) + return + body = b"proxy" if kind == "proxy" else b"1234" + if self.path == "/empty": + body = b"" + self.send_response(200) + length = 10000 if self.path == "/head" else len(body) + self.send_header("Content-Length", str(length)) + self.send_header("X-Fixture", kind) + self.end_headers() + if self.command != "HEAD": + self.wfile.write(body) + + server = http.server.ThreadingHTTPServer(("127.0.0.1", 0), Handler) + server.daemon_threads = True + if context: + server.socket = context.wrap_socket(server.socket, server_side=True) + self.servers.append(server) + thread = threading.Thread(target=server.serve_forever, daemon=True) + thread.start() + self.threads.append(thread) + return server.server_port + + def close(self): + self.release.set() + for server in self.servers: + server.shutdown() + server.server_close() + for thread in self.threads: + thread.join() + + +def clean_env(): + env = os.environ.copy() + for name in ("http_proxy", "HTTP_PROXY", "https_proxy", "HTTPS_PROXY", + "all_proxy", "ALL_PROXY", "no_proxy", "NO_PROXY"): + env.pop(name, None) + env["no_proxy"] = "" + env["NO_PROXY"] = "" + return env + + +def repl(directory, name, expressions, env): + source = directory / (name + ".ghci") + source.write_text(COMMON + expressions + "\n:quit\n") + command = [str(ROOT / "dev"), "exec", "cabal", "repl", "lib:nhcore", + "--project-file=cabal.project.dev", "--offline", "-j1", "-v0", + "--repl-options=-package crypton-x509-store"] + with source.open() as stream: + result = subprocess.run(command, cwd=ROOT, env=env, stdin=stream, + stdout=subprocess.PIPE, stderr=subprocess.PIPE, + text=True, timeout=120) + (directory / (name + ".stdout")).write_text(result.stdout) + (directory / (name + ".stderr")).write_text(result.stderr) + print(result.stdout, end="") + print(result.stderr, end="") + if result.returncode != 0 or "error:" in result.stderr or "*** Exception" in result.stdout: + raise AssertionError("native REPL compilation/execution failed, not a transport regression") + return result.stdout + + +COMMON = """:set -XOverloadedStrings -XTypeApplications -XOverloadedRecordDot +import Prelude qualified as P +import Http.Client qualified as H +import Http.Client.Internal qualified as R +import Network.HTTP.Client qualified as HC +import Network.HTTP.Client.TLS qualified as HT +import Network.Connection qualified as C +import Network.TLS qualified as TLS +import Data.X509.CertificateStore qualified as CA +import Control.Exception qualified as E +import System.Timeout qualified as Timeout +import Task qualified +import Bytes qualified as B +import Text qualified as T +import Result qualified as Result +""" + + +def certificate(directory): + cert, key = directory / "cert.pem", directory / "key.pem" + command = ["openssl", "req", "-x509", "-newkey", "rsa:2048", "-nodes", + "-keyout", str(key), "-out", str(cert), "-days", "2", "-subj", + "/CN=localhost", "-addext", "subjectAltName=DNS:localhost"] + subprocess.run(command, check=True, stdout=subprocess.PIPE, stderr=subprocess.PIPE) + context = ssl.SSLContext(ssl.PROTOCOL_TLS_SERVER) + context.minimum_version = ssl.TLSVersion.TLSv1_2 + context.load_cert_chain(cert, key) + return context, cert + + +def tls_case(fixture, directory): + context, cert = certificate(directory) + port = fixture.start("tls", context) + text = f""" +let params = (TLS.defaultParamsClient "" "") {{TLS.clientSupported=TLS.defaultSupported {{TLS.supportedVersions=H.secureTlsSupportedVersions}}}} +P.Just trust <- CA.readCertificateStore {json.dumps(str(cert))} +let trustedParams = params {{TLS.clientShared=(TLS.clientShared params) {{TLS.sharedCAStore=trust}}}} +trusted <- HC.newManager (HC.managerSetProxy HC.noProxy (HT.mkManagerSettings (C.TLSSettings trustedParams) P.Nothing)) +untrusted <- HC.newManager (HC.managerSetProxy HC.noProxy (HT.mkManagerSettings (C.TLSSettings params) P.Nothing)) +rightName <- HC.parseRequest "https://localhost:{port}/tls" +wrongName <- HC.parseRequest "https://127.0.0.1:{port}/tls" +positive <- E.try @HC.HttpException (HC.httpLbs rightName trusted) +negativeCa <- E.try @HC.HttpException (HC.httpLbs rightName untrusted) +negativeHost <- E.try @HC.HttpException (HC.httpLbs wrongName trusted) +P.print ("TLS_TRUSTED" :: P.String, P.either (P.const P.False) (P.const P.True) positive) +P.print ("TLS_UNTRUSTED" :: P.String, P.either (P.const P.True) (P.const P.False) negativeCa) +P.print ("TLS_WRONG_HOST" :: P.String, P.either (P.const P.True) (P.const P.False) negativeHost) +public <- Task.runResult (H.sendSecure H.Get (H.withUrl "https://localhost:{port}/public-untrusted" H.request) B.empty) +P.print ("PUBLIC_UNTRUSTED" :: P.String, Result.isErr public) +""" + output = repl(directory, "tls", text, clean_env()) + for marker in ("TLS_TRUSTED", "TLS_UNTRUSTED", "TLS_WRONG_HOST", "PUBLIC_UNTRUSTED"): + assert f'("{marker}",True)' in output, marker + print("PASS: injected-manager trust and hostname controls; public untrusted rejection") + print("NOT PROVED: trusted public cached-manager success or system-store integration") + + +def proxy_case(fixture, directory): + origin = fixture.start("origin") + context, _ = certificate(directory) + secure = fixture.start("tls", context) + proxy = fixture.start("proxy") + failures = [] + for case in ("lower", "upper"): + env = clean_env() + for scheme in ("http", "https"): + name = scheme + "_proxy" + env[name if case == "lower" else name.upper()] = f"http://127.0.0.1:{proxy}" + text = f""" +controlManager <- HC.newManager HT.tlsManagerSettings +control <- HC.parseRequest "http://127.0.0.1:{origin}/control-{case}" +E.try @HC.HttpException (HC.httpLbs control controlManager) P.>>= P.print +controlTls <- HC.parseRequest "https://localhost:{secure}/control-{case}" +E.try @HC.HttpException (HC.httpLbs controlTls controlManager) P.>>= P.print +P.putStrLn "PROXY_CONTROL_COMPLETE" +Task.runResult (R.sendRaw H.Put (H.addHeader "Authorization" "synthetic-test" (H.withUrl "http://127.0.0.1:{origin}/actual-{case}" H.request)) (T.toBytes "synthetic")) P.>>= P.print +P.putStrLn "RAW_COMPLETE" +Task.runResult (H.sendSecure H.Get (H.withUrl "https://localhost:{secure}/actual-{case}" H.request) B.empty) P.>>= P.print +P.putStrLn "SECURE_COMPLETE" +""" + before = len(fixture.events) + output = repl(directory, "proxy-" + case, text, env) + assert all(marker in output for marker in ("PROXY_CONTROL_COMPLETE", "RAW_COMPLETE", "SECURE_COMPLETE")) + events = fixture.events[before:] + control_http = [e for e in events if e["kind"] == "proxy" and e["path"].endswith("/control-" + case)] + connects = [e for e in events if e["kind"] == "proxy" and e["method"] == "CONNECT"] + assert control_http and connects, "proxy positive control failed" + actual_proxy = [e for e in events if e["kind"] == "proxy" and e["path"].endswith("/actual-" + case)] + actual_origin = [e for e in events if e["kind"] == "origin" and e["path"].endswith("/actual-" + case)] + if actual_proxy or len(connects) != 1 or not actual_origin: + failures.append(case) + assert not failures, "REGRESSION_ASSERT:environment-proxy-traversal:" + ",".join(failures) + print("PASS: raw origin reached and no actual proxy/CONNECT traversal") + print("NOT PROVED: secure trusted-origin success; TLS trust is a separate prerequisite") + + +def body_case(fixture, directory): + port = fixture.start("origin") + text = f""" +let raw method path cap = Task.runResult (R.sendRaw method (H.withMaxResponseSize cap (H.withUrl (T.fromLinkedList ("http://127.0.0.1:{port}" P.++ path)) H.request)) B.empty) +exact <- raw H.Get "/exact" 4 +empty <- raw H.Get "/empty" 1 +headOnly <- raw H.Head "/head" 1 +zeroBuilder <- E.try @E.ErrorCall (E.evaluate (H.withMaxResponseSize 0 H.request)) +P.print ("ZERO_REJECTED" :: P.String, P.either (P.const P.True) (P.const P.False) zeroBuilder) +P.print ("EXACT" :: P.String, case exact of Result.Ok response -> B.length response.body P.== 4; Result.Err _ -> P.False) +P.print ("ZERO" :: P.String, case empty of Result.Ok response -> B.length response.body P.== 0; Result.Err _ -> P.False) +P.print ("HEAD" :: P.String, case headOnly of Result.Ok response -> B.length response.body P.== 0; Result.Err _ -> P.False) +P.putStrLn "BODY_CONTROLS_COMPLETE" +Timeout.timeout 2000000 (raw H.Get "/paced-chunked" 4) P.>>= P.print +P.putStrLn "CHUNKED_COMPLETE" +Timeout.timeout 2000000 (raw H.Get "/paced-close" 4) P.>>= P.print +P.putStrLn "UNKNOWN_COMPLETE" +""" + output = repl(directory, "body", text, clean_env()) + control_output = output.split("BODY_CONTROLS_COMPLETE")[0] + assert all(f'("{name}",True)' in control_output for name in ("EXACT", "ZERO", "HEAD", "ZERO_REJECTED")), "exact/empty/HEAD/zero-builder control failed" + for path in ("/paced-chunked", "/paced-close"): + assert any(e["method"] == "FLUSHED" and e["path"] == path for e in fixture.events), "source never flushed" + assert output.count("Just (Err (ResponseTooLarge 4))") == 2, "REGRESSION_ASSERT:body-read-awaits-EOF" + print("PASS: raw exact/empty/HEAD, zero-builder rejection and unknown/chunked early cutoff") + + +def main(): + parser = argparse.ArgumentParser() + parser.add_argument("mode", choices=("tls", "proxy", "body")) + parser.add_argument("--evidence-dir", type=Path) + args = parser.parse_args() + with tempfile.TemporaryDirectory(prefix="nh-http-fixture-") as temp: + directory = args.evidence_dir.resolve() if args.evidence_dir else Path(temp) + directory.mkdir(parents=True, exist_ok=True) + fixture = Fixture(directory) + try: + {"tls": tls_case, "proxy": proxy_case, "body": body_case}[args.mode](fixture, directory) + finally: + fixture.close() + (directory / "server-events.json").write_text(json.dumps(fixture.events, indent=2)) + with contextlib.suppress(FileNotFoundError): + (directory / "key.pem").unlink() + + +if __name__ == "__main__": + main() diff --git a/docs/changes/022-http-byte-transport-guarantees.md b/docs/changes/022-http-byte-transport-guarantees.md index b0938681e..5ce83c891 100644 --- a/docs/changes/022-http-byte-transport-guarantees.md +++ b/docs/changes/022-http-byte-transport-guarantees.md @@ -45,11 +45,24 @@ red identity. Formal red evidence requires the exact assertion below. | C2 | Preserve method, body, headers and raw non-2xx behavior | `hspec:nhcore-test-core:core/test/Http/ClientRawSpec.hs#sendRaw PUT delivers method, raw body and custom header`
`hspec:nhcore-test-core:core/test/Http/ClientRawSpec.hs#sendRaw DELETE surfaces a 404 as a status code, not an error` | integration | http:real | | C3 | Preserve independent public Crypto compatibility vectors | `hspec:nhcore-test-core:core/test/CryptoSpec.hs#matches the HMAC-SHA256 known answer`
`hspec:nhcore-test-core:core/test/CryptoSpec.hs#matches the known answer for an empty message` | unit | none | | C4 | Preserve combined Core/service report wiring and its missing-report controls | `script:scripts/workflow-check#--self-test` | unit | none | +| C5 | Test-manager trusted TLS succeeds, untrusted CA/wrong hostname fail, public untrusted TLS fails (not public trusted success) | `script:core/test/Http/transport_fixture.py#tls` | integration | http:real | +| C6 | Fresh-process lower/uppercase env proxy traps work, actual raw request reaches origin and actual secure CONNECT avoids trap | `script:core/test/Http/transport_fixture.py#proxy` | integration | http:real | +| C7 | Raw exact/empty/HEAD and existing zero-builder rejection controls pass; chunked and unknown-length reads reject before EOF | `script:core/test/Http/transport_fixture.py#body` | integration | http:real | ### Required additional criteria before implementation -This bounded draft is NOT final Gate 1-ready. The following exact proposed -selector names must become real tests and typed criteria before formal approval; +The script uses Python stdlib loopback fixtures and invokes `./dev exec cabal +repl` for the actual Haskell request path. It checks clean compilation and +explicit output markers rather than trusting GHCi exit0. Temporary synthetic +keys are deleted and listeners close in `finally`; no system trust is changed. + +C5–C7 now provide executable audit-derived transport controls without any +production test seam. C5 deliberately injects trust only into a test manager; +it does not prove public trusted success. C6 isolates traversal while secure +origin success is still blocked by trust. C7 covers raw reads only. + +This bounded draft is NOT final Gate 1-ready. The following remaining promises +must become real tests and typed criteria before formal approval; no placeholder, skipped test, helper-only proof, or existing suite count can stand in for them. Add to `core/test/Http/ClientRawSpec.hs`, suite `nhcore-test-core`, attest `integration / http:real` in `test-surfaces.json`. @@ -68,7 +81,9 @@ stand in for them. Add to `core/test/Http/ClientRawSpec.hs`, suite through real trusted TLS, plus socket-close observation. Raw C1 alone is not proof of the secure path. - `byte paths preserve exact zero unknown length and HEAD limits`: both paths; - zero/empty succeeds, zero/nonempty fails, exactly N succeeds, N+1 fails, + zero is currently rejected by the builder (C7 preserves that behavior); + any future zero-byte reader contract needs explicit approval, exactly N + succeeds, N+1 fails, chunked and close-delimited unknown lengths stop early, oversized advertised length rejects without a full body, HEAD succeeds with empty body despite large advertised length. Count delivered/decompressed body bytes. A finite diff --git a/docs/changes/test-surfaces.json b/docs/changes/test-surfaces.json index a19f377f4..bb6f2e635 100644 --- a/docs/changes/test-surfaces.json +++ b/docs/changes/test-surfaces.json @@ -38,6 +38,13 @@ } }, "boundaries": [ + { + "kind": "script", + "path": "core/test/Http/transport_fixture.py", + "boundary": "http:real", + "expected_examples": 1, + "fixture": "Http.Client.syntheticTransport" + }, { "kind": "hspec", "suite": "nhcore-test-core", From cabbde64b24b7a6acd6da7f45059be03dac8d5c9 Mon Sep 17 00:00:00 2001 From: stepandra Date: Tue, 13 Oct 2026 03:54:12 +0900 Subject: [PATCH 09/13] test(http): verify trusted TLS response identity --- core/test/Http/transport_fixture.py | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/core/test/Http/transport_fixture.py b/core/test/Http/transport_fixture.py index b3560a8ab..800b35b20 100755 --- a/core/test/Http/transport_fixture.py +++ b/core/test/Http/transport_fixture.py @@ -138,6 +138,7 @@ def repl(directory, name, expressions, env): import Http.Client.Internal qualified as R import Network.HTTP.Client qualified as HC import Network.HTTP.Client.TLS qualified as HT +import Network.HTTP.Types.Status qualified as Status import Network.Connection qualified as C import Network.TLS qualified as TLS import Data.X509.CertificateStore qualified as CA @@ -176,7 +177,7 @@ def tls_case(fixture, directory): positive <- E.try @HC.HttpException (HC.httpLbs rightName trusted) negativeCa <- E.try @HC.HttpException (HC.httpLbs rightName untrusted) negativeHost <- E.try @HC.HttpException (HC.httpLbs wrongName trusted) -P.print ("TLS_TRUSTED" :: P.String, P.either (P.const P.False) (P.const P.True) positive) +P.print ("TLS_TRUSTED" :: P.String, P.either (P.const P.False) (\\response -> HC.responseStatus response P.== Status.status200 P.&& P.lookup "X-Fixture" (HC.responseHeaders response) P.== P.Just "tls" P.&& HC.responseBody response P.== "1234") positive) P.print ("TLS_UNTRUSTED" :: P.String, P.either (P.const P.True) (P.const P.False) negativeCa) P.print ("TLS_WRONG_HOST" :: P.String, P.either (P.const P.True) (P.const P.False) negativeHost) public <- Task.runResult (H.sendSecure H.Get (H.withUrl "https://localhost:{port}/public-untrusted" H.request) B.empty) From ef854440fa0c829ce30ab8e6abd6c8bc9d377273 Mon Sep 17 00:00:00 2001 From: stepandra Date: Wed, 14 Oct 2026 01:51:52 +0900 Subject: [PATCH 10/13] test(http): add isolated public trust and socket closure controls --- core/test/Http/transport_fixture.py | 62 +++++++++++++++++-- .../022-http-byte-transport-guarantees.md | 11 ++++ 2 files changed, 67 insertions(+), 6 deletions(-) diff --git a/core/test/Http/transport_fixture.py b/core/test/Http/transport_fixture.py index 800b35b20..bce2d0b63 100755 --- a/core/test/Http/transport_fixture.py +++ b/core/test/Http/transport_fixture.py @@ -12,6 +12,8 @@ import os from pathlib import Path import ssl +import socket +import sys import subprocess import tempfile import threading @@ -71,7 +73,18 @@ def respond(self): self.wfile.write(data) self.wfile.flush() owner.event(kind=kind, method="FLUSHED", path=self.path) - owner.release.wait(15) + started = time.monotonic() + self.connection.settimeout(0.1) + while not owner.release.is_set() and time.monotonic() - started < 15: + try: + data = self.connection.recv(1) + except socket.timeout: + continue + if not data: + owner.event(kind=kind, method="CLOSED", path=self.path, + elapsed=time.monotonic() - started) + return + owner.event(kind=kind, method="SOURCE_EOF", path=self.path) return body = b"proxy" if kind == "proxy" else b"1234" if self.path == "/empty": @@ -229,7 +242,7 @@ def proxy_case(fixture, directory): print("NOT PROVED: secure trusted-origin success; TLS trust is a separate prerequisite") -def body_case(fixture, directory): +def body_case(fixture, directory, secure_internal=False): port = fixture.start("origin") text = f""" let raw method path cap = Task.runResult (R.sendRaw method (H.withMaxResponseSize cap (H.withUrl (T.fromLinkedList ("http://127.0.0.1:{port}" P.++ path)) H.request)) B.empty) @@ -247,18 +260,51 @@ def body_case(fixture, directory): Timeout.timeout 2000000 (raw H.Get "/paced-close" 4) P.>>= P.print P.putStrLn "UNKNOWN_COMPLETE" """ - output = repl(directory, "body", text, clean_env()) + if secure_internal: + text = ":module + *Http.Client\n" + text.replace( + "Task.runResult (R.sendRaw method", "sendSecureRawIO method").replace( + ")) B.empty)", ")) B.empty") + output = repl(directory, "secure-internal-body" if secure_internal else "body", text, clean_env()) control_output = output.split("BODY_CONTROLS_COMPLETE")[0] assert all(f'("{name}",True)' in control_output for name in ("EXACT", "ZERO", "HEAD", "ZERO_REJECTED")), "exact/empty/HEAD/zero-builder control failed" for path in ("/paced-chunked", "/paced-close"): assert any(e["method"] == "FLUSHED" and e["path"] == path for e in fixture.events), "source never flushed" assert output.count("Just (Err (ResponseTooLarge 4))") == 2, "REGRESSION_ASSERT:body-read-awaits-EOF" - print("PASS: raw exact/empty/HEAD, zero-builder rejection and unknown/chunked early cutoff") + for path in ("/paced-chunked", "/paced-close"): + assert any(e["method"] == "CLOSED" and e["path"] == path and e["elapsed"] < 2 + for e in fixture.events), "response did not close before the source deadline" + assert not any(e["method"] == "SOURCE_EOF" and e["path"] == path + for e in fixture.events), "source completed before client rejection" + print("PASS: exact/empty/HEAD, zero-builder rejection, early cutoff and socket close") + if secure_internal: + print("DIAGNOSTIC ONLY: real secure reader over plaintext; public HTTPS trust not exercised") + + +def public_trust_case(fixture, directory): + if sys.platform == "darwin" or sys.platform == "win32": + print("UNSUPPORTED: pinned native trust loader has no isolated environment bundle override") + raise SystemExit(77) + context, cert = certificate(directory) + port = fixture.start("tls", context) + env = clean_env() + env["SYSTEM_CERTIFICATE_PATH"] = str(cert) + text = f""" +controlManager <- HC.newManager (HC.managerSetProxy HC.noProxy HT.tlsManagerSettings) +controlRequest <- HC.parseRequest "https://localhost:{port}/library-control" +control <- E.try @HC.HttpException (HC.httpLbs controlRequest controlManager) +P.print ("SYSTEM_BUNDLE_CONTROL" :: P.String, P.either (P.const P.False) (\\response -> HC.responseStatus response P.== Status.status200 P.&& HC.responseBody response P.== "1234") control) +public <- Task.runResult (H.sendSecure H.Get (H.withUrl "https://localhost:{port}/public-trusted" H.request) B.empty) +P.print ("PUBLIC_TRUSTED" :: P.String, case public of Result.Ok response -> response.statusCode P.== 200 P.&& response.body P.== T.toBytes "1234"; Result.Err _ -> P.False) +""" + output = repl(directory, "public-trust", text, env) + assert '("SYSTEM_BUNDLE_CONTROL",True)' in output, "isolated system bundle positive control failed" + assert '("PUBLIC_TRUSTED",True)' in output, "REGRESSION_ASSERT:public-trust-store-not-loaded" + print("PASS: actual public manager accepts the isolated native system bundle") def main(): parser = argparse.ArgumentParser() - parser.add_argument("mode", choices=("tls", "proxy", "body")) + parser.add_argument("mode", choices=("tls", "proxy", "body", "secure-internal-body", "public-trust")) parser.add_argument("--evidence-dir", type=Path) args = parser.parse_args() with tempfile.TemporaryDirectory(prefix="nh-http-fixture-") as temp: @@ -266,7 +312,11 @@ def main(): directory.mkdir(parents=True, exist_ok=True) fixture = Fixture(directory) try: - {"tls": tls_case, "proxy": proxy_case, "body": body_case}[args.mode](fixture, directory) + if args.mode == "secure-internal-body": + body_case(fixture, directory, secure_internal=True) + else: + {"tls": tls_case, "proxy": proxy_case, "body": body_case, + "public-trust": public_trust_case}[args.mode](fixture, directory) finally: fixture.close() (directory / "server-events.json").write_text(json.dumps(fixture.events, indent=2)) diff --git a/docs/changes/022-http-byte-transport-guarantees.md b/docs/changes/022-http-byte-transport-guarantees.md index 5ce83c891..bdf837572 100644 --- a/docs/changes/022-http-byte-transport-guarantees.md +++ b/docs/changes/022-http-byte-transport-guarantees.md @@ -48,9 +48,20 @@ red identity. Formal red evidence requires the exact assertion below. | C5 | Test-manager trusted TLS succeeds, untrusted CA/wrong hostname fail, public untrusted TLS fails (not public trusted success) | `script:core/test/Http/transport_fixture.py#tls` | integration | http:real | | C6 | Fresh-process lower/uppercase env proxy traps work, actual raw request reaches origin and actual secure CONNECT avoids trap | `script:core/test/Http/transport_fixture.py#proxy` | integration | http:real | | C7 | Raw exact/empty/HEAD and existing zero-builder rejection controls pass; chunked and unknown-length reads reject before EOF | `script:core/test/Http/transport_fixture.py#body` | integration | http:real | +| C8 | On a supported Unix trust loader, the real public HTTPS manager accepts an isolated system bundle after a library positive control | `script:core/test/Http/transport_fixture.py#public-trust` | integration | http:real | +| C9 | The internal secure reader rejects chunked/unknown-length bodies before EOF and closes the actual socket (plaintext diagnostic, not public TLS) | `script:core/test/Http/transport_fixture.py#secure-internal-body` | integration | http:real | ### Required additional criteria before implementation +C8 requires the pinned Unix trust-loader capability: `SYSTEM_CERTIFICATE_PATH` +selects the fixture bundle in a fresh process. The pinned macOS loader uses +Keychains and has no environment-bundle override; macOS/Windows return exit77, +which is unsupported evidence, never a passing or skipped-green criterion. +`SSL_CERT_FILE` is not this dependency's override. C9 invokes the actual private +secure reader over a plaintext loopback socket to isolate read/close behavior; +it cannot stand in for public secure request success. Both body modes observe +peer closure and require it before the source EOF latch/deadline. + The script uses Python stdlib loopback fixtures and invokes `./dev exec cabal repl` for the actual Haskell request path. It checks clean compilation and explicit output markers rather than trusting GHCi exit0. Temporary synthetic From 1e042c517f05402d17777b7eec45a8c2327e47f2 Mon Sep 17 00:00:00 2001 From: stepandra Date: Wed, 14 Oct 2026 01:52:43 +0900 Subject: [PATCH 11/13] test(http): bind socket cleanup proof to bounded read result --- core/test/Http/transport_fixture.py | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/core/test/Http/transport_fixture.py b/core/test/Http/transport_fixture.py index bce2d0b63..12c6030d2 100755 --- a/core/test/Http/transport_fixture.py +++ b/core/test/Http/transport_fixture.py @@ -271,8 +271,11 @@ def body_case(fixture, directory, secure_internal=False): assert any(e["method"] == "FLUSHED" and e["path"] == path for e in fixture.events), "source never flushed" assert output.count("Just (Err (ResponseTooLarge 4))") == 2, "REGRESSION_ASSERT:body-read-awaits-EOF" for path in ("/paced-chunked", "/paced-close"): - assert any(e["method"] == "CLOSED" and e["path"] == path and e["elapsed"] < 2 - for e in fixture.events), "response did not close before the source deadline" + # The Just/ResponseTooLarge assertion above proves the client completed + # without Timeout.timeout cancelling it. Socket timing alone cannot prove + # that: a cancelled unbounded read also closes at roughly two seconds. + assert any(e["method"] == "CLOSED" and e["path"] == path + for e in fixture.events), "response did not close after bounded completion" assert not any(e["method"] == "SOURCE_EOF" and e["path"] == path for e in fixture.events), "source completed before client rejection" print("PASS: exact/empty/HEAD, zero-builder rejection, early cutoff and socket close") From 74e8d665f381e9755aa4a6f228f5d7a879e2394f Mon Sep 17 00:00:00 2001 From: stepandra Date: Wed, 14 Oct 2026 02:22:59 +0900 Subject: [PATCH 12/13] fix(http): load system trust and bound direct byte responses --- .../016-http-client-byte-level-methods.md | 7 + core/http/Http/Client.hs | 239 +++++++++--------- core/http/Http/Client/Internal.hs | 116 ++++++--- core/test/Http/transport_fixture.py | 20 +- .../016-http-client-byte-level-methods.md | 9 +- .../022-http-byte-transport-guarantees.md | 18 +- 6 files changed, 235 insertions(+), 174 deletions(-) diff --git a/.changes/016-http-client-byte-level-methods.md b/.changes/016-http-client-byte-level-methods.md index 8cabf0336..c8b72c217 100644 --- a/.changes/016-http-client-byte-level-methods.md +++ b/.changes/016-http-client-byte-level-methods.md @@ -9,4 +9,11 @@ category: Added `Http.Client` can now send PUT, HEAD, DELETE, POST and PATCH requests with a raw byte body and read the status code and headers of every response, including 4xx and 5xx. Use `Http.Client.sendSecure method request body` for HTTPS services and `Http.Client.Internal.sendRaw` for trusted loopback endpoints. `Http.getSecure` and `getRaw` keep working exactly as before. +HTTPS byte requests load the system certificate store while keeping certificate +and hostname checks and TLS 1.2 or later. Byte-level requests ignore environment +proxies and stop retaining response chunks as soon as the configured size limit +is exceeded, closing the response instead of waiting for the entire body. +The limit is not a fixed process-memory cap; network buffers can contain extra +bytes. The raw internal API remains caller-restricted, not a loopback validator. + Existing applications do not need code changes. To verify locally, run `./dev test "Http.Client" nhcore-test-core` and confirm the `sendRaw` and `sendSecure` examples pass. diff --git a/core/http/Http/Client.hs b/core/http/Http/Client.hs index 71b93830c..ac520d808 100644 --- a/core/http/Http/Client.hs +++ b/core/http/Http/Client.hs @@ -47,20 +47,21 @@ import Data.Either qualified as GhcEither import Default (Default (..)) import GHC.Int qualified as GhcInt import Json qualified +import LinkedList qualified import Log qualified import Map (Map) import Map qualified import Maybe (Maybe (..)) import Maybe qualified -import Result (Result (..)) import Network.Connection qualified as Connection import Network.HTTP.Client qualified as HttpClient -import Network.HTTP.Simple qualified as HttpSimple -import Network.HTTP.Simple (setRequestIgnoreStatus) import Network.HTTP.Client.TLS qualified as HttpTls +import Network.HTTP.Simple (setRequestIgnoreStatus) +import Network.HTTP.Simple qualified as HttpSimple import Network.HTTP.Types (hContentLength) import Network.HTTP.Types.Status qualified as HttpStatus import Network.TLS qualified as TLS +import Result (Result (..)) import System.IO qualified as GhcIO import System.IO.Unsafe qualified as GhcUnsafe import Task (Task) @@ -73,16 +74,16 @@ import ToText (toText) data Request = Request { url :: Maybe Text, headers :: Map Text Text, + -- | Request timeout in seconds (default: 10 seconds) timeoutSeconds :: Maybe GhcInt.Int, - -- ^ Request timeout in seconds (default: 10 seconds) + -- | Maximum redirects to follow (default: 0 for SSRF protection) maxRedirects :: GhcInt.Int, - -- ^ Maximum redirects to follow (default: 0 for SSRF protection) - maxResponseBytes :: !(Maybe GhcInt.Int) - -- ^ Maximum response body size in bytes (default: 10MB). - -- Enforced in 'getSecure' only. Other methods ('get', 'post', etc.) do not - -- check this limit. The check is post-read (full body is fetched first, then - -- size is validated). For true OOM prevention, use a streaming HTTP client. + -- | Maximum response body size in bytes (default: 10MB). + -- Both byte-level paths count delivered chunks before retaining them and + -- close the response on overflow. Transport buffers may hold an extra chunk; + -- this is not a fixed process-memory bound. JSON methods do not use this cap. -- Set to Nothing to disable the limit (not recommended for external APIs). + maxResponseBytes :: !(Maybe GhcInt.Int) } @@ -112,17 +113,18 @@ instance Default Request where { url = Nothing, headers = Map.empty, timeoutSeconds = Just 10, - -- ^ Default 10 second timeout for production safety. + -- \^ Default 10 second timeout for production safety. -- Prevents indefinite hangs under load. Override with withTimeout if needed. maxRedirects = 0, - -- ^ SECURITY: Default 0 redirects to prevent SSRF bypass. + -- \^ SECURITY: Default 0 redirects to prevent SSRF bypass. -- Attackers can redirect validated URLs to internal IPs (169.254.169.254). -- Use withRedirects to explicitly opt-in when needed. maxResponseBytes = Just (10 * 1024 * 1024) - -- ^ Default 10MB limit to prevent OOM from malicious servers. } +-- \^ Default 10MB limit to prevent OOM from malicious servers. + -- | An empty request: no URL, no headers, default timeout and limits. request :: Request request = def @@ -155,11 +157,11 @@ addHeader :: Text -> Text -> Request -> Request addHeader key value options = let newHeaders = options.headers |> Map.set key value in Request - { url = options.url - , headers = newHeaders - , timeoutSeconds = options.timeoutSeconds - , maxRedirects = options.maxRedirects - , maxResponseBytes = options.maxResponseBytes + { url = options.url, + headers = newHeaders, + timeoutSeconds = options.timeoutSeconds, + maxRedirects = options.maxRedirects, + maxResponseBytes = options.maxResponseBytes } @@ -181,7 +183,9 @@ withRedirects count options = -- | Set the maximum response body size in bytes. -- Default is 10MB. Use this to override for specific endpoints. {-# INLINE withMaxResponseSize #-} --- | Cap the response body in bytes; larger bodies fail with a size error. + + +-- | Cap byte-level responses while reading; JSON methods do not use this limit. withMaxResponseSize :: GhcInt.Int -> Request -> Request withMaxResponseSize maxBytes options = case maxBytes > 0 of @@ -211,13 +215,14 @@ methodName method = case method of Delete -> "DELETE" -data Error = Error Text - | InvalidUrl Text - -- ^ The URL does not use HTTPS. Use getSecure only with https:// URLs. +data Error + = Error Text + | -- | The URL does not use HTTPS. Use getSecure only with https:// URLs. -- The URL is sanitized (query params stripped) to prevent secret leakage in logs. - | ResponseTooLarge GhcInt.Int - -- ^ Response body exceeded the configured size limit. + InvalidUrl Text + | -- | Response body exceeded the configured size limit. -- The Int is the limit in bytes that was exceeded. + ResponseTooLarge GhcInt.Int deriving (Show) @@ -233,10 +238,10 @@ data Error = Error Text -- @ data Response body = Response { -- | HTTP status code (e.g., 200, 201, 404) - statusCode :: Int - , -- | Response headers as key-value pairs - headers :: Array (Text, Text) - , -- | Parsed response body + statusCode :: Int, + -- | Response headers as key-value pairs + headers :: Array (Text, Text), + -- | Parsed response body body :: body } deriving (Show, Generic) @@ -344,26 +349,33 @@ getIO options = do secureTlsSupportedVersions :: [TLS.Version] secureTlsSupportedVersions = [TLS.TLS13, TLS.TLS12] + -- | Build the TLS 1.2+ connection manager shared by every secure request. secureTlsManager :: GhcIO.IO HttpClient.Manager secureTlsManager = do - let tlsParams = - (TLS.defaultParamsClient "" "") - { TLS.clientSupported = - TLS.defaultSupported - { TLS.supportedVersions = secureTlsSupportedVersions - } + let tlsSettings = + Connection.TLSSettingsSimple + { Connection.settingDisableCertificateValidation = False, + Connection.settingDisableSession = False, + Connection.settingUseServerName = True, + Connection.settingClientSupported = + TLS.defaultSupported {TLS.supportedVersions = secureTlsSupportedVersions} } - let tlsSettings = Connection.TLSSettings tlsParams let managerSettings = HttpTls.mkManagerSettings tlsSettings Nothing - HttpClient.newManager managerSettings + HttpClient.newManager (HttpClient.managerSetProxy HttpClient.noProxy managerSettings) + {-# NOINLINE cachedSecureTlsManager #-} + + -- | The process-wide secure manager, built once. cachedSecureTlsManager :: HttpClient.Manager cachedSecureTlsManager = GhcUnsafe.unsafePerformIO secureTlsManager + {-# INLINE getSecure #-} + + -- | GET raw bytes over HTTPS only; returns the status code instead of throwing on 4xx/5xx. getSecure :: Request -> @@ -404,55 +416,33 @@ sendSecure method options body = do -- | Internal IO action for a secure byte-level request using TLS 1.2+ only. sendSecureRawIO :: Method -> Request -> Bytes -> GhcIO.IO (Result Error (Response Bytes)) sendSecureRawIO method options body = do - httpResult <- - case options.maxResponseBytes of - Nothing -> - GhcException.try @HttpClient.HttpException do - response <- sendRawIO method options body - pure (Ok response) - Just _ -> - GhcException.try @HttpClient.HttpException do - baseReq <- parseRequestUrl options - let req = baseReq - |> applyRequestOptions options - |> applyMethodAndBody method body - |> setRequestIgnoreStatus - rawResponse <- HttpClient.responseOpen req cachedSecureTlsManager - -- A HEAD response announces the body it does NOT send; only the - -- post-read check applies to it. - let declaredLimit = case method of - Head -> Nothing - _ -> checkContentLengthHeaderLimit options.maxResponseBytes (HttpClient.responseHeaders rawResponse) - case declaredLimit of - Just maxBytes -> do - HttpClient.responseClose rawResponse - pure (Err (ResponseTooLarge maxBytes)) - Nothing -> do - responseBody <- - GhcException.finally - (readBodyFully (HttpClient.responseBody rawResponse)) - (HttpClient.responseClose rawResponse) - pure (Ok (extractResponseBytesFromOpenResponse rawResponse responseBody)) + httpResult <- GhcException.try @HttpClient.HttpException do + baseReq <- parseRequestUrl options + let req = + baseReq + |> applyRequestOptions options + |> applyMethodAndBody method body + |> setRequestIgnoreStatus + GhcException.bracket + (HttpClient.responseOpen req cachedSecureTlsManager) + HttpClient.responseClose + (readLimitedResponse method options) case httpResult of GhcEither.Left httpException -> pure (Err (sanitizeHttpError httpException)) GhcEither.Right responseResult -> pure responseResult --- | Internal IO action for an unbounded secure byte-level request using TLS 1.2+ only. -sendRawIO :: - Method -> - Request -> - Bytes -> - GhcIO.IO (Response Bytes) -sendRawIO method options body = do - baseReq <- parseRequestUrl options - let req = baseReq - |> applyRequestOptions options - |> applyMethodAndBody method body - |> setRequestIgnoreStatus - |> HttpSimple.setRequestManager cachedSecureTlsManager - httpResponse <- HttpSimple.httpBS req - pure (extractResponseBytes httpResponse) +readLimitedResponse :: + Method -> Request -> HttpClient.Response HttpClient.BodyReader -> GhcIO.IO (Result Error (Response Bytes)) +readLimitedResponse method options rawResponse = do + let declaredLimit = case method of + Head -> Nothing + _ -> checkContentLengthHeaderLimit options.maxResponseBytes (HttpClient.responseHeaders rawResponse) + case declaredLimit of + Just maxBytes -> pure (Err (ResponseTooLarge maxBytes)) + Nothing -> do + bodyResult <- readBodyFully options.maxResponseBytes (HttpClient.responseBody rawResponse) + pure (bodyResult |> fmap (extractResponseBytesFromOpenResponse rawResponse)) -- | Set the wire method and the raw request body. Shared with 'Http.Client.Internal'. @@ -463,23 +453,27 @@ applyMethodAndBody method body req = |> HttpSimple.setRequestBodyLBS (Bytes.toLazyLegacy body) --- | Read the whole body reader into memory, honouring the size limit. -readBodyFully :: HttpClient.BodyReader -> GhcIO.IO ByteString -readBodyFully reader = readBodyChunks reader GhcBSChar.empty +-- | Stop before retaining a chunk that would exceed the response limit. +readBodyFully :: Maybe GhcInt.Int -> HttpClient.BodyReader -> GhcIO.IO (Result Error ByteString) +readBodyFully limit reader = readBodyChunks limit reader 0 [] --- | Accumulate body chunks until EOF or the size limit. -readBodyChunks :: HttpClient.BodyReader -> ByteString -> GhcIO.IO ByteString -readBodyChunks reader accumulatedBody = do +readBodyChunks :: + Maybe GhcInt.Int -> HttpClient.BodyReader -> GhcInt.Int -> [ByteString] -> GhcIO.IO (Result Error ByteString) +readBodyChunks limit reader received chunks = do chunk <- HttpClient.brRead reader - case chunk == GhcBSChar.empty of - True -> pure accumulatedBody - False -> do - let nextBody = GhcBSChar.append accumulatedBody chunk - readBodyChunks reader nextBody + if GhcBSChar.null chunk + then pure (Ok (GhcBSChar.concat (LinkedList.reverse chunks))) + else do + let chunkBytes = GhcBSChar.length chunk + case limit of + Just maxBytes | chunkBytes > maxBytes - received -> pure (Err (ResponseTooLarge maxBytes)) + _ -> readBodyChunks limit reader (received + chunkBytes) (chunk : chunks) -- | Reject early when @Content-Length@ already exceeds the limit. +-- This advertised-size shortcut precedes the delivered/decompressed chunk count; +-- HEAD bypasses it because its advertised body is not sent. checkContentLengthHeaderLimit :: Maybe GhcInt.Int -> [(CI.CI ByteString, ByteString)] -> Maybe GhcInt.Int checkContentLengthHeaderLimit maxResponseLimit responseHeaders = case maxResponseLimit of @@ -521,11 +515,12 @@ findHeaderValue headerName headers = -- | Drain an open response into bytes under the size limit. extractResponseBytesFromOpenResponse :: HttpClient.Response HttpClient.BodyReader -> ByteString -> Response Bytes -extractResponseBytesFromOpenResponse rawResponse responseBody = Response - { statusCode = rawResponse |> HttpClient.responseStatus |> HttpStatus.statusCode - , headers = rawResponse |> HttpClient.responseHeaders |> extractRawHeaders - , body = responseBody |> Bytes.fromLegacy - } +extractResponseBytesFromOpenResponse rawResponse responseBody = + Response + { statusCode = rawResponse |> HttpClient.responseStatus |> HttpStatus.statusCode, + headers = rawResponse |> HttpClient.responseHeaders |> extractRawHeaders, + body = responseBody |> Bytes.fromLegacy + } -- | Convert wire headers to @(name, value)@ text pairs. @@ -533,10 +528,11 @@ extractRawHeaders :: [(CI.CI ByteString, ByteString)] -> Array (Text, Text) extractRawHeaders rawHeaders = rawHeaders |> fmap - (\(name, value) -> - ( name |> CI.original |> Bytes.fromLegacy |> Text.fromBytes - , value |> Bytes.fromLegacy |> Text.fromBytes - )) + ( \(name, value) -> + ( name |> CI.original |> Bytes.fromLegacy |> Text.fromBytes, + value |> Bytes.fromLegacy |> Text.fromBytes + ) + ) |> Array.fromLinkedList @@ -552,15 +548,6 @@ checkResponseSize options response = False -> Task.yield response --- | Extract Response with Bytes body from http-client Response -extractResponseBytes :: HttpSimple.Response ByteString -> Response Bytes -extractResponseBytes httpResponse = Response - { statusCode = HttpSimple.getResponseStatusCode httpResponse - , headers = extractHeaders httpResponse - , body = Bytes.fromLegacy (HttpSimple.getResponseBody httpResponse) - } - - -- | Performs a POST request with JSON body. post :: (Json.FromJSON response, Json.ToJSON requestBody) => @@ -655,8 +642,10 @@ postRaw :: forall response. (Json.FromJSON response) => Request -> - Text -> -- ^ Content-Type - Text -> -- ^ Body content + -- | Content-Type + Text -> + -- | Body content + Text -> Task Error (Response response) postRaw options contentType bodyContent = do let host = requestHost options @@ -809,21 +798,24 @@ extractResponse :: forall body. HttpSimple.Response body -> Response body -extractResponse httpResponse = Response - { statusCode = HttpSimple.getResponseStatusCode httpResponse - , headers = extractHeaders httpResponse - , body = HttpSimple.getResponseBody httpResponse - } +extractResponse httpResponse = + Response + { statusCode = HttpSimple.getResponseStatusCode httpResponse, + headers = extractHeaders httpResponse, + body = HttpSimple.getResponseBody httpResponse + } -- | Extract headers from HTTP response as Array of (Text, Text). extractHeaders :: HttpSimple.Response body -> Array (Text, Text) extractHeaders httpResponse = HttpSimple.getResponseHeaders httpResponse - |> fmap (\(name, value) -> - ( name |> CI.original |> Bytes.fromLegacy |> Text.fromBytes - , value |> Bytes.fromLegacy |> Text.fromBytes - )) + |> fmap + ( \(name, value) -> + ( name |> CI.original |> Bytes.fromLegacy |> Text.fromBytes, + value |> Bytes.fromLegacy |> Text.fromBytes + ) + ) |> Array.fromLinkedList @@ -842,8 +834,11 @@ applyRequestOptions :: Request -> HttpClient.Request -> HttpClient.Request applyRequestOptions options baseReq = do let withHeaders = options.headers - |> Map.reduce baseReq (\key value acc -> - HttpSimple.addRequestHeader (Text.convert key) (Text.convert value) acc) + |> Map.reduce + baseReq + ( \key value acc -> + HttpSimple.addRequestHeader (Text.convert key) (Text.convert value) acc + ) let withTimeout = case options.timeoutSeconds of Nothing -> withHeaders Just seconds -> do diff --git a/core/http/Http/Client/Internal.hs b/core/http/Http/Client/Internal.hs index e002a7a2c..870a7777b 100644 --- a/core/http/Http/Client/Internal.hs +++ b/core/http/Http/Client/Internal.hs @@ -1,30 +1,36 @@ -module Http.Client.Internal - ( -- * Internal HTTP access - -- | WARNING: Does NOT enforce HTTPS. Use 'Http.Client.getSecure' for external APIs. - -- This module is for internal use only (e.g., localhost OAuth2 discovery per ADR-0018). - getRaw, - sendRaw, - ) -where +module Http.Client.Internal ( + -- * Internal HTTP access + + -- | WARNING: Does NOT enforce HTTPS. Use 'Http.Client.getSecure' for external APIs. + -- This module is for internal use only (e.g., localhost OAuth2 discovery per ADR-0018). + getRaw, + sendRaw, +) where import Array (Array) import Array qualified import Basics import Bytes (Bytes) import Bytes qualified +import Control.Exception qualified as GhcException import Data.ByteString (ByteString) +import Data.ByteString qualified as GhcBS import Data.CaseInsensitive qualified as CI import Data.Either qualified as GhcEither import Http.Client (Method, Request (..), Response (..)) import Http.Client qualified as Http +import LinkedList qualified import Log qualified import Map qualified import Maybe (Maybe (..)) import Maybe qualified import Network.HTTP.Client qualified as HttpClient -import Network.HTTP.Simple qualified as HttpSimple +import Network.HTTP.Client.TLS qualified as HttpTls import Network.HTTP.Simple (setRequestIgnoreStatus) +import Network.HTTP.Simple qualified as HttpSimple +import Result (Result (..)) import System.IO qualified as GhcIO +import System.IO.Unsafe qualified as GhcUnsafe import Task (Task) import Task qualified import Text (Text) @@ -59,23 +65,23 @@ sendRaw :: sendRaw method options body = do let verb = Http.methodName method Log.debug [fmt|HTTP #{verb} (raw/internal)|] |> Task.ignoreError - response <- sendRawInternalIO method options body - |> Task.fromFailableIO @HttpClient.HttpException - |> Task.mapError sanitizeInternalHttpError - case options.maxResponseBytes of - Nothing -> Task.yield response - Just maxBytes -> - case response.body |> Bytes.length |> (\len -> len > maxBytes) of - True -> Task.throw (Http.ResponseTooLarge maxBytes) - False -> Task.yield response - - --- | Internal IO action for a raw byte-level request -sendRawInternalIO :: - Method -> - Http.Request -> - Bytes -> - GhcIO.IO (Http.Response Bytes) + result <- + sendRawInternalIO method options body + |> Task.fromFailableIO @HttpClient.HttpException + |> Task.mapError sanitizeInternalHttpError + case result of + Err error -> Task.throw error + Ok response -> Task.yield response + + +{-# NOINLINE rawManager #-} +rawManager :: HttpClient.Manager +rawManager = GhcUnsafe.unsafePerformIO do + HttpClient.newManager (HttpClient.managerSetProxy HttpClient.noProxy HttpTls.tlsManagerSettings) + + +-- | Own the response until its bounded body has been read or rejected. +sendRawInternalIO :: Method -> Http.Request -> Bytes -> GhcIO.IO (Result Http.Error (Http.Response Bytes)) sendRawInternalIO method options body = do baseReq <- parseRequestUrl options let req = @@ -83,8 +89,39 @@ sendRawInternalIO method options body = do |> applyRequestOptions options |> Http.applyMethodAndBody method body |> setRequestIgnoreStatus - httpResponse <- HttpSimple.httpBS req - pure (extractResponseBytes httpResponse) + GhcException.bracket + (HttpClient.responseOpen req rawManager) + HttpClient.responseClose + (readLimitedResponse method options) + + +readLimitedResponse :: + Method -> + Http.Request -> + HttpClient.Response HttpClient.BodyReader -> + GhcIO.IO (Result Http.Error (Http.Response Bytes)) +readLimitedResponse method options response = do + let declaredLimit = case method of + Http.Head -> Nothing + _ -> Http.checkContentLengthHeaderLimit options.maxResponseBytes (HttpClient.responseHeaders response) + case declaredLimit of + Just maxBytes -> pure (Err (Http.ResponseTooLarge maxBytes)) + Nothing -> do + bodyResult <- readBodyChunks options.maxResponseBytes (HttpClient.responseBody response) 0 [] + pure (bodyResult |> fmap (\body -> extractResponseBytes (response {HttpClient.responseBody = body}))) + + +-- Kept private here to avoid widening the public Http.Client API for plumbing. +readBodyChunks :: Maybe Int -> HttpClient.BodyReader -> Int -> [ByteString] -> GhcIO.IO (Result Http.Error ByteString) +readBodyChunks limit reader received chunks = do + chunk <- HttpClient.brRead reader + if GhcBS.null chunk + then pure (Ok (GhcBS.concat (LinkedList.reverse chunks))) + else do + let chunkBytes = GhcBS.length chunk + case limit of + Just maxBytes | chunkBytes > maxBytes - received -> pure (Err (Http.ResponseTooLarge maxBytes)) + _ -> readBodyChunks limit reader (received + chunkBytes) (chunk : chunks) -- | Parse the URL from request options into an http-client Request. @@ -100,8 +137,11 @@ applyRequestOptions :: Http.Request -> HttpClient.Request -> HttpClient.Request applyRequestOptions options baseReq = do let withHeaders = options.headers - |> Map.reduce baseReq (\key value acc -> - HttpSimple.addRequestHeader (Text.convert key) (Text.convert value) acc) + |> Map.reduce + baseReq + ( \key value acc -> + HttpSimple.addRequestHeader (Text.convert key) (Text.convert value) acc + ) let withTimeout = case options.timeoutSeconds of Nothing -> withHeaders Just seconds -> do @@ -119,9 +159,9 @@ applyRequestOptions options baseReq = do extractResponseBytes :: HttpSimple.Response ByteString -> Http.Response Bytes extractResponseBytes httpResponse = Http.Response - { statusCode = HttpSimple.getResponseStatusCode httpResponse - , headers = extractHeaders httpResponse - , body = Bytes.fromLegacy (HttpSimple.getResponseBody httpResponse) + { statusCode = HttpSimple.getResponseStatusCode httpResponse, + headers = extractHeaders httpResponse, + body = Bytes.fromLegacy (HttpSimple.getResponseBody httpResponse) } @@ -129,10 +169,12 @@ extractResponseBytes httpResponse = extractHeaders :: HttpSimple.Response body -> Array (Text, Text) extractHeaders httpResponse = HttpSimple.getResponseHeaders httpResponse - |> fmap (\(name, value) -> - ( name |> CI.original |> Bytes.fromLegacy |> Text.fromBytes - , value |> Bytes.fromLegacy |> Text.fromBytes - )) + |> fmap + ( \(name, value) -> + ( name |> CI.original |> Bytes.fromLegacy |> Text.fromBytes, + value |> Bytes.fromLegacy |> Text.fromBytes + ) + ) |> Array.fromLinkedList diff --git a/core/test/Http/transport_fixture.py b/core/test/Http/transport_fixture.py index 12c6030d2..b4d7fa41d 100755 --- a/core/test/Http/transport_fixture.py +++ b/core/test/Http/transport_fixture.py @@ -7,6 +7,7 @@ """ import argparse import contextlib +import gzip import http.server import json import os @@ -89,8 +90,17 @@ def respond(self): body = b"proxy" if kind == "proxy" else b"1234" if self.path == "/empty": body = b"" + if self.path == "/over": + body = b"12345" + if self.path == "/compressed": + body = gzip.compress(b"x" * 128) self.send_response(200) - length = 10000 if self.path == "/head" else len(body) + length = 10000 if self.path in ("/head", "/advertised") else len(body) + if self.path == "/compressed": + self.send_header("Content-Encoding", "gzip") + if self.path == "/advertised": + self.send_header("Connection", "close") + self.close_connection = True self.send_header("Content-Length", str(length)) self.send_header("X-Fixture", kind) self.end_headers() @@ -249,6 +259,12 @@ def body_case(fixture, directory, secure_internal=False): exact <- raw H.Get "/exact" 4 empty <- raw H.Get "/empty" 1 headOnly <- raw H.Head "/head" 1 +oversized <- raw H.Get "/over" 4 +advertised <- raw H.Get "/advertised" 4 +decoded <- raw H.Get "/compressed" 64 +P.print ("OVER" :: P.String, case oversized of Result.Err (H.ResponseTooLarge 4) -> P.True; _ -> P.False) +P.print ("ADVERTISED" :: P.String, case advertised of Result.Err (H.ResponseTooLarge 4) -> P.True; _ -> P.False) +P.print ("DECOMPRESSED" :: P.String, case decoded of Result.Err (H.ResponseTooLarge 64) -> P.True; _ -> P.False) zeroBuilder <- E.try @E.ErrorCall (E.evaluate (H.withMaxResponseSize 0 H.request)) P.print ("ZERO_REJECTED" :: P.String, P.either (P.const P.True) (P.const P.False) zeroBuilder) P.print ("EXACT" :: P.String, case exact of Result.Ok response -> B.length response.body P.== 4; Result.Err _ -> P.False) @@ -266,7 +282,7 @@ def body_case(fixture, directory, secure_internal=False): ")) B.empty)", ")) B.empty") output = repl(directory, "secure-internal-body" if secure_internal else "body", text, clean_env()) control_output = output.split("BODY_CONTROLS_COMPLETE")[0] - assert all(f'("{name}",True)' in control_output for name in ("EXACT", "ZERO", "HEAD", "ZERO_REJECTED")), "exact/empty/HEAD/zero-builder control failed" + assert all(f'("{name}",True)' in control_output for name in ("EXACT", "ZERO", "HEAD", "ZERO_REJECTED", "OVER", "ADVERTISED", "DECOMPRESSED")), "exact/empty/HEAD/zero-builder control failed" for path in ("/paced-chunked", "/paced-close"): assert any(e["method"] == "FLUSHED" and e["path"] == path for e in fixture.events), "source never flushed" assert output.count("Just (Err (ResponseTooLarge 4))") == 2, "REGRESSION_ASSERT:body-read-awaits-EOF" diff --git a/docs/changes/016-http-client-byte-level-methods.md b/docs/changes/016-http-client-byte-level-methods.md index c6c1b4201..87dd1ccb0 100644 --- a/docs/changes/016-http-client-byte-level-methods.md +++ b/docs/changes/016-http-client-byte-level-methods.md @@ -38,12 +38,10 @@ for Core, and combine both reports for runtime-criterion validation. Missing reports must fail, not silently remove the HTTP examples. `./dev workflow-check` contains the positive and negative report-wiring controls. -Pending explicit API decision: the existing public plumbing helper +The existing public plumbing helper remains supported with its actual raw type: `applyMethodAndBody :: Method -> Bytes -> Network.HTTP.Client.Request -> -Network.HTTP.Client.Request` is omitted from the original signature promise. -The smallest non-breaking choice is to declare it accurately here; hiding it -requires a separately approved removal/breaking declaration. No decision has -been recorded, so the signatures block below is not yet amended for the helper. +Network.HTTP.Client.Request`. It is retained, not removed or redesigned. +The generated signature vocabulary abbreviates that external request type. ```diff signatures + Http.Client: data Method @@ -54,6 +52,7 @@ been recorded, so the signatures block below is not yet amended for the helper. + Http.Client: Patch :: Method + Http.Client: Delete :: Method + Http.Client: methodName :: Method -> Text ++ Http.Client: applyMethodAndBody :: Method -> Bytes -> Request -> Request + Http.Client: sendSecure :: Method -> Request -> Bytes -> Task Error (Response Bytes) + Http.Client.Internal: sendRaw :: Method -> Request -> Bytes -> Task Error (Response Bytes) ``` diff --git a/docs/changes/022-http-byte-transport-guarantees.md b/docs/changes/022-http-byte-transport-guarantees.md index bdf837572..c2f6d0c3c 100644 --- a/docs/changes/022-http-byte-transport-guarantees.md +++ b/docs/changes/022-http-byte-transport-guarantees.md @@ -1,6 +1,7 @@ # Change 022: Enforce the byte-level HTTP transport guarantees -Proposed remediation for #905, not an approved implementation. Byte-level +Approved existing-guarantee remediation for #905 (NickSeagull, +[Gate 1](https://github.com/neohaskell/NeoHaskell/pull/905#issuecomment-6150721779)). Byte-level clients must verify HTTPS peers, stop reading oversized bodies before EOF, and bypass environment proxies. Existing JSON APIs are outside this change. @@ -17,9 +18,9 @@ new-extension-point: false ## Contract delta No new public HTTP type or method. Preserve the signatures and default values -of `sendSecure`, `getSecure`, `sendRaw` and `getRaw`. The helper export decision -is recorded in Change 016 and requires explicit maintainer choice; this draft -does not authorize removing it. Existing timeout semantics remain response +of `sendSecure`, `getSecure`, `sendRaw` and `getRaw`. The existing helper export +is retained and accurately declared in Change 016; no public API removal or +redesign is part of this repair. Existing timeout semantics remain response inactivity timeout, not a total-body deadline. Limits apply to byte-level responses, not every JSON request. @@ -47,7 +48,7 @@ red identity. Formal red evidence requires the exact assertion below. | C4 | Preserve combined Core/service report wiring and its missing-report controls | `script:scripts/workflow-check#--self-test` | unit | none | | C5 | Test-manager trusted TLS succeeds, untrusted CA/wrong hostname fail, public untrusted TLS fails (not public trusted success) | `script:core/test/Http/transport_fixture.py#tls` | integration | http:real | | C6 | Fresh-process lower/uppercase env proxy traps work, actual raw request reaches origin and actual secure CONNECT avoids trap | `script:core/test/Http/transport_fixture.py#proxy` | integration | http:real | -| C7 | Raw exact/empty/HEAD and existing zero-builder rejection controls pass; chunked and unknown-length reads reject before EOF | `script:core/test/Http/transport_fixture.py#body` | integration | http:real | +| C7 | Raw exact/empty/HEAD, finite overflow, advertised/decompressed size and existing zero-builder rejection controls pass; chunked/unknown-length reads reject before EOF and close | `script:core/test/Http/transport_fixture.py#body` | integration | http:real | | C8 | On a supported Unix trust loader, the real public HTTPS manager accepts an isolated system bundle after a library positive control | `script:core/test/Http/transport_fixture.py#public-trust` | integration | http:real | | C9 | The internal secure reader rejects chunked/unknown-length bodies before EOF and closes the actual socket (plaintext diagnostic, not public TLS) | `script:core/test/Http/transport_fixture.py#secure-internal-body` | integration | http:real | @@ -72,8 +73,8 @@ production test seam. C5 deliberately injects trust only into a test manager; it does not prove public trusted success. C6 isolates traversal while secure origin success is still blocked by trust. C7 covers raw reads only. -This bounded draft is NOT final Gate 1-ready. The following remaining promises -must become real tests and typed criteria before formal approval; +Gate 1 authorizes repair of existing guarantees, not readiness or merge. The +following remaining validation promises must be proved before final review; no placeholder, skipped test, helper-only proof, or existing suite count can stand in for them. Add to `core/test/Http/ClientRawSpec.hs`, suite `nhcore-test-core`, attest `integration / http:real` in `test-surfaces.json`. @@ -142,7 +143,8 @@ Apps using byte-level HTTP should receive valid HTTPS responses, avoid proxy environment routing, and reject oversized responses without downloading the whole source. No app edits are proposed for existing intended APIs. `sendRaw` remains a trusted-caller API: loopback is guidance, not an enforced host policy. -The undocumented public helper choice remains open. No release is claimed. +The existing public helper is retained and declared without changing its +signature. No release is claimed. ## ADR From f42a5339dda131f53a23d20f597f3da8ab11eda9 Mon Sep 17 00:00:00 2001 From: stepandra Date: Wed, 14 Oct 2026 02:35:45 +0900 Subject: [PATCH 13/13] docs(http): document bounded readers and refresh API usage --- codemap/api-hot.md | 30 +++++++++++++++--------------- core/http/Http/Client.hs | 2 ++ core/http/Http/Client/Internal.hs | 2 ++ 3 files changed, 19 insertions(+), 15 deletions(-) diff --git a/codemap/api-hot.md b/codemap/api-hot.md index 9014a5601..3458e0057 100644 --- a/codemap/api-hot.md +++ b/codemap/api-hot.md @@ -10,7 +10,7 @@ codemap/signatures/ · type-directed search: ./dev api "" ## Task -- `yield :: value -> Task w value` +- `yield :: value -> Task w value` - `ignoreError :: Task err Unit -> Task w Unit` - `mapError :: (err1 -> err2) -> Task err1 value -> Task err2 value` - `throw :: err -> Task err w` @@ -117,9 +117,9 @@ codemap/signatures/ · type-directed search: ./dev api "" ## Bytes - `unwrap :: Bytes -> ByteString` -- `fromLegacy :: ByteString -> Bytes` +- `fromLegacy :: ByteString -> Bytes` - `toLazyLegacy :: Bytes -> LazyByteString` -- `length :: Bytes -> Int` +- `length :: Bytes -> Int` - `>>> [1, 2, 3] |> Bytes.pack |> Bytes.length` → `3` - `pack :: [Word8] -> Bytes` - `toBase64 :: Bytes -> Bytes` @@ -167,23 +167,12 @@ codemap/signatures/ · type-directed search: ./dev api "" - `load :: HasParser config => Task Text config` - `secret :: FieldDef -> FieldDef` -## Uuid - -- `generate :: Task w Uuid` -- `toText :: Uuid -> Text` -- `nil :: Uuid` -- `toLegacy :: Uuid -> UUID` -- `fromText :: Text -> Maybe Uuid` -- `generateV5 :: Uuid -> Text -> Uuid` - - `>>> Uuid.fromText "6ba7b810-9dad-11d1-80b4-00c04fd430c8" |> Maybe.getOrDie |> (\ns -> Uuid.generateV5 ns "python.org") |> Uuid.toText` → `"886313e1-3b8a-5372-9b90-0c9aee199e5d"` -- `fromLegacy :: UUID -> Uuid` - ## LinkedList - `map :: (a -> b) -> LinkedList a -> LinkedList b` +- `reverse :: LinkedList a -> LinkedList a` - `any :: (a -> Bool) -> LinkedList a -> Bool` - `filter :: (a -> Bool) -> LinkedList a -> LinkedList a` -- `reverse :: LinkedList a -> LinkedList a` - `length :: LinkedList a -> Int` - `find :: (a -> Bool) -> LinkedList a -> Maybe a` - `get :: Int -> LinkedList a -> Maybe a` @@ -191,6 +180,17 @@ codemap/signatures/ · type-directed search: ./dev api "" - `all :: (a -> Bool) -> LinkedList a -> Bool` - `concat :: LinkedList (LinkedList a) -> LinkedList a` +## Uuid + +- `generate :: Task w Uuid` +- `toText :: Uuid -> Text` +- `nil :: Uuid` +- `toLegacy :: Uuid -> UUID` +- `fromText :: Text -> Maybe Uuid` +- `generateV5 :: Uuid -> Text -> Uuid` + - `>>> Uuid.fromText "6ba7b810-9dad-11d1-80b4-00c04fd430c8" |> Maybe.getOrDie |> (\ns -> Uuid.generateV5 ns "python.org") |> Uuid.toText` → `"886313e1-3b8a-5372-9b90-0c9aee199e5d"` +- `fromLegacy :: UUID -> Uuid` + ## AsyncTask - `sleep :: Int -> Task w Unit` diff --git a/core/http/Http/Client.hs b/core/http/Http/Client.hs index ac520d808..463c84fc6 100644 --- a/core/http/Http/Client.hs +++ b/core/http/Http/Client.hs @@ -432,6 +432,7 @@ sendSecureRawIO method options body = do GhcEither.Right responseResult -> pure responseResult +-- | HEAD advertises an unsent body; other methods retain the early header guard. readLimitedResponse :: Method -> Request -> HttpClient.Response HttpClient.BodyReader -> GhcIO.IO (Result Error (Response Bytes)) readLimitedResponse method options rawResponse = do @@ -458,6 +459,7 @@ readBodyFully :: Maybe GhcInt.Int -> HttpClient.BodyReader -> GhcIO.IO (Result E readBodyFully limit reader = readBodyChunks limit reader 0 [] +-- | Check remaining capacity before retaining a chunk; concatenate once at EOF. readBodyChunks :: Maybe GhcInt.Int -> HttpClient.BodyReader -> GhcInt.Int -> [ByteString] -> GhcIO.IO (Result Error ByteString) readBodyChunks limit reader received chunks = do diff --git a/core/http/Http/Client/Internal.hs b/core/http/Http/Client/Internal.hs index 870a7777b..38c449236 100644 --- a/core/http/Http/Client/Internal.hs +++ b/core/http/Http/Client/Internal.hs @@ -75,6 +75,7 @@ sendRaw method options body = do {-# NOINLINE rawManager #-} +-- | Isolate direct byte requests from the library global proxy-aware manager. rawManager :: HttpClient.Manager rawManager = GhcUnsafe.unsafePerformIO do HttpClient.newManager (HttpClient.managerSetProxy HttpClient.noProxy HttpTls.tlsManagerSettings) @@ -95,6 +96,7 @@ sendRawInternalIO method options body = do (readLimitedResponse method options) +-- | HEAD bypasses advertised length; delivered chunks still obey the byte cap. readLimitedResponse :: Method -> Http.Request ->