diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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). diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 diff --git a/http-tower-hs.cabal b/http-tower-hs.cabal new file mode 100644 --- /dev/null +++ b/http-tower-hs.cabal @@ -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 diff --git a/src/Network/HTTP/Tower.hs b/src/Network/HTTP/Tower.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Tower.hs @@ -0,0 +1,112 @@ +-- | +-- Module : Network.HTTP.Tower +-- Description : Composable HTTP client middleware for Haskell +-- License : MIT +-- +-- Inspired by Rust's 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 diff --git a/src/Network/HTTP/Tower/Client.hs b/src/Network/HTTP/Tower/Client.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Tower/Client.hs @@ -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 |> diff --git a/src/Network/HTTP/Tower/Core.hs b/src/Network/HTTP/Tower/Core.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Tower/Core.hs @@ -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 diff --git a/src/Network/HTTP/Tower/Error.hs b/src/Network/HTTP/Tower/Error.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Tower/Error.hs @@ -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 diff --git a/src/Network/HTTP/Tower/Middleware/CircuitBreaker.hs b/src/Network/HTTP/Tower/Middleware/CircuitBreaker.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Tower/Middleware/CircuitBreaker.hs @@ -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 diff --git a/src/Network/HTTP/Tower/Middleware/Filter.hs b/src/Network/HTTP/Tower/Middleware/Filter.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Tower/Middleware/Filter.hs @@ -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 diff --git a/src/Network/HTTP/Tower/Middleware/FollowRedirect.hs b/src/Network/HTTP/Tower/Middleware/FollowRedirect.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Tower/Middleware/FollowRedirect.hs @@ -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] diff --git a/src/Network/HTTP/Tower/Middleware/Hedge.hs b/src/Network/HTTP/Tower/Middleware/Hedge.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Tower/Middleware/Hedge.hs @@ -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 diff --git a/src/Network/HTTP/Tower/Middleware/Logging.hs b/src/Network/HTTP/Tower/Middleware/Logging.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Tower/Middleware/Logging.hs @@ -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 <> ")" diff --git a/src/Network/HTTP/Tower/Middleware/RequestId.hs b/src/Network/HTTP/Tower/Middleware/RequestId.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Tower/Middleware/RequestId.hs @@ -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' diff --git a/src/Network/HTTP/Tower/Middleware/Retry.hs b/src/Network/HTTP/Tower/Middleware/Retry.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Tower/Middleware/Retry.hs @@ -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) diff --git a/src/Network/HTTP/Tower/Middleware/SetHeader.hs b/src/Network/HTTP/Tower/Middleware/SetHeader.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Tower/Middleware/SetHeader.hs @@ -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 \@ 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" diff --git a/src/Network/HTTP/Tower/Middleware/TestDouble.hs b/src/Network/HTTP/Tower/Middleware/TestDouble.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Tower/Middleware/TestDouble.hs @@ -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 diff --git a/src/Network/HTTP/Tower/Middleware/Timeout.hs b/src/Network/HTTP/Tower/Middleware/Timeout.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Tower/Middleware/Timeout.hs @@ -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 diff --git a/src/Network/HTTP/Tower/Middleware/Tracing.hs b/src/Network/HTTP/Tower/Middleware/Tracing.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Tower/Middleware/Tracing.hs @@ -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 diff --git a/src/Network/HTTP/Tower/Middleware/Validate.hs b/src/Network/HTTP/Tower/Middleware/Validate.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Tower/Middleware/Validate.hs @@ -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) diff --git a/test/Network/HTTP/Tower/ClientTLSSpec.hs b/test/Network/HTTP/Tower/ClientTLSSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/HTTP/Tower/ClientTLSSpec.hs @@ -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) diff --git a/test/Network/HTTP/Tower/CoreSpec.hs b/test/Network/HTTP/Tower/CoreSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/HTTP/Tower/CoreSpec.hs @@ -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 diff --git a/test/Network/HTTP/Tower/Middleware/CircuitBreakerSpec.hs b/test/Network/HTTP/Tower/Middleware/CircuitBreakerSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/HTTP/Tower/Middleware/CircuitBreakerSpec.hs @@ -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 diff --git a/test/Network/HTTP/Tower/Middleware/FilterSpec.hs b/test/Network/HTTP/Tower/Middleware/FilterSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/HTTP/Tower/Middleware/FilterSpec.hs @@ -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 diff --git a/test/Network/HTTP/Tower/Middleware/FollowRedirectSpec.hs b/test/Network/HTTP/Tower/Middleware/FollowRedirectSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/HTTP/Tower/Middleware/FollowRedirectSpec.hs @@ -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 diff --git a/test/Network/HTTP/Tower/Middleware/HedgeSpec.hs b/test/Network/HTTP/Tower/Middleware/HedgeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/HTTP/Tower/Middleware/HedgeSpec.hs @@ -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 diff --git a/test/Network/HTTP/Tower/Middleware/LoggingSpec.hs b/test/Network/HTTP/Tower/Middleware/LoggingSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/HTTP/Tower/Middleware/LoggingSpec.hs @@ -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 = [] + } diff --git a/test/Network/HTTP/Tower/Middleware/RequestIdSpec.hs b/test/Network/HTTP/Tower/Middleware/RequestIdSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/HTTP/Tower/Middleware/RequestIdSpec.hs @@ -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" diff --git a/test/Network/HTTP/Tower/Middleware/RetrySpec.hs b/test/Network/HTTP/Tower/Middleware/RetrySpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/HTTP/Tower/Middleware/RetrySpec.hs @@ -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 diff --git a/test/Network/HTTP/Tower/Middleware/SetHeaderSpec.hs b/test/Network/HTTP/Tower/Middleware/SetHeaderSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/HTTP/Tower/Middleware/SetHeaderSpec.hs @@ -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" diff --git a/test/Network/HTTP/Tower/Middleware/TestDoubleSpec.hs b/test/Network/HTTP/Tower/Middleware/TestDoubleSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/HTTP/Tower/Middleware/TestDoubleSpec.hs @@ -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 = [] + } diff --git a/test/Network/HTTP/Tower/Middleware/TimeoutSpec.hs b/test/Network/HTTP/Tower/Middleware/TimeoutSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/HTTP/Tower/Middleware/TimeoutSpec.hs @@ -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 diff --git a/test/Network/HTTP/Tower/Middleware/TracingDockerSpec.hs b/test/Network/HTTP/Tower/Middleware/TracingDockerSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/HTTP/Tower/Middleware/TracingDockerSpec.hs @@ -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 = [] + } diff --git a/test/Network/HTTP/Tower/Middleware/TracingIntegrationSpec.hs b/test/Network/HTTP/Tower/Middleware/TracingIntegrationSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/HTTP/Tower/Middleware/TracingIntegrationSpec.hs @@ -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 + } diff --git a/test/Network/HTTP/Tower/Middleware/TracingSpec.hs b/test/Network/HTTP/Tower/Middleware/TracingSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/HTTP/Tower/Middleware/TracingSpec.hs @@ -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 diff --git a/test/Network/HTTP/Tower/Middleware/ValidateSpec.hs b/test/Network/HTTP/Tower/Middleware/ValidateSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/HTTP/Tower/Middleware/ValidateSpec.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}