http-tower-hs (empty) → 0.1.0.0

raw patch · 37 files changed

+2958/−0 lines, 37 filesdep +QuickCheckdep +aesondep +async

Dependencies added: QuickCheck, aeson, async, base, bytestring, containers, crypton-connection, crypton-x509-store, crypton-x509-system, directory, hs-opentelemetry-api, hs-opentelemetry-exporter-in-memory, hs-opentelemetry-exporter-otlp, hs-opentelemetry-sdk, hspec, hspec-discover, http-client, http-client-tls, http-conduit, http-tower-hs, http-types, process, safe-exceptions, stm, testcontainers, text, time, tls, unagi-chan, unordered-containers, uuid, vector

Files

• CHANGELOG.md +5/−0
• LICENSE +21/−0
• README.md +248/−0
• http-tower-hs.cabal +128/−0
• src/Network/HTTP/Tower.hs +112/−0
• src/Network/HTTP/Tower/Client.hs +165/−0
• src/Network/HTTP/Tower/Core.hs +55/−0
• src/Network/HTTP/Tower/Error.hs +40/−0
• src/Network/HTTP/Tower/Middleware/CircuitBreaker.hs +134/−0
• src/Network/HTTP/Tower/Middleware/Filter.hs +42/−0
• src/Network/HTTP/Tower/Middleware/FollowRedirect.hs +54/−0
• src/Network/HTTP/Tower/Middleware/Hedge.hs +39/−0
• src/Network/HTTP/Tower/Middleware/Logging.hs +55/−0
• src/Network/HTTP/Tower/Middleware/RequestId.hs +38/−0
• src/Network/HTTP/Tower/Middleware/Retry.hs +85/−0
• src/Network/HTTP/Tower/Middleware/SetHeader.hs +45/−0
• src/Network/HTTP/Tower/Middleware/TestDouble.hs +69/−0
• src/Network/HTTP/Tower/Middleware/Timeout.hs +29/−0
• src/Network/HTTP/Tower/Middleware/Tracing.hs +101/−0
• src/Network/HTTP/Tower/Middleware/Validate.hs +73/−0
• test/Network/HTTP/Tower/ClientTLSSpec.hs +134/−0
• test/Network/HTTP/Tower/CoreSpec.hs +54/−0
• test/Network/HTTP/Tower/Middleware/CircuitBreakerSpec.hs +146/−0
• test/Network/HTTP/Tower/Middleware/FilterSpec.hs +46/−0
• test/Network/HTTP/Tower/Middleware/FollowRedirectSpec.hs +89/−0
• test/Network/HTTP/Tower/Middleware/HedgeSpec.hs +57/−0
• test/Network/HTTP/Tower/Middleware/LoggingSpec.hs +65/−0
• test/Network/HTTP/Tower/Middleware/RequestIdSpec.hs +46/−0
• test/Network/HTTP/Tower/Middleware/RetrySpec.hs +91/−0
• test/Network/HTTP/Tower/Middleware/SetHeaderSpec.hs +54/−0
• test/Network/HTTP/Tower/Middleware/TestDoubleSpec.hs +97/−0
• test/Network/HTTP/Tower/Middleware/TimeoutSpec.hs +42/−0
• test/Network/HTTP/Tower/Middleware/TracingDockerSpec.hs +131/−0
• test/Network/HTTP/Tower/Middleware/TracingIntegrationSpec.hs +148/−0
• test/Network/HTTP/Tower/Middleware/TracingSpec.hs +118/−0
• test/Network/HTTP/Tower/Middleware/ValidateSpec.hs +101/−0
• test/Spec.hs +1/−0

@@ -0,0 +1,5 @@+# Changelog++## 0.1.0.0 — 2026-04-05++Initial release of http-tower-hs, a composable HTTP client middleware library for Haskell inspired by Tower (Rust).

@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2026 Jarl André Hübenthal++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.

@@ -0,0 +1,248 @@+# http-tower-hs++Composable HTTP client middleware for Haskell, inspired by Rust's [Tower](https://docs.rs/tower/latest/tower/).++The Haskell ecosystem has solid HTTP clients (`http-client`, `http-client-tls`) but no middleware composition story. Every project ends up hand-rolling retry logic, timeout handling, and logging around raw HTTP calls. `http-tower-hs` fixes this with a simple `Service`/`Middleware` abstraction.++## Quick start++```haskell+import Network.HTTP.Tower+import qualified Network.HTTP.Client as HTTP++main :: IO ()+main = do+  client <- newClient+  let configured = client+        |> withBearerAuth "my-api-token"+        |> withRequestId+        |> withRetry (constantBackoff 3 1.0)+        |> withTimeout 5000+        |> withValidateStatus (\c -> c >= 200 && c < 300)+        |> withTracing++  req <- HTTP.parseRequest "https://api.example.com/v1/users"+  result <- runRequest configured req+  case result of+    Left err   -> putStrLn $ "Failed: " <> show err+    Right resp -> putStrLn $ "OK: " <> show (HTTP.responseStatus resp)+```++## Core concepts++### Service++A function from request to `IO (Either ServiceError response)`:++```haskell+newtype Service req res = Service { runService :: req -> IO (Either ServiceError res) }+```++### Middleware++A function that wraps a service to add behavior:++```haskell+type Middleware req res = Service req res -> Service req res+```++### Client++An HTTP client with a middleware stack, built using the `(|>)` operator:++```haskell+client <- newClient+let configured = client+      |> withRetry (exponentialBackoff 5 0.5 2.0)+      |> withTimeout 3000+```++### TLS / mTLS++`newClient` uses HTTPS by default. For custom CA certificates or client certificate authentication (mTLS):++```haskell+-- Custom CA (e.g., internal PKI)+client <- newClientWithTLS (Just "certs/ca.pem") Nothing++-- mTLS (client certificate authentication)+client <- newClientWithTLS+  (Just "certs/ca.pem")+  (Just ("certs/client.pem", "certs/client-key.pem"))++-- System CA store, no client cert (same as newClient)+client <- newClientWithTLS Nothing Nothing+```++For full control, use `newClientWith` with custom `ManagerSettings`.++## Middleware++### Retry++Retries failed requests with configurable backoff:++```haskell+-- Constant: 3 retries, 1 second between each+client |> withRetry (constantBackoff 3 1.0)++-- Exponential: 5 retries, starting at 500ms, doubling each time+client |> withRetry (exponentialBackoff 5 0.5 2.0)+```++### Timeout++Fails with `TimeoutError` if the request exceeds the given milliseconds:++```haskell+client |> withTimeout 5000+```++### Logging++Logs method, host, status, and duration:++```haskell+client |> withLogging (\msg -> Data.Text.IO.putStrLn msg)+```++### Circuit Breaker++Three-state circuit breaker (Closed → Open → HalfOpen) using STM:++```haskell+breaker <- newCircuitBreaker+let configured = client+      |> withCircuitBreaker (CircuitBreakerConfig 5 30) breaker+```++Trips open after 5 consecutive failures, rejects immediately for 30 seconds, then probes recovery with one request.++### OpenTelemetry Tracing++Wraps each request in an OTel span with [stable HTTP semantic conventions](https://opentelemetry.io/docs/specs/semconv/http/http-spans/):++```haskell+-- Uses global TracerProvider (no-ops if unconfigured)+client |> withTracing++-- Or with a specific tracer+client |> withTracingTracer myTracer+```++Attributes: `http.request.method`, `server.address`, `server.port`, `url.full`, `http.response.status_code`, `error.type`.++### Set Header++Add headers to every request:++```haskell+client |> withBearerAuth "my-token"+client |> withUserAgent "my-app/1.0"+client |> withHeader "X-Custom" "value"+client |> withHeaders [("X-A", "1"), ("X-B", "2")]+```++### Request ID++Generate a UUID v4 correlation ID per request:++```haskell+client |> withRequestId                        -- X-Request-ID header+client |> withRequestIdHeader "X-Correlation-ID"  -- custom header name+```++### Follow Redirects++Automatically follow 3xx responses (301, 302, 303, 307, 308):++```haskell+client |> withFollowRedirects 5  -- max 5 hops+```++Respects 303 → GET method change per HTTP spec.++### Filter++Predicate-based request control:++```haskell+-- Only allow GET requests+client |> withFilter (\req -> HTTP.method req == "GET")++-- Don't retry 4xx responses (place between retry and base service)+client |> withNoRetryOn (\resp -> statusCode (responseStatus resp) < 500)+```++### Hedge++Speculative retry — if the primary request is slow, fire a second and return whichever finishes first:++```haskell+client |> withHedge 200  -- hedge after 200ms+```++Only use for idempotent requests (GET, etc.).++### Response Validation++Reject unexpected responses:++```haskell+-- Only accept 2xx+client |> withValidateStatus (\c -> c >= 200 && c < 300)++-- Require JSON+client |> withValidateContentType "application/json"++-- Require a specific header+client |> withValidateHeader "X-Request-ID"+```++### Test Doubles++Testing utilities — mock services, record requests:++```haskell+-- Replace the service entirely+let testClient = client |> withMock (\req -> pure (Right fakeResponse))++-- Route-based mocks+let mocks = Map.fromList+      [ ("api.example.com/v1/users", Right usersResponse)+      , ("api.example.com/v1/health", Right healthResponse)+      ]+let testClient = client |> withMockMap mocks++-- Record requests for assertions+recorder <- newIORef []+let testClient = client |> withRecorder recorder+_ <- runRequest testClient someRequest+recorded <- readIORef recorder+length recorded `shouldBe` 1+```++## Error handling++All errors are returned as `Either ServiceError Response` — no exceptions escape the middleware stack:++```haskell+data ServiceError+  = HttpError SomeException+  | TimeoutError+  | RetryExhausted Int ServiceError+  | CircuitBreakerOpen+  | CustomError Text+```++## Building++```bash+stack build+stack test+hlint src/ test/+```++## License++MIT

@@ -0,0 +1,128 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.38.1.+--+-- see: https://github.com/sol/hpack++name:           http-tower-hs+version:        0.1.0.0+synopsis:       Composable HTTP client middleware for Haskell, inspired by Rust's Tower+description:    http-tower-hs provides a composable middleware abstraction for HTTP clients.+                Build middleware stacks with retry, timeout, logging, and more — all with+                pure error handling via Either (no exceptions).+category:       Network+homepage:       https://github.com/jarlah/http-tower-hs#readme+bug-reports:    https://github.com/jarlah/http-tower-hs/issues+author:         Jarl André Hübenthal+maintainer:     jarlah@protonmail.com+copyright:      2026 Jarl André Hübenthal+license:        MIT+license-file:   LICENSE+build-type:     Simple+tested-with:+    GHC == 9.6.6, GHC == 9.8.4, GHC == 9.10.1+extra-source-files:+    README.md+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/jarlah/http-tower-hs++library+  exposed-modules:+      Network.HTTP.Tower+      Network.HTTP.Tower.Core+      Network.HTTP.Tower.Error+      Network.HTTP.Tower.Client+      Network.HTTP.Tower.Middleware.Retry+      Network.HTTP.Tower.Middleware.Timeout+      Network.HTTP.Tower.Middleware.Logging+      Network.HTTP.Tower.Middleware.CircuitBreaker+      Network.HTTP.Tower.Middleware.Tracing+      Network.HTTP.Tower.Middleware.SetHeader+      Network.HTTP.Tower.Middleware.RequestId+      Network.HTTP.Tower.Middleware.FollowRedirect+      Network.HTTP.Tower.Middleware.Filter+      Network.HTTP.Tower.Middleware.Hedge+      Network.HTTP.Tower.Middleware.Validate+      Network.HTTP.Tower.Middleware.TestDouble+  other-modules:+      Paths_http_tower_hs+  hs-source-dirs:+      src+  build-depends:+      async ==2.2.*+    , base >=4.14 && <5+    , bytestring >=0.11 && <0.13+    , containers >=0.6 && <0.8+    , crypton-connection ==0.4.*+    , crypton-x509-store ==1.6.*+    , crypton-x509-system ==1.6.*+    , hs-opentelemetry-api ==0.3.*+    , http-client ==0.7.*+    , http-client-tls ==0.3.*+    , http-types ==0.12.*+    , safe-exceptions ==0.1.*+    , stm ==2.5.*+    , text >=2.0 && <2.2+    , time >=1.11 && <1.15+    , tls >=2.0 && <2.2+    , unordered-containers ==0.2.*+    , uuid ==1.3.*+  default-language: Haskell2010++test-suite http-tower-hs-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Network.HTTP.Tower.ClientTLSSpec+      Network.HTTP.Tower.CoreSpec+      Network.HTTP.Tower.Middleware.CircuitBreakerSpec+      Network.HTTP.Tower.Middleware.FilterSpec+      Network.HTTP.Tower.Middleware.FollowRedirectSpec+      Network.HTTP.Tower.Middleware.HedgeSpec+      Network.HTTP.Tower.Middleware.LoggingSpec+      Network.HTTP.Tower.Middleware.RequestIdSpec+      Network.HTTP.Tower.Middleware.RetrySpec+      Network.HTTP.Tower.Middleware.SetHeaderSpec+      Network.HTTP.Tower.Middleware.TestDoubleSpec+      Network.HTTP.Tower.Middleware.TimeoutSpec+      Network.HTTP.Tower.Middleware.TracingDockerSpec+      Network.HTTP.Tower.Middleware.TracingIntegrationSpec+      Network.HTTP.Tower.Middleware.TracingSpec+      Network.HTTP.Tower.Middleware.ValidateSpec+      Paths_http_tower_hs+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-tool-depends:+      hspec-discover:hspec-discover+  build-depends:+      QuickCheck ==2.14.*+    , aeson >=2.1 && <2.3+    , async ==2.2.*+    , base >=4.14 && <5+    , bytestring >=0.11 && <0.13+    , containers >=0.6 && <0.8+    , directory ==1.3.*+    , hs-opentelemetry-api ==0.3.*+    , hs-opentelemetry-exporter-in-memory >=0.0.1 && <0.1+    , hs-opentelemetry-exporter-otlp ==0.1.*+    , hs-opentelemetry-sdk ==0.1.*+    , hspec ==2.11.*+    , hspec-discover ==2.11.*+    , http-client ==0.7.*+    , http-client-tls ==0.3.*+    , http-conduit ==2.3.*+    , http-tower-hs+    , http-types ==0.12.*+    , process ==1.6.*+    , stm ==2.5.*+    , testcontainers ==0.5.*+    , text >=2.0 && <2.2+    , time >=1.11 && <1.15+    , unagi-chan ==0.4.*+    , uuid ==1.3.*+    , vector ==0.13.*+  default-language: Haskell2010

@@ -0,0 +1,112 @@+-- |+-- Module      : Network.HTTP.Tower+-- Description : Composable HTTP client middleware for Haskell+-- License     : MIT+--+-- Inspired by Rust's <https://docs.rs/tower/latest/tower/ Tower> crate.+-- Build composable middleware stacks for HTTP clients with the @('|>')@ operator.+--+-- @+-- import Network.HTTP.Tower+-- import qualified Network.HTTP.Client as HTTP+--+-- main :: IO ()+-- main = do+--   client <- 'newClient'+--   let configured = client+--         '|>' 'withBearerAuth' \"my-token\"+--         '|>' 'withRequestId'+--         '|>' 'withRetry' ('constantBackoff' 3 1.0)+--         '|>' 'withTimeout' 5000+--         '|>' 'withValidateStatus' (\\c -> c >= 200 && c < 300)+--         '|>' 'withTracing'+--+--   req <- HTTP.parseRequest \"https://api.example.com/v1/users\"+--   result <- 'runRequest' configured req+--   case result of+--     Left err   -> putStrLn $ \"Failed: \" \<> show err+--     Right resp -> putStrLn $ \"OK: \" \<> show (HTTP.responseStatus resp)+-- @+--+-- All errors are returned as @'Either' 'ServiceError' response@ — no exceptions+-- escape the middleware stack.+module Network.HTTP.Tower+  ( -- * Core types+    Service(..)+  , Middleware+  , mapService+  , composeMiddleware+    -- * Client+  , Client(..)+  , HttpResponse+  , newClient+  , newClientWith+  , newClientWithTLS+  , runRequest+  , applyMiddleware+  , (|>)+    -- * Errors+  , ServiceError(..)+  , displayError+    -- * Middleware+    -- ** Retry+  , BackoffStrategy(..)+  , constantBackoff+  , exponentialBackoff+  , withRetry+    -- ** Timeout+  , withTimeout+    -- ** Logging+  , withLogging+  , withLoggingCustom+    -- ** Circuit Breaker+  , CircuitBreakerConfig(..)+  , CircuitBreakerState(..)+  , CircuitBreaker+  , newCircuitBreaker+  , withCircuitBreaker+  , getCircuitBreakerState+    -- ** Tracing (OpenTelemetry)+  , withTracing+  , withTracingTracer+    -- ** Set Header+  , withHeader+  , withHeaders+  , withBearerAuth+  , withUserAgent+    -- ** Request ID+  , withRequestId+  , withRequestIdHeader+    -- ** Follow Redirects+  , withFollowRedirects+    -- ** Filter+  , withFilter+  , withNoRetryOn++    -- ** Hedge+  , withHedge+    -- ** Response Validation+  , withValidateStatus+  , withValidateHeader+  , withValidateContentType+    -- ** Test Doubles+  , withMock+  , withMockMap+  , withRecorder+  ) where++import Network.HTTP.Tower.Core+import Network.HTTP.Tower.Client+import Network.HTTP.Tower.Error+import Network.HTTP.Tower.Middleware.Retry+import Network.HTTP.Tower.Middleware.Timeout+import Network.HTTP.Tower.Middleware.Logging+import Network.HTTP.Tower.Middleware.CircuitBreaker+import Network.HTTP.Tower.Middleware.Tracing+import Network.HTTP.Tower.Middleware.SetHeader+import Network.HTTP.Tower.Middleware.RequestId+import Network.HTTP.Tower.Middleware.FollowRedirect+import Network.HTTP.Tower.Middleware.Filter+import Network.HTTP.Tower.Middleware.Hedge+import Network.HTTP.Tower.Middleware.Validate+import Network.HTTP.Tower.Middleware.TestDouble

@@ -0,0 +1,165 @@+-- |+-- Module      : Network.HTTP.Tower.Client+-- Description : HTTP client with composable middleware+-- License     : MIT+--+-- Create an HTTP client and compose middleware using the @('|>')@ operator:+--+-- @+-- client <- 'newClient'+-- let configured = client+--       '|>' withRetry (constantBackoff 3 1.0)+--       '|>' withTimeout 5000+-- result <- 'runRequest' configured request+-- @+--+-- For mTLS (client certificate authentication):+--+-- @+-- client <- 'newClientWithTLS'+--   (Just \"certs\/ca.pem\")+--   (Just (\"certs\/client.pem\", \"certs\/client-key.pem\"))+-- @+module Network.HTTP.Tower.Client+  ( Client(..)+  , HttpResponse+  , newClient+  , newClientWith+  , newClientWithTLS+  , runRequest+  , applyMiddleware+  , (|>)+  ) where++import Control.Exception.Safe (tryAny)+import qualified Data.ByteString.Lazy as LBS+import qualified Data.X509.CertificateStore as X509+import qualified Network.Connection as Conn+import qualified Network.HTTP.Client as HTTP+import qualified Network.HTTP.Client.TLS as TLS+import qualified Network.TLS as TLS.Core+import qualified Network.TLS.Extra.Cipher as TLS.Cipher+import qualified System.X509 as X509System++import Network.HTTP.Tower.Core (Service(..), Middleware)+import Network.HTTP.Tower.Error (ServiceError(..))++-- | Concrete response type used by the client (lazy bytestring body).+type HttpResponse = HTTP.Response LBS.ByteString++-- | An HTTP client with a composable middleware stack.+data Client = Client+  { clientService :: Service HTTP.Request HttpResponse+    -- ^ The service with all middleware applied.+  , clientManager :: HTTP.Manager+    -- ^ The underlying connection manager.+  }++-- | Create a client with default TLS settings. HTTPS works out of the box.+newClient :: IO Client+newClient = newClientWith TLS.tlsManagerSettings++-- | Create a client with custom manager settings.+--+-- Use this with 'Network.HTTP.Client.TLS.mkManagerSettings' for advanced+-- TLS configuration, proxies, etc.+newClientWith :: HTTP.ManagerSettings -> IO Client+newClientWith settings = do+  mgr <- HTTP.newManager settings+  let baseService = Service $ \req -> do+        result <- tryAny $ HTTP.httpLbs req mgr+        pure $ case result of+          Left err   -> Left (HttpError err)+          Right resp -> Right resp+  pure Client+    { clientService = baseService+    , clientManager = mgr+    }++-- | Create a client with custom TLS certificate configuration.+--+-- Supports:+--+-- * Custom CA bundle for server certificate verification+-- * Client certificate authentication (mTLS)+-- * Both, either, or neither+--+-- @+-- -- Custom CA only (verify server against your own CA)+-- client <- 'newClientWithTLS' (Just \"certs\/ca.pem\") Nothing+--+-- -- mTLS (client cert + custom CA)+-- client <- 'newClientWithTLS'+--   (Just \"certs\/ca.pem\")+--   (Just (\"certs\/client.pem\", \"certs\/client-key.pem\"))+--+-- -- mTLS with system CA store+-- client <- 'newClientWithTLS'+--   Nothing+--   (Just (\"certs\/client.pem\", \"certs\/client-key.pem\"))+-- @+newClientWithTLS+  :: Maybe FilePath                    -- ^ Path to CA certificate (PEM). 'Nothing' uses system store.+  -> Maybe (FilePath, FilePath)        -- ^ Client cert and key paths (PEM) for mTLS. 'Nothing' for no client cert.+  -> IO Client+newClientWithTLS mCaPath mClientCert = do+  -- Load CA store+  caStore <- case mCaPath of+    Just caPath -> do+      mStore <- X509.readCertificateStore caPath+      case mStore of+        Just store -> pure store+        Nothing    -> fail $ "Failed to load CA certificate: " <> caPath+    Nothing -> X509System.getSystemCertificateStore++  -- Load client credentials+  credentials <- case mClientCert of+    Just (certPath, keyPath) -> do+      result <- TLS.Core.credentialLoadX509 certPath keyPath+      case result of+        Right cred -> pure (TLS.Core.Credentials [cred])+        Left err   -> fail $ "Failed to load client certificate: " <> err+    Nothing -> pure (TLS.Core.Credentials [])++  let defaults = TLS.Core.defaultParamsClient "" mempty+      clientParams = defaults+        { TLS.Core.clientShared = (TLS.Core.clientShared defaults)+            { TLS.Core.sharedCAStore      = caStore+            , TLS.Core.sharedCredentials  = credentials+            }+        , TLS.Core.clientSupported = (TLS.Core.clientSupported defaults)+            { TLS.Core.supportedCiphers = TLS.Cipher.ciphersuite_default+            }+        , TLS.Core.clientHooks = (TLS.Core.clientHooks defaults)+            { TLS.Core.onCertificateRequest = \_ ->+                case credentials of+                  TLS.Core.Credentials (cred:_) -> pure (Just cred)+                  _                             -> pure Nothing+            }+        }+      tlsSettings = Conn.TLSSettings clientParams+      managerSettings = TLS.mkManagerSettings tlsSettings Nothing++  newClientWith managerSettings++-- | Execute a request through the client's middleware stack.+runRequest :: Client -> HTTP.Request -> IO (Either ServiceError HttpResponse)+runRequest client = runService (clientService client)++-- | Apply a middleware to a client, wrapping its existing service.+applyMiddleware :: Middleware HTTP.Request HttpResponse -> Client -> Client+applyMiddleware mw client = client { clientService = mw (clientService client) }++-- | Operator for fluent middleware application.+--+-- @+-- client <- 'newClient'+-- let configured = client+--       '|>' withRetry (constantBackoff 3 1.0)+--       '|>' withTimeout 5000+--       '|>' withLogging putStrLn+-- @+(|>) :: Client -> Middleware HTTP.Request HttpResponse -> Client+(|>) client mw = applyMiddleware mw client++infixl 1 |>

@@ -0,0 +1,55 @@+-- |+-- Module      : Network.HTTP.Tower.Core+-- Description : Core Service and Middleware abstractions+-- License     : MIT+--+-- The fundamental building blocks for composable middleware stacks.+-- A 'Service' is a function from request to @IO (Either ServiceError response)@,+-- and 'Middleware' wraps a service to add behavior.+module Network.HTTP.Tower.Core+  ( Service(..)+  , Middleware+  , mapService+  , composeMiddleware+  ) where++import Network.HTTP.Tower.Error (ServiceError)++-- | A service transforms a request into an effectful response.+-- This is the fundamental building block — middleware wraps services.+--+-- @+-- let echoService = 'Service' $ \\req -> pure (Right req)+-- result <- 'runService' echoService "hello"+-- -- result == Right "hello"+-- @+newtype Service req res = Service+  { runService :: req -> IO (Either ServiceError res)+    -- ^ Execute the service with a request, returning either an error or a response.+  }++-- | Middleware wraps a service to add behavior (retry, timeout, logging, etc.)+--+-- A middleware is simply a function from 'Service' to 'Service':+--+-- @+-- type Middleware req res = Service req res -> Service req res+-- @+type Middleware req res = Service req res -> Service req res++-- | Transform the response of a service, leaving errors unchanged.+--+-- @+-- let svc = 'Service' $ \\_ -> pure (Right 10)+-- let doubled = 'mapService' (* 2) svc+-- result <- 'runService' doubled ()+-- -- result == Right 20+-- @+mapService :: (a -> b) -> Service req a -> Service req b+mapService f (Service run) = Service $ \req -> fmap (fmap f) (run req)++-- | Compose two middleware, applying the outer first, then the inner.+--+-- @'composeMiddleware' outer inner = outer . inner@+composeMiddleware :: Middleware req res -> Middleware req res -> Middleware req res+composeMiddleware outer inner = outer . inner

@@ -0,0 +1,40 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Network.HTTP.Tower.Error+-- Description : Error types for the middleware stack+-- License     : MIT+--+-- All middleware returns @Either 'ServiceError' response@ — no exceptions+-- escape the middleware stack.+module Network.HTTP.Tower.Error+  ( ServiceError(..)+  , displayError+  ) where++import Control.Exception (SomeException)+import Data.Text (Text, pack)++-- | Errors that can occur in a middleware stack.+--+-- All middleware returns @Either ServiceError Response@ — no exceptions escape.+data ServiceError+  = HttpError SomeException+    -- ^ An HTTP-level exception (connection refused, DNS failure, etc.)+  | TimeoutError+    -- ^ The request exceeded the configured timeout.+  | RetryExhausted Int ServiceError+    -- ^ All retries failed. Contains the number of attempts and the last error.+  | CircuitBreakerOpen+    -- ^ The circuit breaker is open — requests are being rejected.+  | CustomError Text+    -- ^ A custom error from middleware (e.g., validation failure, too many redirects).+  deriving (Show)++-- | Render a 'ServiceError' as human-readable 'Text'.+displayError :: ServiceError -> Text+displayError (HttpError e)          = pack $ "HTTP error: " <> show e+displayError TimeoutError           = "Request timed out"+displayError (RetryExhausted n err) = "Retry exhausted after " <> pack (show n) <> " attempts: " <> displayError err+displayError CircuitBreakerOpen     = "Circuit breaker is open"+displayError (CustomError t)        = t

@@ -0,0 +1,134 @@+-- |+-- Module      : Network.HTTP.Tower.Middleware.CircuitBreaker+-- Description : Three-state circuit breaker using STM+-- License     : MIT+--+-- Prevents cascading failures by tracking consecutive errors and+-- short-circuiting requests when a service is known to be down.+--+-- @+-- breaker <- 'newCircuitBreaker'+-- let config = 'CircuitBreakerConfig' { 'cbFailureThreshold' = 5, 'cbCooldownPeriod' = 30 }+-- let client' = client '|>' 'withCircuitBreaker' config breaker+-- @+--+-- == State machine+--+-- * __Closed__ — normal operation. Failures are counted. Trips to Open+--   after reaching the threshold.+-- * __Open__ — all requests rejected with 'CircuitBreakerOpen'. After the+--   cooldown period, transitions to HalfOpen.+-- * __HalfOpen__ — one probe request is allowed through. Success resets to+--   Closed; failure trips back to Open.+module Network.HTTP.Tower.Middleware.CircuitBreaker+  ( CircuitBreakerConfig(..)+  , CircuitBreakerState(..)+  , CircuitBreaker+  , newCircuitBreaker+  , withCircuitBreaker+  , getCircuitBreakerState+  ) where++import Control.Concurrent.STM+import Data.Time.Clock (UTCTime, NominalDiffTime, getCurrentTime, diffUTCTime)++import Network.HTTP.Tower.Core (Service(..), Middleware)+import Network.HTTP.Tower.Error (ServiceError(..))++-- | Configuration for the circuit breaker.+data CircuitBreakerConfig = CircuitBreakerConfig+  { cbFailureThreshold :: !Int+    -- ^ Number of consecutive failures before the breaker trips open.+  , cbCooldownPeriod   :: !NominalDiffTime+    -- ^ How long to stay open before transitioning to half-open (in seconds).+  } deriving (Show, Eq)++-- | Observable state of the circuit breaker.+data CircuitBreakerState+  = Closed      -- ^ Normal operation, requests flow through.+  | Open        -- ^ Tripped — all requests rejected immediately.+  | HalfOpen    -- ^ Testing — one request allowed through to probe recovery.+  deriving (Show, Eq)++data BreakerInternals = BreakerInternals+  { biState          :: !CircuitBreakerState+  , biFailureCount   :: !Int+  , biLastFailureAt  :: !(Maybe UTCTime)+  }++-- | Opaque handle to a circuit breaker instance.+-- Create with 'newCircuitBreaker', share across requests.+newtype CircuitBreaker = CircuitBreaker (TVar BreakerInternals)++-- | Create a new circuit breaker in the 'Closed' state.+newCircuitBreaker :: IO CircuitBreaker+newCircuitBreaker = CircuitBreaker <$> newTVarIO BreakerInternals+  { biState         = Closed+  , biFailureCount  = 0+  , biLastFailureAt = Nothing+  }++-- | Read the current state of the circuit breaker.+getCircuitBreakerState :: CircuitBreaker -> IO CircuitBreakerState+getCircuitBreakerState (CircuitBreaker var) = biState <$> readTVarIO var++-- | Circuit breaker middleware.+--+-- The 'CircuitBreaker' handle is shared across all requests — create it+-- once and reuse it:+--+-- @+-- breaker <- 'newCircuitBreaker'+-- let client' = client '|>' 'withCircuitBreaker' config breaker+-- @+withCircuitBreaker :: CircuitBreakerConfig -> CircuitBreaker -> Middleware req res+withCircuitBreaker config (CircuitBreaker var) inner = Service $ \req -> do+  now <- getCurrentTime+  decision <- atomically $ do+    internals <- readTVar var+    case biState internals of+      Open ->+        case biLastFailureAt internals of+          Just lastFail+            | diffUTCTime now lastFail >= cbCooldownPeriod config -> do+                writeTVar var internals { biState = HalfOpen }+                pure AllowRequest+          _ -> pure RejectRequest+      HalfOpen -> pure AllowRequest+      Closed   -> pure AllowRequest++  case decision of+    RejectRequest -> pure (Left CircuitBreakerOpen)+    AllowRequest  -> do+      result <- runService inner req+      now' <- getCurrentTime+      atomically $ do+        internals <- readTVar var+        case result of+          Right _ -> writeTVar var BreakerInternals+            { biState         = Closed+            , biFailureCount  = 0+            , biLastFailureAt = Nothing+            }+          Left _ ->+            case biState internals of+              HalfOpen -> writeTVar var BreakerInternals+                { biState         = Open+                , biFailureCount  = cbFailureThreshold config+                , biLastFailureAt = Just now'+                }+              _ -> do+                let newCount = biFailureCount internals + 1+                if newCount >= cbFailureThreshold config+                  then writeTVar var BreakerInternals+                    { biState         = Open+                    , biFailureCount  = newCount+                    , biLastFailureAt = Just now'+                    }+                  else writeTVar var internals+                    { biFailureCount  = newCount+                    , biLastFailureAt = Just now'+                    }+      pure result++data Decision = AllowRequest | RejectRequest

@@ -0,0 +1,42 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Network.HTTP.Tower.Middleware.Filter+-- Description : Predicate-based request and response filtering+-- License     : MIT+--+-- @+-- -- Only allow GET requests+-- client '|>' 'withFilter' (\\req -> HTTP.method req == \"GET\")+--+-- -- Don't retry 4xx responses+-- client '|>' 'withNoRetryOn' (\\resp -> statusCode (responseStatus resp) < 500)+-- @+module Network.HTTP.Tower.Middleware.Filter+  ( withFilter+  , withNoRetryOn+  ) where++import Network.HTTP.Tower.Core (Service(..), Middleware)+import Network.HTTP.Tower.Error (ServiceError(..))++-- | Only pass requests through that match a predicate.+-- Requests that don't match are rejected with @'CustomError' \"Request filtered out\"@.+withFilter :: (req -> Bool) -> Middleware req res+withFilter predicate inner = Service $ \req ->+  if predicate req+    then runService inner req+    else pure (Left (CustomError "Request filtered out"))++-- | Don't retry responses that match a predicate.+-- Pass-through middleware — place between retry and the base service.+--+-- Responses matching the predicate are returned as-is (success), so+-- the retry middleware above won't retry them.+withNoRetryOn :: (res -> Bool) -> Middleware req res+withNoRetryOn shouldNotRetry inner = Service $ \req -> do+  result <- runService inner req+  case result of+    Right resp+      | shouldNotRetry resp -> pure (Right resp)+    _ -> pure result

@@ -0,0 +1,54 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Network.HTTP.Tower.Middleware.FollowRedirect+-- Description : Automatic HTTP redirect following+-- License     : MIT+--+-- Follows 3xx redirects by reading the @Location@ header, up to a+-- configurable maximum number of hops.+--+-- @+-- client '|>' 'withFollowRedirects' 5  -- max 5 hops+-- @+--+-- Handles 301, 302, 303, 307, and 308. On 303, the method is changed+-- to GET per the HTTP spec.+module Network.HTTP.Tower.Middleware.FollowRedirect+  ( withFollowRedirects+  ) where++import Data.ByteString.Char8 (unpack)+import qualified Network.HTTP.Client as HTTP+import qualified Network.HTTP.Types.Status as HTTP++import Network.HTTP.Tower.Client (HttpResponse)+import Network.HTTP.Tower.Core (Service(..), Middleware)+import Network.HTTP.Tower.Error (ServiceError(..))++-- | Follow HTTP 3xx redirects up to a maximum number of hops.+--+-- Returns @'CustomError' \"Too many redirects\"@ if the limit is exceeded.+withFollowRedirects :: Int -> Middleware HTTP.Request HttpResponse+withFollowRedirects maxRedirects inner = Service $ \req ->+  go req 0+  where+    go req hops+      | hops >= maxRedirects = pure (Left (CustomError "Too many redirects"))+      | otherwise = do+          result <- runService inner req+          case result of+            Left err -> pure (Left err)+            Right resp+              | isRedirect (HTTP.responseStatus resp) ->+                  case lookup "Location" (HTTP.responseHeaders resp) of+                    Nothing -> pure (Right resp)+                    Just loc -> do+                      newReq <- HTTP.parseRequest (unpack loc)+                      let req' = if HTTP.statusCode (HTTP.responseStatus resp) == 303+                            then newReq { HTTP.method = "GET", HTTP.requestBody = "" }+                            else newReq { HTTP.method = HTTP.method req }+                      go req' (hops + 1)+              | otherwise -> pure (Right resp)++    isRedirect s = HTTP.statusCode s `elem` [301, 302, 303, 307, 308]

@@ -0,0 +1,39 @@+{-# LANGUAGE NumericUnderscores #-}++-- |+-- Module      : Network.HTTP.Tower.Middleware.Hedge+-- Description : Speculative retry via async race+-- License     : MIT+--+-- If the primary request is slow, fire a second speculative request after+-- a delay and return whichever finishes first.+--+-- @+-- client '|>' 'withHedge' 200  -- hedge after 200ms+-- @+--+-- __Only use for idempotent requests__ (GET, etc.) since the request may+-- be sent twice.+module Network.HTTP.Tower.Middleware.Hedge+  ( withHedge+  ) where++import Control.Concurrent (threadDelay)+import Control.Concurrent.Async (race)++import Network.HTTP.Tower.Core (Service(..), Middleware)+import Network.HTTP.Tower.Error (ServiceError)++-- | Hedging middleware: if the primary request doesn't complete within+-- @delayMs@ milliseconds, fire a second request and return whichever+-- finishes first.+withHedge :: Int -> Middleware req res+withHedge delayMs inner = Service $ \req -> do+  let primary = runService inner req+      hedged = do+        threadDelay (delayMs * 1_000)+        runService inner req+  result <- race primary hedged+  pure $ case result of+    Left res  -> res+    Right res -> res

@@ -0,0 +1,55 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Network.HTTP.Tower.Middleware.Logging+-- Description : Request/response logging middleware+-- License     : MIT+--+-- Logs HTTP method, host, status code, and duration for each request.+--+-- @+-- client '|>' 'withLogging' (\\msg -> Data.Text.IO.putStrLn msg)+-- @+module Network.HTTP.Tower.Middleware.Logging+  ( withLogging+  , withLoggingCustom+  ) where++import Data.Text (Text, pack)+import Data.Time.Clock (getCurrentTime, diffUTCTime)+import qualified Network.HTTP.Client as HTTP+import qualified Network.HTTP.Types.Status as HTTP++import Network.HTTP.Tower.Client (HttpResponse)+import Network.HTTP.Tower.Core (Service(..), Middleware)+import Network.HTTP.Tower.Error (ServiceError, displayError)++-- | Logging middleware using a simple @Text -> IO ()@ logger.+-- Logs method, URL, status code, and duration for each request.+withLogging :: (Text -> IO ()) -> Middleware HTTP.Request HttpResponse+withLogging = withLoggingCustom formatDefault++-- | Logging middleware with a custom formatter.+--+-- The formatter receives the request, the result, and the duration in seconds.+withLoggingCustom+  :: (HTTP.Request -> Either ServiceError HttpResponse -> Double -> Text)+  -> (Text -> IO ())+  -> Middleware HTTP.Request HttpResponse+withLoggingCustom formatter logger inner = Service $ \req -> do+  start <- getCurrentTime+  result <- runService inner req+  end <- getCurrentTime+  let durationSec = realToFrac (diffUTCTime end start) :: Double+  logger (formatter req result durationSec)+  pure result++formatDefault :: HTTP.Request -> Either ServiceError HttpResponse -> Double -> Text+formatDefault req result duration =+  let method = pack $ show (HTTP.method req)+      url    = pack $ show (HTTP.host req) <> show (HTTP.path req)+      status = case result of+        Right resp -> pack $ show (HTTP.statusCode (HTTP.responseStatus resp))+        Left err   -> "ERR: " <> displayError err+      dur = pack $ show (round (duration * 1000) :: Int) <> "ms"+  in method <> " " <> url <> " -> " <> status <> " (" <> dur <> ")"

@@ -0,0 +1,38 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Network.HTTP.Tower.Middleware.RequestId+-- Description : Generate unique request IDs+-- License     : MIT+--+-- Adds a UUID v4 correlation ID to every request.+--+-- @+-- client '|>' 'withRequestId'                          -- X-Request-ID header+-- client '|>' 'withRequestIdHeader' \"X-Correlation-ID\"  -- custom header+-- @+module Network.HTTP.Tower.Middleware.RequestId+  ( withRequestId+  , withRequestIdHeader+  ) where++import Data.ByteString.Char8 (pack)+import Data.UUID (toString)+import Data.UUID.V4 (nextRandom)+import qualified Network.HTTP.Client as HTTP+import qualified Network.HTTP.Types.Header as HTTP++import Network.HTTP.Tower.Client (HttpResponse)+import Network.HTTP.Tower.Core (Service(..), Middleware)++-- | Add a unique @X-Request-ID@ header with a UUID v4 to every request.+withRequestId :: Middleware HTTP.Request HttpResponse+withRequestId = withRequestIdHeader "X-Request-ID"++-- | Add a unique request ID using a custom header name.+withRequestIdHeader :: HTTP.HeaderName -> Middleware HTTP.Request HttpResponse+withRequestIdHeader headerName inner = Service $ \req -> do+  uuid <- nextRandom+  let reqId = pack (toString uuid)+      req' = req { HTTP.requestHeaders = (headerName, reqId) : HTTP.requestHeaders req }+  runService inner req'

@@ -0,0 +1,85 @@+{-# LANGUAGE NumericUnderscores #-}++-- |+-- Module      : Network.HTTP.Tower.Middleware.Retry+-- Description : Retry middleware with configurable backoff+-- License     : MIT+--+-- Retries failed requests with constant or exponential backoff.+--+-- @+-- client '|>' 'withRetry' ('constantBackoff' 3 1.0)+-- client '|>' 'withRetry' ('exponentialBackoff' 5 0.5 2.0)+-- @+module Network.HTTP.Tower.Middleware.Retry+  ( BackoffStrategy(..)+  , constantBackoff+  , exponentialBackoff+  , withRetry+  , computeDelay+  ) where++import Control.Concurrent (threadDelay)+import Data.Time.Clock (NominalDiffTime)++import Network.HTTP.Tower.Core (Service(..), Middleware)+import Network.HTTP.Tower.Error (ServiceError(..))++-- | Strategy for computing delay between retries.+data BackoffStrategy+  = ConstantBackoff+      { backoffMaxRetries :: !Int+        -- ^ Maximum number of retries.+      , backoffDelay      :: !NominalDiffTime+        -- ^ Fixed delay between retries.+      }+  | ExponentialBackoff+      { backoffMaxRetries :: !Int+        -- ^ Maximum number of retries.+      , backoffBaseDelay  :: !NominalDiffTime+        -- ^ Initial delay before first retry.+      , backoffMultiplier :: !Double+        -- ^ Multiplier applied to delay after each attempt.+      }+  deriving (Show, Eq)++-- | Constant backoff: same delay between every retry.+--+-- @'constantBackoff' 3 1.0@ — retry up to 3 times, 1 second apart.+constantBackoff :: Int -> NominalDiffTime -> BackoffStrategy+constantBackoff = ConstantBackoff++-- | Exponential backoff: delay grows by multiplier each attempt.+--+-- @'exponentialBackoff' 5 0.5 2.0@ — retry up to 5 times, starting at 500ms, doubling each time.+exponentialBackoff :: Int -> NominalDiffTime -> Double -> BackoffStrategy+exponentialBackoff = ExponentialBackoff++-- | Compute the delay for a given attempt number (0-indexed).+computeDelay :: BackoffStrategy -> Int -> NominalDiffTime+computeDelay (ConstantBackoff _ d) _ = d+computeDelay (ExponentialBackoff _ base mult) attempt =+  base * realToFrac (mult ^^ attempt)++-- | Retry middleware: retries failed requests according to the backoff strategy.+--+-- On failure, waits for the computed delay, then retries. After all retries+-- are exhausted, returns 'RetryExhausted' with the attempt count and last error.+withRetry :: BackoffStrategy -> Middleware req res+withRetry strategy inner = Service $ \req ->+  go req 0+  where+    maxRetries = backoffMaxRetries strategy++    go req attempt = do+      result <- runService inner req+      case result of+        Right resp -> pure (Right resp)+        Left err+          | attempt >= maxRetries ->+              pure (Left (RetryExhausted attempt err))+          | otherwise -> do+              let delaySeconds = computeDelay strategy attempt+                  delayMicros = round (delaySeconds * 1_000_000) :: Int+              threadDelay delayMicros+              go req (attempt + 1)

@@ -0,0 +1,45 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Network.HTTP.Tower.Middleware.SetHeader+-- Description : Add headers to every request+-- License     : MIT+--+-- @+-- client '|>' 'withBearerAuth' \"my-token\"+-- client '|>' 'withUserAgent' \"my-app\/1.0\"+-- client '|>' 'withHeader' \"X-Custom\" \"value\"+-- @+module Network.HTTP.Tower.Middleware.SetHeader+  ( withHeader+  , withHeaders+  , withBearerAuth+  , withUserAgent+  ) where++import Data.ByteString (ByteString)+import qualified Network.HTTP.Client as HTTP+import qualified Network.HTTP.Types.Header as HTTP++import Network.HTTP.Tower.Client (HttpResponse)+import Network.HTTP.Tower.Core (Service(..), Middleware)++-- | Add a single header to every request.+withHeader :: HTTP.HeaderName -> ByteString -> Middleware HTTP.Request HttpResponse+withHeader name value inner = Service $ \req ->+  let req' = req { HTTP.requestHeaders = (name, value) : HTTP.requestHeaders req }+  in runService inner req'++-- | Add multiple headers to every request.+withHeaders :: [HTTP.Header] -> Middleware HTTP.Request HttpResponse+withHeaders hdrs inner = Service $ \req ->+  let req' = req { HTTP.requestHeaders = hdrs ++ HTTP.requestHeaders req }+  in runService inner req'++-- | Add a @Authorization: Bearer \<token\>@ header.+withBearerAuth :: ByteString -> Middleware HTTP.Request HttpResponse+withBearerAuth token = withHeader "Authorization" ("Bearer " <> token)++-- | Set the @User-Agent@ header.+withUserAgent :: ByteString -> Middleware HTTP.Request HttpResponse+withUserAgent = withHeader "User-Agent"

@@ -0,0 +1,69 @@+-- |+-- Module      : Network.HTTP.Tower.Middleware.TestDouble+-- Description : Mock services and request recording for testing+-- License     : MIT+--+-- @+-- -- Replace the service entirely+-- let testClient = client '|>' 'withMock' (\\req -> pure (Right fakeResponse))+--+-- -- Record requests for assertions+-- recorder <- newIORef []+-- let testClient = client '|>' 'withRecorder' recorder+-- @+module Network.HTTP.Tower.Middleware.TestDouble+  ( withMock+  , withMockMap+  , withRecorder+  ) where++import Data.ByteString (ByteString)+import Data.IORef+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import qualified Network.HTTP.Client as HTTP++import Network.HTTP.Tower.Client (HttpResponse)+import Network.HTTP.Tower.Core (Service(..), Middleware)+import Network.HTTP.Tower.Error (ServiceError(..))++-- | Replace the inner service entirely with a mock function.+-- The inner service is never called.+withMock+  :: (HTTP.Request -> IO (Either ServiceError HttpResponse))+  -> Middleware HTTP.Request HttpResponse+withMock handler _inner = Service handler++-- | Route requests to different mock responses based on @host <> path@.+-- Falls through to the inner service if no match is found.+--+-- @+-- let mocks = Map.fromList+--       [ (\"api.example.com\/v1\/users\", Right usersResponse)+--       , (\"api.example.com\/v1\/health\", Right healthResponse)+--       ]+-- let testClient = client '|>' 'withMockMap' mocks+-- @+withMockMap+  :: Map ByteString (Either ServiceError HttpResponse)+  -> Middleware HTTP.Request HttpResponse+withMockMap routes inner = Service $ \req ->+  let key = HTTP.host req <> HTTP.path req+  in case Map.lookup key routes of+    Just result -> pure result+    Nothing     -> runService inner req++-- | Record all requests that pass through, then forward to the inner service.+-- The recorder stores requests in reverse order (most recent first).+--+-- @+-- recorder <- newIORef []+-- let testClient = client '|>' 'withRecorder' recorder+-- _ <- runRequest testClient someRequest+-- recorded <- readIORef recorder+-- length recorded \`shouldBe\` 1+-- @+withRecorder :: IORef [HTTP.Request] -> Middleware HTTP.Request HttpResponse+withRecorder ref inner = Service $ \req -> do+  modifyIORef' ref (req :)+  runService inner req

@@ -0,0 +1,29 @@+-- |+-- Module      : Network.HTTP.Tower.Middleware.Timeout+-- Description : Timeout middleware+-- License     : MIT+--+-- Fails with 'TimeoutError' if the inner service doesn't respond within+-- the specified number of milliseconds.+--+-- @+-- client '|>' 'withTimeout' 5000  -- 5 second timeout+-- @+module Network.HTTP.Tower.Middleware.Timeout+  ( withTimeout+  ) where++import qualified System.Timeout as Sys++import Network.HTTP.Tower.Core (Service(..), Middleware)+import Network.HTTP.Tower.Error (ServiceError(..))++-- | Timeout middleware: fails with 'TimeoutError' if the request takes+-- longer than the specified number of milliseconds.+withTimeout :: Int -> Middleware req res+withTimeout ms inner = Service $ \req -> do+  let micros = ms * 1000+  result <- Sys.timeout micros (runService inner req)+  pure $ case result of+    Nothing        -> Left TimeoutError+    Just innerRes  -> innerRes

@@ -0,0 +1,101 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.HTTP.Tower.Middleware.Tracing+  ( withTracing+  , withTracingTracer+  ) where++import Control.Monad (when)+import Data.Text (Text, pack)+import Data.Text.Encoding (decodeUtf8)+import qualified Network.HTTP.Client as HTTP+import qualified Network.HTTP.Types.Status as HTTP++import OpenTelemetry.Attributes (emptyAttributes)+import OpenTelemetry.Trace.Core+  ( Tracer+  , InstrumentationLibrary(..)+  , TracerOptions(..)+  , SpanArguments(..)+  , SpanKind(..)+  , SpanStatus(..)+  , makeTracer+  , getGlobalTracerProvider+  , defaultSpanArguments+  , addAttribute+  , setStatus+  , inSpan'+  )++import Network.HTTP.Tower.Client (HttpResponse)+import Network.HTTP.Tower.Core (Service(..), Middleware)+import Network.HTTP.Tower.Error (ServiceError, displayError)++-- | Tracing middleware using the global TracerProvider.+-- Reads the global provider on each request (single IORef read, trivial cost).+-- If no TracerProvider is configured, this is a no-op (zero overhead).+--+-- @+-- let client' = client |> withTracing+-- @+withTracing :: Middleware HTTP.Request HttpResponse+withTracing inner = Service $ \req -> do+  tp <- getGlobalTracerProvider+  let tracer = makeTracer tp instrumentationLibrary (TracerOptions Nothing)+  runService (withTracingTracer tracer inner) req++-- | Tracing middleware using a specific Tracer.+-- Wraps each request in an OpenTelemetry span following+-- [stable HTTP semantic conventions](https://opentelemetry.io/docs/specs/semconv/http/http-spans/).+--+-- * Span name: @{method}@ (e.g., @GET@)+-- * Span kind: Client+-- * Attributes: @http.request.method@, @server.address@, @server.port@,+--   @url.full@, @http.response.status_code@, @error.type@+withTracingTracer :: Tracer -> Middleware HTTP.Request HttpResponse+withTracingTracer tracer inner = Service $ \req -> do+  let spanName = decodeUtf8 (HTTP.method req)+      spanArgs = defaultSpanArguments { kind = Client }+  inSpan' tracer spanName spanArgs $ \s -> do+    -- Required attributes+    addAttribute s "http.request.method" (decodeUtf8 (HTTP.method req))+    addAttribute s "server.address" (decodeUtf8 (HTTP.host req))+    addAttribute s "server.port" (HTTP.port req)+    addAttribute s "url.full" (buildUrl req)++    result <- runService inner req++    case result of+      Right resp -> do+        let code = HTTP.statusCode (HTTP.responseStatus resp)+        addAttribute s "http.response.status_code" code+        when (code >= 400) $ do+          addAttribute s "error.type" (pack (show code))+          setStatus s (Error "HTTP error status")+        pure (Right resp)+      Left err -> do+        addAttribute s "error.type" (displayError err)+        setStatus s (Error (displayError err))+        pure (Left err)++instrumentationLibrary :: InstrumentationLibrary+instrumentationLibrary = InstrumentationLibrary+  { libraryName = "http-tower-hs"+  , libraryVersion = "0.1.0.0"+  , librarySchemaUrl = ""+  , libraryAttributes = emptyAttributes+  }++-- | Build a full URL from an http-client Request.+buildUrl :: HTTP.Request -> Text+buildUrl req =+  let scheme = if HTTP.secure req then "https" else "http" :: Text+      host = decodeUtf8 (HTTP.host req)+      port = HTTP.port req+      path = decodeUtf8 (HTTP.path req)+      query = decodeUtf8 (HTTP.queryString req)+      showPort = case (HTTP.secure req, port) of+        (True, 443)  -> ""+        (False, 80)  -> ""+        _            -> ":" <> pack (show port)+  in scheme <> "://" <> host <> showPort <> path <> query

@@ -0,0 +1,73 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Network.HTTP.Tower.Middleware.Validate+-- Description : Response validation middleware+-- License     : MIT+--+-- Reject responses that don't meet expectations:+--+-- @+-- client '|>' 'withValidateStatus' (\\c -> c >= 200 && c < 300)+-- client '|>' 'withValidateContentType' \"application\/json\"+-- client '|>' 'withValidateHeader' \"X-Request-ID\"+-- @+module Network.HTTP.Tower.Middleware.Validate+  ( withValidateStatus+  , withValidateHeader+  , withValidateContentType+  ) where++import Data.ByteString (ByteString, isInfixOf)+import Data.Text (pack)+import qualified Network.HTTP.Client as HTTP+import qualified Network.HTTP.Types.Header as HTTP+import qualified Network.HTTP.Types.Status as HTTP++import Network.HTTP.Tower.Client (HttpResponse)+import Network.HTTP.Tower.Core (Service(..), Middleware)+import Network.HTTP.Tower.Error (ServiceError(..))++-- | Validate the response status code. Returns a 'CustomError' if the+-- predicate returns 'False'.+--+-- @+-- -- Only accept 2xx+-- client '|>' 'withValidateStatus' (\\c -> c >= 200 && c < 300)+-- @+withValidateStatus :: (Int -> Bool) -> Middleware HTTP.Request HttpResponse+withValidateStatus isValid inner = Service $ \req -> do+  result <- runService inner req+  case result of+    Right resp ->+      let code = HTTP.statusCode (HTTP.responseStatus resp)+      in if isValid code+          then pure (Right resp)+          else pure (Left (CustomError ("Unexpected status code: " <> pack (show code))))+    Left err -> pure (Left err)++-- | Validate that a specific response header is present.+withValidateHeader :: HTTP.HeaderName -> Middleware HTTP.Request HttpResponse+withValidateHeader headerName inner = Service $ \req -> do+  result <- runService inner req+  case result of+    Right resp ->+      case lookup headerName (HTTP.responseHeaders resp) of+        Just _  -> pure (Right resp)+        Nothing -> pure (Left (CustomError ("Missing required header: " <> pack (show headerName))))+    Left err -> pure (Left err)++-- | Validate the @Content-Type@ header contains the expected value.+--+-- Uses substring matching, so @\"application\/json\"@ matches+-- @\"application\/json; charset=utf-8\"@.+withValidateContentType :: ByteString -> Middleware HTTP.Request HttpResponse+withValidateContentType expected inner = Service $ \req -> do+  result <- runService inner req+  case result of+    Right resp ->+      case lookup "Content-Type" (HTTP.responseHeaders resp) of+        Just ct | expected `isInfixOf` ct -> pure (Right resp)+        Just ct -> pure (Left (CustomError ("Unexpected Content-Type: " <> pack (show ct))))+        Nothing -> pure (Left (CustomError "Missing Content-Type header"))+    Left err -> pure (Left err)

@@ -0,0 +1,134 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NumericUnderscores #-}++module Network.HTTP.Tower.ClientTLSSpec (spec) where++import Control.Concurrent (threadDelay)+import Control.Exception (try, SomeException)+import Data.Text (pack)+import qualified Network.HTTP.Client as HTTP+import qualified Network.HTTP.Types as HTTP+import System.Directory (createDirectoryIfMissing)+import System.Process (callCommand, readProcess)+import Test.Hspec++import qualified TestContainers as TC+import TestContainers.Hspec (withContainers)++import Network.HTTP.Tower.Client (newClientWithTLS, runRequest)+import Network.HTTP.Tower.Error (ServiceError(..))++-- | Generate test certificates: CA, server cert, client cert.+generateCerts :: FilePath -> IO ()+generateCerts dir = do+  createDirectoryIfMissing True dir+  -- CA+  callCommand $ "openssl genrsa -out " <> dir <> "/ca-key.pem 2048 2>/dev/null"+  callCommand $ "openssl req -new -x509 -key " <> dir <> "/ca-key.pem"+    <> " -out " <> dir <> "/ca.pem -days 1 -subj '/CN=Test CA' 2>/dev/null"+  -- Server (signed by CA, with SAN for localhost)+  callCommand $ "openssl genrsa -out " <> dir <> "/server-key.pem 2048 2>/dev/null"+  callCommand $ "openssl req -new -key " <> dir <> "/server-key.pem"+    <> " -out " <> dir <> "/server.csr -subj '/CN=localhost' 2>/dev/null"+  writeFile (dir <> "/san.cnf") $ unlines+    [ "[v3_req]"+    , "subjectAltName = DNS:localhost,IP:127.0.0.1"+    ]+  callCommand $ "openssl x509 -req -in " <> dir <> "/server.csr"+    <> " -CA " <> dir <> "/ca.pem -CAkey " <> dir <> "/ca-key.pem"+    <> " -CAcreateserial -out " <> dir <> "/server.pem -days 1"+    <> " -extensions v3_req -extfile " <> dir <> "/san.cnf 2>/dev/null"+  -- Client (signed by CA)+  callCommand $ "openssl genrsa -out " <> dir <> "/client-key.pem 2048 2>/dev/null"+  callCommand $ "openssl req -new -key " <> dir <> "/client-key.pem"+    <> " -out " <> dir <> "/client.csr -subj '/CN=Test Client' 2>/dev/null"+  callCommand $ "openssl x509 -req -in " <> dir <> "/client.csr"+    <> " -CA " <> dir <> "/ca.pem -CAkey " <> dir <> "/ca-key.pem"+    <> " -CAcreateserial -out " <> dir <> "/client.pem -days 1 2>/dev/null"++nginxConf :: String+nginxConf = unlines+  [ "events { worker_connections 64; }"+  , "http {"+  , "  server {"+  , "    listen 443 ssl;"+  , "    ssl_certificate /certs/server.pem;"+  , "    ssl_certificate_key /certs/server-key.pem;"+  , "    ssl_client_certificate /certs/ca.pem;"+  , "    ssl_verify_client on;"+  , "    location / { return 200 'mTLS OK'; }"+  , "  }"+  , "}"+  ]++dockerAvailable :: IO Bool+dockerAvailable = do+  result <- try (readProcess "docker" ["info"] "") :: IO (Either SomeException String)+  pure $ case result of+    Right _ -> True+    Left _  -> False++spec :: Spec+spec = describe "Client TLS (Docker)" $ beforeAll dockerAvailable $ do++  it "connects with custom CA to system HTTPS" $ \isAvailable -> do+    -- No Docker needed for this one — just test that newClientWithTLS works+    client <- newClientWithTLS Nothing Nothing+    req <- HTTP.parseRequest "https://example.com"+    result <- runRequest client req+    case result of+      Right resp -> HTTP.statusCode (HTTP.responseStatus resp) `shouldBe` 200+      Left err -> expectationFailure $ "Expected success, got: " <> show err++  it "connects with mTLS client cert to nginx" $ \isAvailable -> do+    if not isAvailable+      then pendingWith "Docker not available"+      else do+        let certDir = "/tmp/http-tower-hs-test-certs"+        generateCerts certDir+        writeFile (certDir <> "/nginx.conf") nginxConf++        withContainers (setupNginx certDir) $ \port -> do+          threadDelay 2_000_000++          client <- newClientWithTLS+            (Just (certDir <> "/ca.pem"))+            (Just (certDir <> "/client.pem", certDir <> "/client-key.pem"))+          req <- HTTP.parseRequest $ "https://localhost:" <> show port <> "/"+          result <- runRequest client req+          case result of+            Right resp -> HTTP.statusCode (HTTP.responseStatus resp) `shouldBe` 200+            Left err -> expectationFailure $ "mTLS request failed: " <> show err++  it "fails without client cert when mTLS is required" $ \isAvailable -> do+    if not isAvailable+      then pendingWith "Docker not available"+      else do+        let certDir = "/tmp/http-tower-hs-test-certs"+        generateCerts certDir+        writeFile (certDir <> "/nginx.conf") nginxConf++        withContainers (setupNginx certDir) $ \port -> do+          threadDelay 2_000_000++          client <- newClientWithTLS+            (Just (certDir <> "/ca.pem"))+            Nothing  -- no client cert+          req <- HTTP.parseRequest $ "https://localhost:" <> show port <> "/"+          result <- runRequest client req+          case result of+            Left _ -> pure ()  -- TLS handshake error+            Right resp ->+              -- nginx returns 400 when client cert is missing+              HTTP.statusCode (HTTP.responseStatus resp) `shouldSatisfy` (>= 400)++setupNginx :: FilePath -> TC.TestContainer Int+setupNginx certDir = do+  container <- TC.run $ TC.containerRequest (TC.fromTag "nginx:alpine")+    TC.& TC.setExpose [443]+    TC.& TC.setVolumeMounts+        [ (pack certDir, "/certs")+        , (pack (certDir <> "/nginx.conf"), "/etc/nginx/nginx.conf")+        ]+    TC.& TC.setWaitingFor (TC.waitUntilTimeout 30 (TC.waitUntilMappedPortReachable 443))+  pure (TC.containerPort container 443)

@@ -0,0 +1,54 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.HTTP.Tower.CoreSpec (spec) where++import Test.Hspec++import Network.HTTP.Tower.Core+import Network.HTTP.Tower.Error++spec :: Spec+spec = describe "Core" $ do+  describe "Service" $ do+    it "runs a simple service" $ do+      let svc = Service $ \n -> pure (Right (n * 2 :: Int))+      result <- runService svc 21+      result `shouldBe` Right 42++    it "returns errors in Left" $ do+      let svc :: Service () String+          svc = Service $ \_ -> pure (Left (CustomError "boom"))+      result <- runService svc ()+      result `shouldBe` Left (CustomError "boom")++  describe "mapService" $ do+    it "transforms successful responses" $ do+      let svc :: Service () Int+          svc = Service $ \_ -> pure (Right 10)+          mapped = mapService (* 3) svc+      result <- runService mapped ()+      result `shouldBe` Right 30++    it "passes through errors unchanged" $ do+      let svc :: Service () Int+          svc = Service $ \_ -> pure (Left TimeoutError)+          mapped = mapService (* 3) svc+      result <- runService mapped ()+      result `shouldBe` Left TimeoutError++  describe "composeMiddleware" $ do+    it "applies outer then inner" $ do+      let addTag tag (Service run) = Service $ \req ->+            run (req ++ tag)+          mw1 = addTag "[1]"+          mw2 = addTag "[2]"+          composed = composeMiddleware mw1 mw2+          svc = Service $ \req -> pure (Right req)+      result <- runService (composed svc) "start"+      result `shouldBe` Right "start[1][2]"++instance Eq ServiceError where+  CustomError a      == CustomError b      = a == b+  TimeoutError       == TimeoutError       = True+  RetryExhausted n _ == RetryExhausted m _ = n == m+  _                  == _                  = False

@@ -0,0 +1,146 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NumericUnderscores #-}++module Network.HTTP.Tower.Middleware.CircuitBreakerSpec (spec) where++import Control.Concurrent (threadDelay)+import Data.IORef+import Test.Hspec++import Network.HTTP.Tower.Core+import Network.HTTP.Tower.Error+import Network.HTTP.Tower.Middleware.CircuitBreaker++spec :: Spec+spec = describe "Circuit Breaker middleware" $ do+  let config = CircuitBreakerConfig+        { cbFailureThreshold = 3+        , cbCooldownPeriod   = 1  -- 1 second+        }++  describe "Closed state" $ do+    it "passes requests through when healthy" $ do+      breaker <- newCircuitBreaker+      let svc :: Service () String+          svc = Service $ \_ -> pure (Right "ok")+          wrapped = withCircuitBreaker config breaker svc+      result <- runService wrapped ()+      result `shouldBe` Right "ok"+      getCircuitBreakerState breaker >>= (`shouldBe` Closed)++    it "stays closed on fewer failures than threshold" $ do+      breaker <- newCircuitBreaker+      callCount <- newIORef (0 :: Int)+      let svc :: Service () String+          svc = Service $ \_ -> do+            modifyIORef' callCount (+ 1)+            pure (Left (CustomError "fail"))+          wrapped = withCircuitBreaker config breaker svc+      -- 2 failures, threshold is 3+      _ <- runService wrapped ()+      _ <- runService wrapped ()+      getCircuitBreakerState breaker >>= (`shouldBe` Closed)+      readIORef callCount >>= (`shouldBe` 2)++  describe "Tripping open" $ do+    it "trips open after reaching failure threshold" $ do+      breaker <- newCircuitBreaker+      let svc :: Service () String+          svc = Service $ \_ -> pure (Left (CustomError "fail"))+          wrapped = withCircuitBreaker config breaker svc+      -- 3 failures = threshold+      _ <- runService wrapped ()+      _ <- runService wrapped ()+      _ <- runService wrapped ()+      getCircuitBreakerState breaker >>= (`shouldBe` Open)++    it "rejects requests immediately when open" $ do+      breaker <- newCircuitBreaker+      callCount <- newIORef (0 :: Int)+      let failSvc :: Service () String+          failSvc = Service $ \_ -> do+            modifyIORef' callCount (+ 1)+            pure (Left (CustomError "fail"))+          wrapped = withCircuitBreaker config breaker failSvc+      -- Trip the breaker+      _ <- runService wrapped ()+      _ <- runService wrapped ()+      _ <- runService wrapped ()+      -- Next request should be rejected without calling the service+      countBefore <- readIORef callCount+      result <- runService wrapped ()+      countAfter <- readIORef callCount+      result `shouldBe` Left CircuitBreakerOpen+      countAfter `shouldBe` countBefore  -- service was NOT called++  describe "Half-open state" $ do+    it "transitions to half-open after cooldown" $ do+      let fastConfig = config { cbCooldownPeriod = 0.1 }  -- 100ms cooldown+      breaker <- newCircuitBreaker+      let svc :: Service () String+          svc = Service $ \_ -> pure (Left (CustomError "fail"))+          wrapped = withCircuitBreaker fastConfig breaker svc+      -- Trip the breaker+      _ <- runService wrapped ()+      _ <- runService wrapped ()+      _ <- runService wrapped ()+      getCircuitBreakerState breaker >>= (`shouldBe` Open)+      -- Wait for cooldown+      threadDelay 150_000  -- 150ms+      -- Next request should go through (half-open allows one probe)+      _ <- runService wrapped ()+      -- It failed again, so back to Open+      getCircuitBreakerState breaker >>= (`shouldBe` Open)++    it "resets to closed on success in half-open" $ do+      let fastConfig = config { cbCooldownPeriod = 0.1 }+      breaker <- newCircuitBreaker+      callCount <- newIORef (0 :: Int)+      let svc :: Service () String+          svc = Service $ \_ -> do+            n <- readIORef callCount+            modifyIORef' callCount (+ 1)+            if n < 3+              then pure (Left (CustomError "fail"))+              else pure (Right "recovered")+          wrapped = withCircuitBreaker fastConfig breaker svc+      -- Trip the breaker (3 failures)+      _ <- runService wrapped ()+      _ <- runService wrapped ()+      _ <- runService wrapped ()+      getCircuitBreakerState breaker >>= (`shouldBe` Open)+      -- Wait for cooldown+      threadDelay 150_000+      -- Next request succeeds — should reset to Closed+      result <- runService wrapped ()+      result `shouldBe` Right "recovered"+      getCircuitBreakerState breaker >>= (`shouldBe` Closed)++  describe "Reset on success" $ do+    it "resets failure count on any success" $ do+      breaker <- newCircuitBreaker+      callCount <- newIORef (0 :: Int)+      let svc :: Service () String+          svc = Service $ \_ -> do+            n <- readIORef callCount+            modifyIORef' callCount (+ 1)+            if n == 1  -- second call succeeds+              then pure (Right "ok")+              else pure (Left (CustomError "fail"))+          wrapped = withCircuitBreaker config breaker svc+      -- Fail once+      _ <- runService wrapped ()+      -- Succeed — resets counter+      _ <- runService wrapped ()+      getCircuitBreakerState breaker >>= (`shouldBe` Closed)+      -- Now need 3 MORE failures to trip (not 2)+      _ <- runService wrapped ()  -- fail+      _ <- runService wrapped ()  -- fail+      getCircuitBreakerState breaker >>= (`shouldBe` Closed)++instance Eq ServiceError where+  CustomError a      == CustomError b      = a == b+  TimeoutError       == TimeoutError       = True+  CircuitBreakerOpen == CircuitBreakerOpen  = True+  RetryExhausted n _ == RetryExhausted m _ = n == m+  _                  == _                  = False

@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.HTTP.Tower.Middleware.FilterSpec (spec) where++import qualified Network.HTTP.Client as HTTP+import Test.Hspec++import Network.HTTP.Tower.Client (HttpResponse)+import Network.HTTP.Tower.Core+import Network.HTTP.Tower.Error+import Network.HTTP.Tower.Middleware.Filter++spec :: Spec+spec = describe "Filter middleware" $ do+  describe "withFilter" $ do+    it "allows matching requests through" $ do+      let svc :: Service HTTP.Request String+          svc = Service $ \_ -> pure (Right "ok")+          filtered = withFilter (const True) svc+      req <- HTTP.parseRequest "http://example.com"+      result <- runService filtered req+      result `shouldBe` Right "ok"++    it "rejects non-matching requests" $ do+      let svc :: Service HTTP.Request String+          svc = Service $ \_ -> pure (Right "ok")+          filtered = withFilter (const False) svc+      req <- HTTP.parseRequest "http://example.com"+      result <- runService filtered req+      result `shouldBe` Left (CustomError "Request filtered out")++    it "filters based on request properties" $ do+      let svc :: Service HTTP.Request String+          svc = Service $ \_ -> pure (Right "ok")+          onlyGet = withFilter (\r -> HTTP.method r == "GET") svc+      getReq <- HTTP.parseRequest "http://example.com"+      postReq <- HTTP.parseRequest "http://example.com"+      let postReq' = postReq { HTTP.method = "POST" }+      getResult <- runService onlyGet getReq+      postResult <- runService onlyGet postReq'+      getResult `shouldBe` Right "ok"+      postResult `shouldBe` Left (CustomError "Request filtered out")++instance Eq ServiceError where+  CustomError a == CustomError b = a == b+  _ == _ = False

@@ -0,0 +1,89 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.HTTP.Tower.Middleware.FollowRedirectSpec (spec) where++import Data.IORef+import qualified Data.ByteString.Lazy as LBS+import qualified Network.HTTP.Client as HTTP+import qualified Network.HTTP.Client.Internal as HTTP+import qualified Network.HTTP.Types as HTTP+import Test.Hspec++import Network.HTTP.Tower.Client (HttpResponse)+import Network.HTTP.Tower.Core+import Network.HTTP.Tower.Error+import Network.HTTP.Tower.Middleware.FollowRedirect++spec :: Spec+spec = describe "FollowRedirect middleware" $ do+  it "passes non-redirect responses through" $ do+    let svc = Service $ \_ -> pure (Right (fakeResponseWith HTTP.status200 []))+        followed = withFollowRedirects 5 svc+    req <- HTTP.parseRequest "http://example.com"+    result <- runService followed req+    case result of+      Right resp -> HTTP.responseStatus resp `shouldBe` HTTP.status200+      Left err -> expectationFailure $ show err++  it "follows a 302 redirect" $ do+    callCount <- newIORef (0 :: Int)+    let svc = Service $ \req -> do+          n <- readIORef callCount+          modifyIORef' callCount (+ 1)+          if n == 0+            then pure $ Right $ fakeResponseWith+              (HTTP.mkStatus 302 "Found")+              [("Location", "http://example.com/redirected")]+            else pure $ Right $ fakeResponseWith HTTP.status200 []+        followed = withFollowRedirects 5 svc+    req <- HTTP.parseRequest "http://example.com/original"+    result <- runService followed req+    case result of+      Right resp -> HTTP.responseStatus resp `shouldBe` HTTP.status200+      Left err -> expectationFailure $ show err+    readIORef callCount >>= (`shouldBe` 2)++  it "stops after max redirects" $ do+    let svc = Service $ \_ -> pure $ Right $ fakeResponseWith+          (HTTP.mkStatus 301 "Moved")+          [("Location", "http://example.com/loop")]+        followed = withFollowRedirects 3 svc+    req <- HTTP.parseRequest "http://example.com/loop"+    result <- runService followed req+    case result of+      Left (CustomError msg) -> msg `shouldBe` "Too many redirects"+      other -> expectationFailure $ "Expected CustomError, got: " ++ show other++  it "changes method to GET on 303" $ do+    recorder <- newIORef []+    let svc = Service $ \req -> do+          modifyIORef' recorder (HTTP.method req :)+          n <- length <$> readIORef recorder+          if n == 1+            then pure $ Right $ fakeResponseWith+              (HTTP.mkStatus 303 "See Other")+              [("Location", "http://example.com/result")]+            else pure $ Right $ fakeResponseWith HTTP.status200 []+        followed = withFollowRedirects 5 svc+    req <- HTTP.parseRequest "http://example.com/action"+    let postReq = req { HTTP.method = "POST" }+    _ <- runService followed postReq+    methods <- readIORef recorder+    -- First request was POST, second (after 303) should be GET+    reverse methods `shouldBe` ["POST", "GET"]++fakeResponseWith :: HTTP.Status -> [HTTP.Header] -> HttpResponse+fakeResponseWith status hdrs = HTTP.Response+  { HTTP.responseStatus = status+  , HTTP.responseVersion = HTTP.http11+  , HTTP.responseHeaders = hdrs+  , HTTP.responseBody = ""+  , HTTP.responseCookieJar = HTTP.createCookieJar []+  , HTTP.responseClose' = HTTP.ResponseClose (pure ())+  , HTTP.responseOriginalRequest = error "not used"+  , HTTP.responseEarlyHints = []+  }++instance Eq ServiceError where+  CustomError a == CustomError b = a == b+  _ == _ = False

@@ -0,0 +1,57 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NumericUnderscores #-}++module Network.HTTP.Tower.Middleware.HedgeSpec (spec) where++import Control.Concurrent (threadDelay)+import Data.IORef+import Test.Hspec++import Network.HTTP.Tower.Core+import Network.HTTP.Tower.Error+import Network.HTTP.Tower.Middleware.Hedge++spec :: Spec+spec = describe "Hedge middleware" $ do+  it "returns result from fast primary without hedging" $ do+    let svc :: Service () String+        svc = Service $ \_ -> pure (Right "fast")+        hedged = withHedge 1000 svc+    result <- runService hedged ()+    result `shouldBe` Right "fast"++  it "returns a result when primary is slow (hedge may win)" $ do+    callCount <- newIORef (0 :: Int)+    let svc :: Service () String+        svc = Service $ \_ -> do+          n <- atomicModifyIORef' callCount (\c -> (c + 1, c))+          if n == 0+            then do+              threadDelay 500_000  -- primary: slow+              pure (Right "primary")+            else pure (Right "hedge")  -- hedge: instant+        hedged = withHedge 50 svc+    result <- runService hedged ()+    case result of+      Right _ -> pure ()+      Left err -> expectationFailure $ "Expected Right, got: " ++ show err++  it "calls service at most twice" $ do+    callCount <- newIORef (0 :: Int)+    let svc :: Service () String+        svc = Service $ \_ -> do+          modifyIORef' callCount (+ 1)+          threadDelay 100_000+          pure (Right "done")+        hedged = withHedge 50 svc+    _ <- runService hedged ()+    threadDelay 200_000+    count <- readIORef callCount+    count `shouldSatisfy` (<= 2)++instance Eq ServiceError where+  CustomError a      == CustomError b      = a == b+  TimeoutError       == TimeoutError       = True+  CircuitBreakerOpen == CircuitBreakerOpen  = True+  RetryExhausted n _ == RetryExhausted m _ = n == m+  _                  == _                  = False

@@ -0,0 +1,65 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.HTTP.Tower.Middleware.LoggingSpec (spec) where++import Data.IORef+import Data.Text (Text, isInfixOf)+import qualified Data.ByteString.Lazy as LBS+import qualified Network.HTTP.Client as HTTP+import qualified Network.HTTP.Client.Internal as HTTP+import qualified Network.HTTP.Types as HTTP+import Test.Hspec++import Network.HTTP.Tower.Client (HttpResponse)+import Network.HTTP.Tower.Core+import Network.HTTP.Tower.Error+import Network.HTTP.Tower.Middleware.Logging++spec :: Spec+spec = describe "Logging middleware" $ do+  it "logs successful requests" $ do+    logRef <- newIORef ([] :: [Text])+    let logger msg = modifyIORef' logRef (msg :)+        svc = Service $ \_ -> pure (Right fakeResponse)+        logged = withLogging logger svc+    req <- HTTP.parseRequest "http://example.com/test"+    _ <- runService logged req+    logs <- readIORef logRef+    length logs `shouldBe` 1+    let logMsg = head logs+    isInfixOf "example.com" logMsg `shouldBe` True++  it "logs failed requests" $ do+    logRef <- newIORef ([] :: [Text])+    let logger msg = modifyIORef' logRef (msg :)+        svc :: Service HTTP.Request HttpResponse+        svc = Service $ \_ -> pure (Left TimeoutError)+        logged = withLogging logger svc+    req <- HTTP.parseRequest "http://example.com/fail"+    _ <- runService logged req+    logs <- readIORef logRef+    length logs `shouldBe` 1+    let logMsg = head logs+    isInfixOf "ERR" logMsg `shouldBe` True++  it "does not alter the result" $ do+    let logger _ = pure ()+        svc = Service $ \_ -> pure (Right fakeResponse)+        logged = withLogging logger svc+    req <- HTTP.parseRequest "http://example.com/passthrough"+    result <- runService logged req+    case result of+      Right _  -> pure ()+      Left err -> expectationFailure $ "Expected Right, got: " ++ show err++fakeResponse :: HTTP.Response LBS.ByteString+fakeResponse = HTTP.Response+  { HTTP.responseStatus = HTTP.status200+  , HTTP.responseVersion = HTTP.http11+  , HTTP.responseHeaders = []+  , HTTP.responseBody = ""+  , HTTP.responseCookieJar = HTTP.createCookieJar []+  , HTTP.responseClose' = HTTP.ResponseClose (pure ())+  , HTTP.responseOriginalRequest = error "not used"+  , HTTP.responseEarlyHints = []+  }

@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.HTTP.Tower.Middleware.RequestIdSpec (spec) where++import Data.IORef+import qualified Network.HTTP.Client as HTTP+import Test.Hspec++import Network.HTTP.Tower.Client (HttpResponse)+import Network.HTTP.Tower.Core+import Network.HTTP.Tower.Middleware.RequestId+import Network.HTTP.Tower.Middleware.TestDouble (withRecorder)++spec :: Spec+spec = describe "RequestId middleware" $ do+  it "adds X-Request-ID header" $ do+    recorder <- newIORef []+    let svc = withRequestId (withRecorder recorder (Service $ \_ -> pure (Right fakeResponse)))+    req <- HTTP.parseRequest "http://example.com"+    _ <- runService svc req+    recorded <- readIORef recorder+    let hdrs = HTTP.requestHeaders (head recorded)+    lookup "X-Request-ID" hdrs `shouldSatisfy` (/= Nothing)++  it "generates unique IDs per request" $ do+    recorder <- newIORef []+    let svc = withRequestId (withRecorder recorder (Service $ \_ -> pure (Right fakeResponse)))+    req <- HTTP.parseRequest "http://example.com"+    _ <- runService svc req+    _ <- runService svc req+    recorded <- readIORef recorder+    let ids = map (lookup "X-Request-ID" . HTTP.requestHeaders) recorded+    length ids `shouldBe` 2+    head ids `shouldSatisfy` (/= last ids)++  it "uses custom header name" $ do+    recorder <- newIORef []+    let svc = withRequestIdHeader "X-Correlation-ID" (withRecorder recorder (Service $ \_ -> pure (Right fakeResponse)))+    req <- HTTP.parseRequest "http://example.com"+    _ <- runService svc req+    recorded <- readIORef recorder+    let hdrs = HTTP.requestHeaders (head recorded)+    lookup "X-Correlation-ID" hdrs `shouldSatisfy` (/= Nothing)++fakeResponse :: HttpResponse+fakeResponse = error "fakeResponse: body not evaluated in RequestId tests"

@@ -0,0 +1,91 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.HTTP.Tower.Middleware.RetrySpec (spec) where++import Data.IORef+import Data.Time.Clock (NominalDiffTime)+import Test.Hspec+import Test.QuickCheck++import Network.HTTP.Tower.Core+import Network.HTTP.Tower.Error+import Network.HTTP.Tower.Middleware.Retry++spec :: Spec+spec = describe "Retry middleware" $ do+  describe "withRetry" $ do+    it "returns success immediately without retrying" $ do+      callCount <- newIORef (0 :: Int)+      let svc :: Service () String+          svc = Service $ \_ -> do+            modifyIORef' callCount (+ 1)+            pure (Right "ok")+          retried = withRetry (constantBackoff 3 0) svc+      result <- runService retried ()+      result `shouldBe` Right "ok"+      readIORef callCount >>= (`shouldBe` 1)++    it "retries on failure up to max retries" $ do+      callCount <- newIORef (0 :: Int)+      let svc :: Service () String+          svc = Service $ \_ -> do+            modifyIORef' callCount (+ 1)+            pure (Left (CustomError "fail"))+          retried = withRetry (constantBackoff 3 0) svc+      result <- runService retried ()+      case result of+        Left (RetryExhausted n _) -> n `shouldBe` 3+        other -> expectationFailure $ "Expected RetryExhausted, got: " ++ show other+      readIORef callCount >>= (`shouldBe` 4)  -- 1 initial + 3 retries++    it "succeeds after transient failures" $ do+      callCount <- newIORef (0 :: Int)+      let svc :: Service () String+          svc = Service $ \_ -> do+            n <- readIORef callCount+            modifyIORef' callCount (+ 1)+            if n < 2+              then pure (Left (CustomError "transient"))+              else pure (Right "recovered")+          retried = withRetry (constantBackoff 3 0) svc+      result <- runService retried ()+      result `shouldBe` Right "recovered"+      readIORef callCount >>= (`shouldBe` 3)  -- 2 failures + 1 success++    it "retries zero times when maxRetries is 0" $ do+      callCount <- newIORef (0 :: Int)+      let svc :: Service () String+          svc = Service $ \_ -> do+            modifyIORef' callCount (+ 1)+            pure (Left (CustomError "fail"))+          retried = withRetry (constantBackoff 0 0) svc+      result <- runService retried ()+      case result of+        Left (RetryExhausted 0 _) -> pure ()+        other -> expectationFailure $ "Expected RetryExhausted 0, got: " ++ show other+      readIORef callCount >>= (`shouldBe` 1)++  describe "computeDelay" $ do+    it "constant backoff returns same delay regardless of attempt" $ do+      let strategy = constantBackoff 3 2.0+      computeDelay strategy 0 `shouldBe` 2.0+      computeDelay strategy 1 `shouldBe` 2.0+      computeDelay strategy 5 `shouldBe` 2.0++    it "exponential backoff grows by multiplier" $ do+      let strategy = exponentialBackoff 5 1.0 2.0+      computeDelay strategy 0 `shouldBe` 1.0+      computeDelay strategy 1 `shouldBe` 2.0+      computeDelay strategy 2 `shouldBe` 4.0+      computeDelay strategy 3 `shouldBe` 8.0++    it "exponential delay is always positive" $ property $+      \(Positive base) (Positive mult) (NonNegative attempt) ->+        let strategy = exponentialBackoff 10 (realToFrac (base :: Double)) (mult :: Double)+        in computeDelay strategy (attempt :: Int) >= (0 :: NominalDiffTime)++instance Eq ServiceError where+  CustomError a      == CustomError b      = a == b+  TimeoutError       == TimeoutError       = True+  RetryExhausted n _ == RetryExhausted m _ = n == m+  _                  == _                  = False

@@ -0,0 +1,54 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.HTTP.Tower.Middleware.SetHeaderSpec (spec) where++import Data.IORef+import qualified Network.HTTP.Client as HTTP+import Test.Hspec++import Network.HTTP.Tower.Client (HttpResponse)+import Network.HTTP.Tower.Core+import Network.HTTP.Tower.Middleware.SetHeader+import Network.HTTP.Tower.Middleware.TestDouble (withRecorder)++spec :: Spec+spec = describe "SetHeader middleware" $ do+  it "adds a single header to requests" $ do+    recorder <- newIORef []+    let svc = withHeader "X-Custom" "value" (withRecorder recorder (Service $ \_ -> pure (Right fakeResponse)))+    req <- HTTP.parseRequest "http://example.com"+    _ <- runService svc req+    recorded <- readIORef recorder+    let hdrs = HTTP.requestHeaders (head recorded)+    lookup "X-Custom" hdrs `shouldBe` Just "value"++  it "adds multiple headers" $ do+    recorder <- newIORef []+    let svc = withHeaders [("X-A", "1"), ("X-B", "2")] (withRecorder recorder (Service $ \_ -> pure (Right fakeResponse)))+    req <- HTTP.parseRequest "http://example.com"+    _ <- runService svc req+    recorded <- readIORef recorder+    let hdrs = HTTP.requestHeaders (head recorded)+    lookup "X-A" hdrs `shouldBe` Just "1"+    lookup "X-B" hdrs `shouldBe` Just "2"++  it "adds Bearer auth header" $ do+    recorder <- newIORef []+    let svc = withBearerAuth "my-token" (withRecorder recorder (Service $ \_ -> pure (Right fakeResponse)))+    req <- HTTP.parseRequest "http://example.com"+    _ <- runService svc req+    recorded <- readIORef recorder+    let hdrs = HTTP.requestHeaders (head recorded)+    lookup "Authorization" hdrs `shouldBe` Just "Bearer my-token"++  it "sets User-Agent header" $ do+    recorder <- newIORef []+    let svc = withUserAgent "http-tower/0.1" (withRecorder recorder (Service $ \_ -> pure (Right fakeResponse)))+    req <- HTTP.parseRequest "http://example.com"+    _ <- runService svc req+    recorded <- readIORef recorder+    let hdrs = HTTP.requestHeaders (head recorded)+    lookup "User-Agent" hdrs `shouldBe` Just "http-tower/0.1"++fakeResponse :: HttpResponse+fakeResponse = error "fakeResponse: body not evaluated in SetHeader tests"

@@ -0,0 +1,97 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.HTTP.Tower.Middleware.TestDoubleSpec (spec) where++import Data.IORef+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Map.Strict as Map+import qualified Network.HTTP.Client as HTTP+import qualified Network.HTTP.Client.Internal as HTTP+import qualified Network.HTTP.Types as HTTP+import Test.Hspec++import Network.HTTP.Tower.Client (HttpResponse)+import Network.HTTP.Tower.Core+import Network.HTTP.Tower.Error+import Network.HTTP.Tower.Middleware.TestDouble++spec :: Spec+spec = describe "TestDouble middleware" $ do+  describe "withMock" $ do+    it "replaces the inner service entirely" $ do+      innerCalled <- newIORef False+      let inner = Service $ \_ -> do+            writeIORef innerCalled True+            pure (Right fakeResponse)+          mocked = withMock (\_ -> pure (Right fakeResponse)) inner+      req <- HTTP.parseRequest "http://example.com"+      result <- runService mocked req+      case result of+        Right _ -> pure ()+        Left err -> expectationFailure $ show err+      readIORef innerCalled >>= (`shouldBe` False)++    it "can return errors" $ do+      let mocked = withMock (\_ -> pure (Left (CustomError "mock error"))) (Service $ \_ -> pure (Right fakeResponse))+      req <- HTTP.parseRequest "http://example.com"+      result <- runService mocked req+      case result of+        Left (CustomError "mock error") -> pure ()+        other -> expectationFailure $ "Expected mock error, got: " ++ show other++  describe "withMockMap" $ do+    it "routes to matching mock response" $ do+      let mocks = Map.fromList+            [ ("example.com/api/users", Right fakeResponse)+            ]+          mocked = withMockMap mocks (Service $ \_ -> pure (Left (CustomError "not mocked")))+      req <- HTTP.parseRequest "http://example.com/api/users"+      result <- runService mocked req+      case result of+        Right _ -> pure ()+        Left err -> expectationFailure $ "Expected mock match, got: " ++ show err++    it "falls through to inner service on no match" $ do+      let mocks = Map.fromList+            [ ("example.com/api/users", Right fakeResponse)+            ]+          mocked = withMockMap mocks (Service $ \_ -> pure (Right fakeResponse))+      req <- HTTP.parseRequest "http://example.com/api/other"+      result <- runService mocked req+      case result of+        Right _ -> pure ()+        Left err -> expectationFailure $ show err++  describe "withRecorder" $ do+    it "records all requests" $ do+      recorder <- newIORef []+      let svc = withRecorder recorder (Service $ \_ -> pure (Right fakeResponse))+      req1 <- HTTP.parseRequest "http://example.com/a"+      req2 <- HTTP.parseRequest "http://example.com/b"+      _ <- runService svc req1+      _ <- runService svc req2+      recorded <- readIORef recorder+      length recorded `shouldBe` 2++    it "still forwards to inner service" $ do+      recorder <- newIORef []+      innerCalled <- newIORef (0 :: Int)+      let inner = Service $ \_ -> do+            modifyIORef' innerCalled (+ 1)+            pure (Right fakeResponse)+          svc = withRecorder recorder inner+      req <- HTTP.parseRequest "http://example.com"+      _ <- runService svc req+      readIORef innerCalled >>= (`shouldBe` 1)++fakeResponse :: HttpResponse+fakeResponse = HTTP.Response+  { HTTP.responseStatus = HTTP.status200+  , HTTP.responseVersion = HTTP.http11+  , HTTP.responseHeaders = []+  , HTTP.responseBody = ""+  , HTTP.responseCookieJar = HTTP.createCookieJar []+  , HTTP.responseClose' = HTTP.ResponseClose (pure ())+  , HTTP.responseOriginalRequest = error "not used"+  , HTTP.responseEarlyHints = []+  }

@@ -0,0 +1,42 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NumericUnderscores #-}++module Network.HTTP.Tower.Middleware.TimeoutSpec (spec) where++import Control.Concurrent (threadDelay)+import Test.Hspec++import Network.HTTP.Tower.Core+import Network.HTTP.Tower.Error+import Network.HTTP.Tower.Middleware.Timeout++spec :: Spec+spec = describe "Timeout middleware" $ do+  it "allows fast requests through" $ do+    let svc :: Service () String+        svc = Service $ \_ -> pure (Right "fast")+        timed = withTimeout 1000 svc+    result <- runService timed ()+    result `shouldBe` Right "fast"++  it "times out slow requests" $ do+    let svc :: Service () String+        svc = Service $ \_ -> do+          threadDelay 500_000  -- 500ms+          pure (Right "slow")+        timed = withTimeout 100 svc  -- 100ms timeout+    result <- runService timed ()+    result `shouldBe` Left TimeoutError++  it "preserves errors from inner service" $ do+    let svc :: Service () String+        svc = Service $ \_ -> pure (Left (CustomError "inner error"))+        timed = withTimeout 1000 svc+    result <- runService timed ()+    result `shouldBe` Left (CustomError "inner error")++instance Eq ServiceError where+  CustomError a      == CustomError b      = a == b+  TimeoutError       == TimeoutError       = True+  RetryExhausted n _ == RetryExhausted m _ = n == m+  _                  == _                  = False

@@ -0,0 +1,131 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE NamedFieldPuns #-}++module Network.HTTP.Tower.Middleware.TracingDockerSpec (spec) where++import Control.Concurrent (threadDelay)+import Control.Exception (try, SomeException)+import Data.Aeson (Value(..), (.:), decode, withObject)+import Data.Aeson.Types (parseMaybe)+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Vector as V+import qualified Network.HTTP.Client as HTTP+import qualified Network.HTTP.Client.Internal as HTTP+import qualified Network.HTTP.Client.TLS as TLS+import qualified Network.HTTP.Types as HTTP+import System.Environment (setEnv, unsetEnv)+import System.Process (readProcess)+import Test.Hspec++import qualified TestContainers as TC+import TestContainers.Hspec (withContainers)++import OpenTelemetry.Trace.Core+  ( makeTracer+  , InstrumentationLibrary(..)+  , TracerOptions(..)+  , shutdownTracerProvider+  )+import OpenTelemetry.Attributes (emptyAttributes)+import OpenTelemetry.Trace (initializeGlobalTracerProvider)++import Network.HTTP.Tower.Client (HttpResponse)+import Network.HTTP.Tower.Core+import Network.HTTP.Tower.Middleware.Tracing++-- | Jaeger container setup via testcontainers.+data JaegerPorts = JaegerPorts+  { otlpPort   :: Int+  , jaegerPort :: Int+  }++setupJaeger :: TC.TestContainer JaegerPorts+setupJaeger = do+  container <- TC.run $ TC.containerRequest (TC.fromTag "jaegertracing/all-in-one:latest")+    TC.& TC.setExpose [4318, 16686]+    TC.& TC.setWaitingFor (TC.waitUntilTimeout 60 (TC.waitUntilMappedPortReachable 16686))+  pure JaegerPorts+    { otlpPort   = TC.containerPort container 4318+    , jaegerPort = TC.containerPort container 16686+    }++dockerAvailable :: IO Bool+dockerAvailable = do+  result <- try (readProcess "docker" ["info"] "") :: IO (Either SomeException String)+  pure $ case result of+    Right _ -> True+    Left _  -> False++queryJaegerTraces :: HTTP.Manager -> Int -> String -> IO (Maybe Value)+queryJaegerTraces mgr port service = do+  req <- HTTP.parseRequest $+    "http://localhost:" <> show port <> "/api/traces?service=" <> service <> "&limit=10"+  resp <- HTTP.httpLbs req mgr+  pure (decode (HTTP.responseBody resp))++spec :: Spec+spec = describe "Tracing Docker integration (Jaeger via testcontainers)" $ beforeAll dockerAvailable $ do++  it "exports spans to Jaeger via OTLP" $ \isAvailable -> do+    if not isAvailable+      then pendingWith "Docker not available, skipping Jaeger integration test"+      else withContainers setupJaeger $ \JaegerPorts{otlpPort, jaegerPort} -> do+        -- Configure OTel SDK via environment variables+        setEnv "OTEL_EXPORTER_OTLP_ENDPOINT" ("http://localhost:" <> show otlpPort)+        setEnv "OTEL_EXPORTER_OTLP_PROTOCOL" "http/protobuf"+        setEnv "OTEL_SERVICE_NAME" "http-tower-hs-tc-test"++        -- Initialize TracerProvider from env+        tp <- initializeGlobalTracerProvider++        let tracer = makeTracer tp+              (InstrumentationLibrary+                { libraryName = "http-tower-hs-tc-test"+                , libraryVersion = "0.1.0.0"+                , librarySchemaUrl = ""+                , libraryAttributes = emptyAttributes+                })+              (TracerOptions Nothing)++        -- Run a request through the tracing middleware+        let svc = Service $ \_ -> pure (Right fakeResponse)+            traced = withTracingTracer tracer svc+        req <- HTTP.parseRequest "http://example.com/testcontainers-test"+        _ <- runService traced req++        -- Shut down to flush all spans+        shutdownTracerProvider tp++        -- Clean up env vars+        unsetEnv "OTEL_EXPORTER_OTLP_ENDPOINT"+        unsetEnv "OTEL_EXPORTER_OTLP_PROTOCOL"+        unsetEnv "OTEL_SERVICE_NAME"++        -- Give Jaeger time to index+        threadDelay 3_000_000++        -- Query Jaeger for our traces+        mgr <- HTTP.newManager TLS.tlsManagerSettings+        result <- queryJaegerTraces mgr jaegerPort "http-tower-hs-tc-test"+        case result of+          Nothing -> expectationFailure "Failed to parse Jaeger API response"+          Just val -> do+            let traceCount = parseMaybe (withObject "resp" $ \o -> do+                    arr <- o .: "data"+                    pure (V.length (arr :: V.Vector Value))) val+            case traceCount of+              Just n  -> n `shouldSatisfy` (>= 1)+              Nothing -> expectationFailure $ "Unexpected Jaeger response: " ++ show val++fakeResponse :: HttpResponse+fakeResponse = HTTP.Response+  { HTTP.responseStatus = HTTP.status200+  , HTTP.responseVersion = HTTP.http11+  , HTTP.responseHeaders = []+  , HTTP.responseBody = ""+  , HTTP.responseCookieJar = HTTP.createCookieJar []+  , HTTP.responseClose' = HTTP.ResponseClose (pure ())+  , HTTP.responseOriginalRequest = error "not used"+  , HTTP.responseEarlyHints = []+  }

@@ -0,0 +1,148 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NumericUnderscores #-}++module Network.HTTP.Tower.Middleware.TracingIntegrationSpec (spec) where++import Control.Concurrent (threadDelay)+import Data.IORef+import Data.Text (Text, isInfixOf)+import qualified Data.ByteString.Lazy as LBS+import qualified Network.HTTP.Client as HTTP+import qualified Network.HTTP.Client.Internal as HTTP+import qualified Network.HTTP.Types as HTTP+import Test.Hspec++import OpenTelemetry.Trace.Core+  ( Tracer+  , makeTracer+  , InstrumentationLibrary(..)+  , TracerOptions(..)+  , ImmutableSpan(..)+  , setGlobalTracerProvider+  , shutdownTracerProvider+  )+import OpenTelemetry.Attributes (emptyAttributes, lookupAttribute)+import OpenTelemetry.Trace+  ( createTracerProvider+  , emptyTracerProviderOptions+  )+import OpenTelemetry.Exporter.InMemory (inMemoryListExporter)++import Network.HTTP.Tower.Client (HttpResponse)+import Network.HTTP.Tower.Core+import Network.HTTP.Tower.Error+import Network.HTTP.Tower.Middleware.Tracing++withTestTracer :: (Tracer -> IORef [ImmutableSpan] -> IO a) -> IO a+withTestTracer action = do+  (processor, spanRef) <- inMemoryListExporter+  tp <- createTracerProvider [processor] emptyTracerProviderOptions+  setGlobalTracerProvider tp+  let tracer = makeTracer tp+        (InstrumentationLibrary+          { libraryName = "http-tower-hs-test"+          , libraryVersion = "0.0.0"+          , librarySchemaUrl = ""+          , libraryAttributes = emptyAttributes+          })+        (TracerOptions Nothing)+  result <- action tracer spanRef+  shutdownTracerProvider tp+  pure result++spec :: Spec+spec = describe "Tracing integration (in-memory exporter)" $ do++  it "creates a span for each request" $ withTestTracer $ \tracer spanRef -> do+    let svc = Service $ \_ -> pure (Right fakeResponse)+        traced = withTracingTracer tracer svc+    req <- HTTP.parseRequest "http://example.com/test"+    _ <- runService traced req+    threadDelay 100_000+    spans <- readIORef spanRef+    length spans `shouldSatisfy` (>= 1)++  it "sets span name to HTTP method only" $ withTestTracer $ \tracer spanRef -> do+    let svc = Service $ \_ -> pure (Right fakeResponse)+        traced = withTracingTracer tracer svc+    req <- HTTP.parseRequest "http://api.example.com/v1/users"+    _ <- runService traced req+    threadDelay 100_000+    spans <- readIORef spanRef+    let names = map spanName spans+    -- Stable convention: span name is just the method+    elem "GET" names `shouldBe` True++  it "records http.request.method attribute" $ withTestTracer $ \tracer spanRef -> do+    let svc = Service $ \_ -> pure (Right fakeResponse)+        traced = withTracingTracer tracer svc+    req <- HTTP.parseRequest "http://example.com/data"+    _ <- runService traced req+    threadDelay 100_000+    spans <- readIORef spanRef+    length spans `shouldSatisfy` (>= 1)+    let attrs = spanAttributes (head spans)+    lookupAttribute attrs "http.request.method" `shouldSatisfy` (/= Nothing)++  it "records server.address and url.full" $ withTestTracer $ \tracer spanRef -> do+    let svc = Service $ \_ -> pure (Right fakeResponse)+        traced = withTracingTracer tracer svc+    req <- HTTP.parseRequest "http://example.com/some/path"+    _ <- runService traced req+    threadDelay 100_000+    spans <- readIORef spanRef+    length spans `shouldSatisfy` (>= 1)+    let attrs = spanAttributes (head spans)+    lookupAttribute attrs "server.address" `shouldSatisfy` (/= Nothing)+    lookupAttribute attrs "url.full" `shouldSatisfy` (/= Nothing)++  it "records http.response.status_code on success" $ withTestTracer $ \tracer spanRef -> do+    let svc = Service $ \_ -> pure (Right fakeResponse)+        traced = withTracingTracer tracer svc+    req <- HTTP.parseRequest "http://example.com/ok"+    _ <- runService traced req+    threadDelay 100_000+    spans <- readIORef spanRef+    length spans `shouldSatisfy` (>= 1)+    let attrs = spanAttributes (head spans)+    lookupAttribute attrs "http.response.status_code" `shouldSatisfy` (/= Nothing)++  it "records error.type on service failure" $ withTestTracer $ \tracer spanRef -> do+    let svc :: Service HTTP.Request HttpResponse+        svc = Service $ \_ -> pure (Left TimeoutError)+        traced = withTracingTracer tracer svc+    req <- HTTP.parseRequest "http://example.com/fail"+    _ <- runService traced req+    threadDelay 100_000+    spans <- readIORef spanRef+    length spans `shouldSatisfy` (>= 1)+    let attrs = spanAttributes (head spans)+    lookupAttribute attrs "error.type" `shouldSatisfy` (/= Nothing)++  it "records error.type on HTTP 5xx" $ withTestTracer $ \tracer spanRef -> do+    let svc = Service $ \_ -> pure (Right fake500Response)+        traced = withTracingTracer tracer svc+    req <- HTTP.parseRequest "http://example.com/error"+    _ <- runService traced req+    threadDelay 100_000+    spans <- readIORef spanRef+    length spans `shouldSatisfy` (>= 1)+    let attrs = spanAttributes (head spans)+    lookupAttribute attrs "error.type" `shouldSatisfy` (/= Nothing)++fakeResponse :: HttpResponse+fakeResponse = HTTP.Response+  { HTTP.responseStatus = HTTP.status200+  , HTTP.responseVersion = HTTP.http11+  , HTTP.responseHeaders = []+  , HTTP.responseBody = ""+  , HTTP.responseCookieJar = HTTP.createCookieJar []+  , HTTP.responseClose' = HTTP.ResponseClose (pure ())+  , HTTP.responseOriginalRequest = error "not used"+  , HTTP.responseEarlyHints = []+  }++fake500Response :: HttpResponse+fake500Response = fakeResponse+  { HTTP.responseStatus = HTTP.internalServerError500+  }

@@ -0,0 +1,118 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.HTTP.Tower.Middleware.TracingSpec (spec) where++import Data.IORef+import qualified Data.ByteString.Lazy as LBS+import qualified Network.HTTP.Client as HTTP+import qualified Network.HTTP.Client.Internal as HTTP+import qualified Network.HTTP.Types as HTTP+import Test.Hspec++import OpenTelemetry.Trace.Core+  ( makeTracer+  , getGlobalTracerProvider+  , InstrumentationLibrary(..)+  , TracerOptions(..)+  )+import OpenTelemetry.Attributes (emptyAttributes)++import Network.HTTP.Tower.Client (HttpResponse)+import Network.HTTP.Tower.Core+import Network.HTTP.Tower.Error+import Network.HTTP.Tower.Middleware.Tracing++spec :: Spec+spec = describe "Tracing middleware" $ do+  -- No OTel SDK configured, so tracing is a no-op — but the middleware+  -- still wraps the service and must be transparent.++  it "passes successful responses through unchanged" $ do+    let svc = Service $ \_ -> pure (Right fakeResponse)+        traced = withTracing svc+    req <- HTTP.parseRequest "http://example.com/test"+    result <- runService traced req+    case result of+      Right resp -> HTTP.responseStatus resp `shouldBe` HTTP.status200+      Left err   -> expectationFailure $ "Expected Right, got: " ++ show err++  it "passes errors through unchanged" $ do+    let svc :: Service HTTP.Request HttpResponse+        svc = Service $ \_ -> pure (Left TimeoutError)+        traced = withTracing svc+    req <- HTTP.parseRequest "http://example.com/fail"+    result <- runService traced req+    case result of+      Left TimeoutError -> pure ()+      other -> expectationFailure $ "Expected Left TimeoutError, got: " ++ show other++  it "calls the inner service exactly once" $ do+    callCount <- newIORef (0 :: Int)+    let svc = Service $ \_ -> do+          modifyIORef' callCount (+ 1)+          pure (Right fakeResponse)+        traced = withTracing svc+    req <- HTTP.parseRequest "http://example.com/once"+    _ <- runService traced req+    readIORef callCount >>= (`shouldBe` 1)++  it "works with withTracingTracer using a specific tracer" $ do+    tp <- getGlobalTracerProvider+    let tracer = makeTracer tp+          (InstrumentationLibrary+            { libraryName = "test"+            , libraryVersion = "0.0.0"+            , librarySchemaUrl = ""+            , libraryAttributes = emptyAttributes+            })+          (TracerOptions Nothing)+        svc = Service $ \_ -> pure (Right fakeResponse)+        traced = withTracingTracer tracer svc+    req <- HTTP.parseRequest "https://api.example.com/v1/data"+    result <- runService traced req+    case result of+      Right resp -> HTTP.responseStatus resp `shouldBe` HTTP.status200+      Left err   -> expectationFailure $ "Expected Right, got: " ++ show err++  it "handles 4xx responses without altering the result" $ do+    let svc = Service $ \_ -> pure (Right fake404Response)+        traced = withTracing svc+    req <- HTTP.parseRequest "http://example.com/notfound"+    result <- runService traced req+    case result of+      Right resp -> HTTP.responseStatus resp `shouldBe` HTTP.notFound404+      Left err   -> expectationFailure $ "Expected Right, got: " ++ show err++  it "composes with the |> operator" $ do+    -- withTracing is now a pure Middleware, so it works directly with |>+    let svc = Service $ \_ -> pure (Right fakeResponse)+        traced = withTracing svc+    req <- HTTP.parseRequest "http://example.com/pipe"+    result <- runService traced req+    case result of+      Right resp -> HTTP.responseStatus resp `shouldBe` HTTP.status200+      Left err   -> expectationFailure $ "Expected Right, got: " ++ show err++fakeResponse :: HttpResponse+fakeResponse = HTTP.Response+  { HTTP.responseStatus = HTTP.status200+  , HTTP.responseVersion = HTTP.http11+  , HTTP.responseHeaders = []+  , HTTP.responseBody = ""+  , HTTP.responseCookieJar = HTTP.createCookieJar []+  , HTTP.responseClose' = HTTP.ResponseClose (pure ())+  , HTTP.responseOriginalRequest = error "not used"+  , HTTP.responseEarlyHints = []+  }++fake404Response :: HttpResponse+fake404Response = fakeResponse+  { HTTP.responseStatus = HTTP.notFound404+  }++instance Eq ServiceError where+  CustomError a      == CustomError b      = a == b+  TimeoutError       == TimeoutError       = True+  CircuitBreakerOpen == CircuitBreakerOpen  = True+  RetryExhausted n _ == RetryExhausted m _ = n == m+  _                  == _                  = False

@@ -0,0 +1,101 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.HTTP.Tower.Middleware.ValidateSpec (spec) where++import qualified Data.ByteString.Lazy as LBS+import qualified Network.HTTP.Client as HTTP+import qualified Network.HTTP.Client.Internal as HTTP+import qualified Network.HTTP.Types as HTTP+import Test.Hspec++import Network.HTTP.Tower.Client (HttpResponse)+import Network.HTTP.Tower.Core+import Network.HTTP.Tower.Error+import Network.HTTP.Tower.Middleware.Validate++spec :: Spec+spec = describe "Validate middleware" $ do+  describe "withValidateStatus" $ do+    it "passes valid status codes" $ do+      let svc = Service $ \_ -> pure (Right (fakeResponseWith HTTP.status200 []))+          validated = withValidateStatus (\c -> c >= 200 && c < 300) svc+      req <- HTTP.parseRequest "http://example.com"+      result <- runService validated req+      case result of+        Right resp -> HTTP.responseStatus resp `shouldBe` HTTP.status200+        Left err -> expectationFailure $ show err++    it "rejects invalid status codes" $ do+      let svc = Service $ \_ -> pure (Right (fakeResponseWith HTTP.internalServerError500 []))+          validated = withValidateStatus (\c -> c >= 200 && c < 300) svc+      req <- HTTP.parseRequest "http://example.com"+      result <- runService validated req+      case result of+        Left (CustomError msg) -> msg `shouldBe` "Unexpected status code: 500"+        other -> expectationFailure $ "Expected CustomError, got: " ++ show other++  describe "withValidateContentType" $ do+    it "passes matching content type" $ do+      let svc = Service $ \_ -> pure (Right (fakeResponseWith HTTP.status200+              [("Content-Type", "application/json; charset=utf-8")]))+          validated = withValidateContentType "application/json" svc+      req <- HTTP.parseRequest "http://example.com"+      result <- runService validated req+      case result of+        Right _ -> pure ()+        Left err -> expectationFailure $ show err++    it "rejects non-matching content type" $ do+      let svc = Service $ \_ -> pure (Right (fakeResponseWith HTTP.status200+              [("Content-Type", "text/html")]))+          validated = withValidateContentType "application/json" svc+      req <- HTTP.parseRequest "http://example.com"+      result <- runService validated req+      case result of+        Left (CustomError _) -> pure ()+        other -> expectationFailure $ "Expected CustomError, got: " ++ show other++    it "rejects missing content type" $ do+      let svc = Service $ \_ -> pure (Right (fakeResponseWith HTTP.status200 []))+          validated = withValidateContentType "application/json" svc+      req <- HTTP.parseRequest "http://example.com"+      result <- runService validated req+      case result of+        Left (CustomError msg) -> msg `shouldBe` "Missing Content-Type header"+        other -> expectationFailure $ "Expected CustomError, got: " ++ show other++  describe "withValidateHeader" $ do+    it "passes when header is present" $ do+      let svc = Service $ \_ -> pure (Right (fakeResponseWith HTTP.status200+              [("X-Request-ID", "abc")]))+          validated = withValidateHeader "X-Request-ID" svc+      req <- HTTP.parseRequest "http://example.com"+      result <- runService validated req+      case result of+        Right _ -> pure ()+        Left err -> expectationFailure $ show err++    it "rejects when header is missing" $ do+      let svc = Service $ \_ -> pure (Right (fakeResponseWith HTTP.status200 []))+          validated = withValidateHeader "X-Request-ID" svc+      req <- HTTP.parseRequest "http://example.com"+      result <- runService validated req+      case result of+        Left (CustomError _) -> pure ()+        other -> expectationFailure $ "Expected CustomError, got: " ++ show other++fakeResponseWith :: HTTP.Status -> [HTTP.Header] -> HttpResponse+fakeResponseWith status hdrs = HTTP.Response+  { HTTP.responseStatus = status+  , HTTP.responseVersion = HTTP.http11+  , HTTP.responseHeaders = hdrs+  , HTTP.responseBody = ""+  , HTTP.responseCookieJar = HTTP.createCookieJar []+  , HTTP.responseClose' = HTTP.ResponseClose (pure ())+  , HTTP.responseOriginalRequest = error "not used"+  , HTTP.responseEarlyHints = []+  }++instance Eq ServiceError where+  CustomError a == CustomError b = a == b+  _ == _ = False

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}