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..c8b72c217 --- /dev/null +++ b/.changes/016-http-client-byte-level-methods.md @@ -0,0 +1,19 @@ +--- +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. + +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/.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/.github/workflows/test.yml b/.github/workflows/test.yml index 236a529fe..33651bd67 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -190,8 +190,53 @@ 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-transport: + needs: [build] + runs-on: ubuntu-latest + timeout-minutes: 45 + steps: + - uses: actions/checkout@v7.0.1 + - uses: DeterminateSystems/determinate-nix-action@v3.22.2 + with: + extra-conf: | + accept-flake-config = true + extra-substituters = https://cache.iog.io https://neohaskell.cachix.org + extra-trusted-public-keys = hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= neohaskell.cachix.org-1:mo2cLaGbwqbrxs9xhqKK8jeNsn3osi7t6XoAmxSZssc= + - uses: DeterminateSystems/magic-nix-cache-action@v14 + - uses: actions/download-artifact@v8 + with: + name: dist-newstyle + path: dist-newstyle + - name: Run byte transport fixtures + run: | + set -euo pipefail + : > transport-fixture.report + for mode in tls proxy body secure-internal-body public-trust; do + nix develop --command core/test/Http/transport_fixture.py "$mode" | tee -a transport-fixture.report + done + - uses: actions/upload-artifact@v7 + if: always() + with: + name: transport-fixture-report + path: transport-fixture.report + retention-days: 1 + if-no-files-found: error test-auth: needs: [build] @@ -234,7 +279,8 @@ jobs: run: LOG_LEVEL=Warn nix develop --command cabal test nhcore-test-integration test-service: - needs: [build] + # Both producers must finish before their evidence is consumed below. + needs: [build, test-core, test-transport] runs-on: ubuntu-latest timeout-minutes: 20 steps: @@ -277,12 +323,24 @@ 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 + - uses: actions/download-artifact@v8 + if: github.event_name == 'pull_request' + with: + name: transport-fixture-report + # Missing evidence fails `cat`; a partial report cannot pass the 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 transport-fixture.report .nhcore-test-service.report > nhcore-criteria.report + ./dev spec-check --criteria-runtime "origin/${BASE_REF}" --report nhcore-criteria.report test-hurl: needs: [build] @@ -359,7 +417,7 @@ jobs: # check, and passes cleanly when there is nothing to check. ci-gate: if: always() - needs: [changes, build, doctest, test-core, test-auth, test-integration, test-service, test-hurl, codemap-sync] + needs: [changes, build, doctest, test-core, test-transport, test-auth, test-integration, test-service, test-hurl, codemap-sync] runs-on: ubuntu-latest steps: - name: Check all tests passed @@ -387,6 +445,7 @@ jobs: "build=${{ needs.build.result }}" "doctest=${{ needs.doctest.result }}" "test-core=${{ needs.test-core.result }}" + "test-transport=${{ needs.test-transport.result }}" "test-auth=${{ needs.test-auth.result }}" "test-integration=${{ needs.test-integration.result }}" "test-service=${{ needs.test-service.result }}" 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 0f4a16cbc..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` @@ -116,17 +116,17 @@ codemap/signatures/ · type-directed search: ./dev api "" ## Bytes -- `unwrap :: Bytes -> ByteString` -- `fromLegacy :: ByteString -> Bytes` -- `toLazyLegacy :: Bytes -> LazyByteString` -- `length :: Bytes -> Int` +- `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 @@ -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` @@ -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` @@ -295,20 +295,20 @@ when WRITING TESTS; they are not feature-code frequency signal. ## Task - `mapError :: (err1 -> err2) -> Task err1 value -> Task err2 value` -- `yield :: value -> Task w value` -- `asResult :: Task err value -> Task err2 (Result err value)` +- `yield :: value -> Task w 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 69ab67c04..5b2f1e03e 100644 --- a/codemap/phrasebook.md +++ b/codemap/phrasebook.md @@ -99,6 +99,18 @@ Ok "hello" True ``` +### Crypto + +```haskell +>>> Bytes.pack [0, 15, 255] |> Crypto.toHex +"000fff" +``` + +```haskell +>>> Text.toBytes "abc" |> Crypto.sha256 |> Crypto.toHex +"ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" +``` + ### Float ```haskell @@ -270,4 +282,4 @@ True --- -*37 example sessions · modules with ZERO doctests: 315 (the documentation backlog — see codemap/.doc-ratchet)* +*39 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 f085a6499..5d15913e1 100644 --- a/codemap/signatures/nhcore-core.txt +++ b/codemap/signatures/nhcore-core.txt @@ -577,9 +577,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 @@ -726,8 +729,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 @@ -740,18 +749,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) @@ -759,6 +773,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 @@ -766,6 +781,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 6cbcf1452..463c84fc6 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. @@ -43,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) @@ -69,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) } @@ -108,21 +113,24 @@ 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 +-- | Set the request URL. withUrl :: Text -> Request -> Request withUrl url options = options @@ -144,15 +152,16 @@ 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 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 } @@ -174,6 +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 byte-level responses while reading; JSON methods do not use this limit. withMaxResponseSize :: GhcInt.Int -> Request -> Request withMaxResponseSize maxBytes options = case maxBytes > 0 of @@ -185,13 +197,32 @@ withMaxResponseSize maxBytes options = panic [fmt|withMaxResponseSize requires positive bytes, got: #{maxBytes}|] -data Error = Error Text - | InvalidUrl Text - -- ^ The URL does not use HTTPS. Use getSecure only with https:// URLs. +-- | 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 + | -- | 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) @@ -207,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) @@ -285,6 +316,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 -> @@ -317,28 +349,55 @@ 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 -> 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,72 +405,77 @@ 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 - httpResult <- - case options.maxResponseBytes of - Nothing -> - GhcException.try @HttpClient.HttpException do - response <- getRawIO options - pure (Ok response) - Just _ -> - GhcException.try @HttpClient.HttpException do - baseReq <- parseRequestUrl options - let req = baseReq - |> applyRequestOptions options - |> setRequestIgnoreStatus - rawResponse <- HttpClient.responseOpen req cachedSecureTlsManager - case checkContentLengthHeaderLimit options.maxResponseBytes (HttpClient.responseHeaders rawResponse) 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)) +-- | 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 <- 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 secure raw GET request using TLS 1.2+ only. -getRawIO :: - Request -> - GhcIO.IO (Response Bytes) -getRawIO options = do - baseReq <- parseRequestUrl options - let req = baseReq - |> applyRequestOptions options - |> setRequestIgnoreStatus - |> HttpSimple.setRequestManager cachedSecureTlsManager - httpResponse <- HttpSimple.httpBS req - pure (extractResponseBytes httpResponse) +-- | 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 + 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)) -readBodyFully :: HttpClient.BodyReader -> GhcIO.IO ByteString -readBodyFully reader = readBodyChunks reader GhcBSChar.empty +-- | 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) -readBodyChunks :: HttpClient.BodyReader -> ByteString -> GhcIO.IO ByteString -readBodyChunks reader accumulatedBody = do - chunk <- HttpClient.brRead reader - case chunk == GhcBSChar.empty of - True -> pure accumulatedBody - False -> do - let nextBody = GhcBSChar.append accumulatedBody chunk - readBodyChunks reader nextBody +-- | 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 [] +-- | 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 + chunk <- HttpClient.brRead reader + 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 @@ -429,6 +493,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 @@ -439,6 +504,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 @@ -449,22 +515,26 @@ 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 - , 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. 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 @@ -480,15 +550,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) => @@ -583,8 +644,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 @@ -737,21 +800,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 @@ -770,8 +836,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 19fa029a8..38c449236 100644 --- a/core/http/Http/Client/Internal.hs +++ b/core/http/Http/Client/Internal.hs @@ -1,29 +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, - ) -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 (Request (..), Response (..)) +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) @@ -41,31 +48,82 @@ 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 - |> 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 raw GET request -getRawInternalIO :: +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 -> - GhcIO.IO (Http.Response Bytes) -getRawInternalIO options = do + 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 + 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 #-} +-- | 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) + + +-- | 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 = baseReq |> 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) + + +-- | HEAD bypasses advertised length; delivered chunks still obey the byte cap. +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. @@ -81,8 +139,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 @@ -100,9 +161,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) } @@ -110,10 +171,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/CryptoSpec.hs b/core/test/CryptoSpec.hs index c4168d131..f4c4635a0 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/core/test/Http/ClientRawSpec.hs b/core/test/Http/ClientRawSpec.hs index 4f0dd2038..d4f8e2b62 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,166 @@ 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 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 <- + 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 +334,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/core/test/Http/transport_fixture.py b/core/test/Http/transport_fixture.py new file mode 100755 index 000000000..01e8643fc --- /dev/null +++ b/core/test/Http/transport_fixture.py @@ -0,0 +1,356 @@ +#!/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 gzip +import http.server +import json +import os +from pathlib import Path +import ssl +import socket +import sys +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) + 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": + 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 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() + 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=600) + (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") + print("fixture: Http.Client.syntheticTransport") + return result.stdout + + +COMMON = """:set -XOverloadedStrings -XTypeApplications -XOverloadedRecordDot +import Prelude qualified as P +import Control.Concurrent qualified as Conc +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.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 +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) (\\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) +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, 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) +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) +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" +Conc.threadDelay 3000000 +""" + 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", "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" + for path in ("/paced-chunked", "/paced-close"): + # 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. + # Keep GHCi alive above so process exit cannot hide a leaked response. + assert any(e["method"] == "CLOSED" and e["path"] == path and e["elapsed"] < 2.5 + for e in fixture.events), "response did not close on bounded rejection" + 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() + for name in ("SSL_CERT_FILE", "SSL_CERT_DIR", "NIX_SSL_CERT_FILE"): + env.pop(name, None) + 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", "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: + directory = args.evidence_dir.resolve() if args.evidence_dir else Path(temp) + directory.mkdir(parents=True, exist_ok=True) + fixture = Fixture(directory) + try: + 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)) + with contextlib.suppress(FileNotFoundError): + (directory / "key.pem").unlink() + + relative_path = Path(__file__).resolve().relative_to(ROOT).as_posix() + print(f"PASS script:{relative_path}#{args.mode}") + + +if __name__ == "__main__": + main() 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..87dd1ccb0 --- /dev/null +++ b/docs/changes/016-http-client-byte-level-methods.md @@ -0,0 +1,99 @@ +# 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, ci-cd, dev-pipeline] +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 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. + +The existing public plumbing helper remains supported with its actual raw type: +`applyMethodAndBody :: Method -> Bytes -> Network.HTTP.Client.Request -> +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 ++ 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: 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) +``` + +## 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` | 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` 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 | + +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 + +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`). 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..5cff89f2e --- /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` 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 + +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. 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..dbce82833 --- /dev/null +++ b/docs/changes/022-http-byte-transport-guarantees.md @@ -0,0 +1,170 @@ +# Change 022: Enforce the byte-level HTTP transport guarantees + +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. + +```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 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. + +```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 | +| 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, 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 | + +### 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. +The fixture clears `SSL_CERT_FILE`, `SSL_CERT_DIR` and `NIX_SSL_CERT_FILE` in +the child environment so only `SYSTEM_CERTIFICATE_PATH` selects its bundle. +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 +keys are deleted and listeners close in `finally`; no system trust is changed. + +Linux CI runs all five modes in `test-transport` and requires that job in +`ci-gate`. The criteria report includes its actual output alongside the Core +and service reports. Each successful mode emits one exact +`PASS script:core/test/Http/transport_fixture.py#` receipt and the printed +`Http.Client.syntheticTransport` fixture marker. Nonzero exit (including 77), +missing or duplicate receipts, wrong modes, and missing fixture markers fail +the gate. Scripts do not fabricate Hspec summaries. The local script probe +allows 1800 seconds overall and 600 seconds per native-toolchain session. +Body probes keep the client process alive for three seconds after rejection +and require socket closure before 2.5 seconds, so process exit cannot stand in +for response cleanup. The typed result also excludes closure by the two-second +read watchdog. Production timeouts are unchanged. + +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. + +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`. + +- `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 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 + 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 existing public helper is retained and declared without changing its +signature. 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 08eb0ae1f..bb6f2e635 100644 --- a/docs/changes/test-surfaces.json +++ b/docs/changes/test-surfaces.json @@ -38,6 +38,22 @@ } }, "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", + "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", @@ -213,6 +229,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" } ] } diff --git a/scripts/spec-check b/scripts/spec-check index 5a6d45ae7..0a28a6396 100755 --- a/scripts/spec-check +++ b/scripts/spec-check @@ -565,7 +565,9 @@ def unresolved_criteria_tests(spec_name, spec_text, root=ROOT, surfaces=None): return errs -def run_locator_probe(locator, timeout_seconds=120): +def run_locator_probe(locator, timeout_seconds=None): + if timeout_seconds is None: + timeout_seconds = 1800 if locator["kind"] == "script" else 120 command = locator_command(locator, ROOT) environment = os.environ.copy() environment["POSTGRES_AVAILABLE"] = "true" @@ -585,6 +587,11 @@ def runtime_probe_errors(locator, boundary_entry, runner=run_locator_probe): code, output, timed_out = runner(locator) if timed_out: return [f"runtime locator probe timed out `{locator['raw']}`"] + if locator["kind"] == "script": + errors = script_evidence_errors(locator, boundary_entry, output) + if code != 0: + errors.append(f"runtime script exited {code} `{locator['raw']}`") + return errors summaries = re.findall(r"^(\d+) examples?, (\d+) failures?$", output, re.MULTILINE) if code != 0 or len(summaries) != 1: return [f"runtime locator probe did not pass cleanly `{locator['raw']}`"] @@ -599,7 +606,21 @@ def runtime_probe_errors(locator, boundary_entry, runner=run_locator_probe): return errors +def script_evidence_errors(locator, boundary_entry, output): + """Script success is an exact locator receipt, not an invented Hspec summary.""" + selected = output.splitlines().count(f"PASS {locator['raw']}") + errors = [] + if selected != boundary_entry["expected_examples"]: + errors.append(f"runtime script emitted {selected} receipts; expected " + f"{boundary_entry['expected_examples']} `{locator['raw']}`") + if boundary_entry["fixture"] not in output: + errors.append(f"runtime script omitted fixture `{boundary_entry['fixture']}`") + return errors + + def runtime_report_errors(locator, boundary_entry, report_text): + if locator["kind"] == "script": + return script_evidence_errors(locator, boundary_entry, report_text) selected = report_text.count(locator["match"]) errors = [] if selected != boundary_entry["expected_examples"]: @@ -891,6 +912,24 @@ def self_test(): "fixture-postgres\n"): print("self-test FAIL runtime report zero-match accepted"); fails += 1 + script_locator, _ = parse_locator("script:scripts/example#tls") + script_entry = {"fixture": "fixture-transport", "expected_examples": 1} + script_output = "fixture-transport\nPASS script:scripts/example#tls\n" + for label, output, valid in ( + ("valid", script_output, True), + ("unsupported", "UNSUPPORTED: trust loader\n", False), + ("missing fixture", "PASS script:scripts/example#tls\n", False), + ("wrong mode", script_output.replace("#tls", "#proxy"), False), + ("duplicate", script_output + script_output, False), + ("substring", script_output.replace("PASS ", "not PASS "), False)): + if bool(runtime_report_errors(script_locator, script_entry, output)) == valid: + print(f"self-test FAIL script report {label}"); fails += 1 + for code in (0, 1, 77): + errors = runtime_probe_errors(script_locator, script_entry, + runner=lambda _locator, code=code: (code, script_output, False)) + if bool(errors) != (code != 0): + print(f"self-test FAIL script probe exit {code}"); fails += 1 + joins = plan_joins( VALID_FIXTURE.replace("[core-primitives]", "[auth, concurrency]"), caps) if joins["design_reviews"] != ["security", "perf"]: diff --git a/scripts/workflow-check b/scripts/workflow-check index 7d35bcd76..2006b3e30 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,84 @@ 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" +TRANSPORT_REPORT = "transport-fixture.report" +TRANSPORT_ARTIFACT = "transport-fixture-report" + + +def check_transport_report(name, text, consumer): + """Require actual Linux transport execution, its report, and gate ownership.""" + jobs = job_blocks(strip_comments(text)) + transport = jobs.get("test-transport", "") + errors = [] + runs = [step for step in _steps_of(transport) if "transport_fixture.py" in step] + modes = "tls proxy body secure-internal-body public-trust" + if not runs or "set -euo pipefail" not in runs[0] \ + or f"for mode in {modes}; do" not in runs[0] \ + or 'transport_fixture.py "$mode"' not in runs[0] \ + or f"tee -a {TRANSPORT_REPORT}" not in runs[0]: + errors.append(f"{name}: test-transport must run every mode and tee under pipefail") + if "runs-on: ubuntu-latest" not in transport: + errors.append(f"{name}: test-transport needs the supported Linux trust loader") + uploads = [step for step in _steps_of(transport) if UPLOAD_RE.search(step) + and f"name: {TRANSPORT_ARTIFACT}" in step] + if not uploads or f"path: {TRANSPORT_REPORT}" not in uploads[0] \ + or "if-no-files-found: error" not in uploads[0]: + errors.append(f"{name}: test-transport must require its report artifact") + owner = jobs.get(consumer, "") + needs = re.search(r"^ needs:\s*\[([^\]]*)\]", owner, re.M) + if not needs or "test-transport" not in [n.strip() for n in needs.group(1).split(",")]: + errors.append(f"{name}: {consumer} must need test-transport") + if not any("actions/download-artifact" in step and f"name: {TRANSPORT_ARTIFACT}" in step + for step in _steps_of(owner)): + errors.append(f"{name}: {consumer} must download {TRANSPORT_ARTIFACT}") + gate = jobs.get("ci-gate", "") + needs = re.search(r"^ needs:\s*\[([^\]]*)\]", gate, re.M) + if not needs or "test-transport" not in [n.strip() for n in needs.group(1).split(",")] \ + or "needs.test-transport.result" not in gate: + errors.append(f"{name}: ci-gate must require the transport job result") + return errors + + +def check_criteria_report(name, text): + """Contract 6: criteria consume Core, real transport, and service reports.""" + errs = check_transport_report(name, text, "test-service") + 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(TRANSPORT_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}`, `{TRANSPORT_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 +1105,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 +1759,73 @@ 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-transport:\n runs-on: ubuntu-latest\n steps:\n" + " - name: transport\n run: |\n" + " set -euo pipefail\n" + " for mode in tls proxy body secure-internal-body public-trust; do\n" + ' nix develop --command core/test/Http/transport_fixture.py "$mode"' + " | tee -a transport-fixture.report\n done\n" + " - uses: actions/upload-artifact@v7\n with:\n" + " name: transport-fixture-report\n" + " path: transport-fixture.report\n" + " if-no-files-found: error\n" + " test-service:\n needs: [build, test-core, test-transport]\n steps:\n" + " - uses: actions/download-artifact@v8\n with:\n" + " name: nhcore-test-core-report\n" + " - uses: actions/download-artifact@v8\n with:\n" + " name: transport-fixture-report\n" + " - name: gate\n run: |\n set -euo pipefail\n" + " cat nhcore-test-core.report transport-fixture.report .nhcore-test-service.report > all.report\n" + " ./dev spec-check --criteria-runtime base --report all.report\n" + " ci-gate:\n needs: [test-core, test-transport, test-service]\n steps:\n" + " - run: echo '${{ needs.test-transport.result }}'\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, test-transport]", "needs: [build, test-transport]")) + 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")) + cr_bad("transport report omitted from the concatenation is flagged", + good_report.replace("transport-fixture.report .nhcore", ".nhcore")) + cr_bad("transport execution without pipefail is flagged", + good_report.replace(" set -euo pipefail\n", "", 1)) + cr_bad("transport upload tolerating a missing report is flagged", + good_report.replace("path: transport-fixture.report\n if-no-files-found: error", + "path: transport-fixture.report\n if-no-files-found: warn")) + cr_bad("transport mode missing from actual execution is flagged", + good_report.replace("body secure-internal-body public-trust;", "body public-trust;")) + cr_bad("transport result missing from ci-gate is flagged", + good_report.replace("needs.test-transport.result", "needs.test-core.result")) print("workflow-check: self-test", "OK" if ok else "FAILED") return 0 if ok else 1