diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,7 @@ +# Changelog + +## 0.1.0.0 — 2026-04-06 + +- Initial release +- `Servant.Tower.Adapter`: bridge tower-hs middleware to servant's `ClientMiddleware` +- Servant-specific middleware: SetHeader, RequestId, Validate, Tracing (OpenTelemetry), Logging 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,12 @@ +# servant-tower-hs + +Use [tower-hs](https://hackage.haskell.org/package/tower-hs) middleware with [servant](https://hackage.haskell.org/package/servant-client) clients. + +Provides an adapter bridging tower-hs middleware to servant's `ClientMiddleware`, plus servant-native middleware: headers, request IDs, response validation, OpenTelemetry tracing, and logging. + +Part of the [tower-hs](https://github.com/jarlah/tower-hs) mono-repo. See the repo README for full documentation and examples. + +## Related packages + +- [tower-hs](https://hackage.haskell.org/package/tower-hs) — Generic service middleware core +- [http-tower-hs](https://hackage.haskell.org/package/http-tower-hs) — HTTP client middleware built on tower-hs diff --git a/servant-tower-hs.cabal b/servant-tower-hs.cabal new file mode 100644 --- /dev/null +++ b/servant-tower-hs.cabal @@ -0,0 +1,92 @@ +cabal-version: 1.18 + +-- This file has been generated from package.yaml by hpack version 0.38.1. +-- +-- see: https://github.com/sol/hpack + +name: servant-tower-hs +version: 0.1.0.0 +synopsis: Use tower-hs middleware with servant clients +description: servant-tower-hs provides an adapter to use tower-hs middleware + (retry, timeout, circuit breaker, etc.) with servant-client's + ClientMiddleware type, plus servant-specific middleware for headers, + request IDs, validation, tracing, and logging. +category: Network, Web +homepage: https://github.com/jarlah/tower-hs#readme +bug-reports: https://github.com/jarlah/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-doc-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/jarlah/tower-hs + +library + exposed-modules: + Servant.Tower.Adapter + Servant.Tower.Middleware.SetHeader + Servant.Tower.Middleware.RequestId + Servant.Tower.Middleware.Validate + Servant.Tower.Middleware.Tracing + Servant.Tower.Middleware.Logging + other-modules: + Paths_servant_tower_hs + hs-source-dirs: + src + build-depends: + base >=4.14 && <5 + , bytestring >=0.11 && <0.13 + , containers >=0.6 && <0.8 + , hs-opentelemetry-api ==0.3.* + , http-types ==0.12.* + , mtl >=2.2 && <2.4 + , servant-client ==0.20.* + , servant-client-core ==0.20.* + , text >=2.0 && <2.2 + , tower-hs >=0.1.0.0 && <0.2 + , uuid ==1.3.* + default-language: Haskell2010 + +test-suite servant-tower-hs-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Servant.Tower.AdapterSpec + Servant.Tower.IntegrationSpec + Servant.Tower.Middleware.TracingIntegrationSpec + Paths_servant_tower_hs + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-tool-depends: + hspec-discover:hspec-discover + build-depends: + base >=4.14 && <5 + , bytestring >=0.11 && <0.13 + , hs-opentelemetry-api ==0.3.* + , hs-opentelemetry-exporter-in-memory >=0.0.1 && <0.1 + , hs-opentelemetry-sdk ==0.1.* + , hspec ==2.11.* + , hspec-discover ==2.11.* + , http-client ==0.7.* + , http-types ==0.12.* + , servant ==0.20.* + , servant-client ==0.20.* + , servant-client-core ==0.20.* + , servant-server ==0.20.* + , servant-tower-hs + , stm ==2.5.* + , text >=2.0 && <2.2 + , tower-hs + , unagi-chan ==0.4.* + , warp >=3.3 && <3.5 + default-language: Haskell2010 diff --git a/src/Servant/Tower/Adapter.hs b/src/Servant/Tower/Adapter.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Tower/Adapter.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE DeriveAnyClass #-} + +-- | +-- Module : Servant.Tower.Adapter +-- Description : Bridge tower-hs middleware to servant's ClientMiddleware +-- License : MIT +-- +-- Adapt tower-hs middleware for use with servant-client. +-- +-- @ +-- import Servant.Tower.Adapter +-- import Tower.Middleware.Retry +-- import Tower.Middleware.Timeout +-- +-- let env = ('withTowerMiddleware' +-- ('withRetry' ('constantBackoff' 3 1.0) . 'withTimeout' 5000)) +-- (mkClientEnv manager baseUrl) +-- runClientM myApiCall env +-- @ +module Servant.Tower.Adapter + ( -- * Converting tower-hs middleware to servant ClientMiddleware + toClientMiddleware + -- * Error mapping + , toClientError + , toServiceError + -- * Convenience + , withTowerMiddleware + ) where + +import Control.Exception (Exception, SomeException, toException) +import Control.Monad.Error.Class (throwError) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Reader (ask) + +import Servant.Client + ( ClientEnv(..) + , ClientError(..) + , ClientM + , runClientM + ) +import Servant.Client.Core (Request, Response) +import Servant.Client.Internal.HttpClient (ClientMiddleware) + +import Tower.Error (ServiceError(..)) +import Tower.Service (Service(..), Middleware) + +-- | Convert a tower-hs 'Middleware' (specialized to servant's Request/Response) +-- into a servant 'ClientMiddleware'. +-- +-- The tower-hs middleware wraps around the servant request pipeline. Errors +-- from the tower-hs middleware are mapped to 'ClientError' via 'toClientError'. +-- +-- @ +-- toClientMiddleware (withRetry (constantBackoff 3 1.0)) +-- @ +toClientMiddleware :: Middleware Request Response -> ClientMiddleware +toClientMiddleware towerMw servantApp req = do + env <- ask + let wrappedService = Service $ \r -> do + result <- runClientM (servantApp r) env + case result of + Left clientErr -> pure (Left (toServiceError clientErr)) + Right resp -> pure (Right resp) + Service towered = towerMw wrappedService + result <- liftIO (towered req) + case result of + Left svcErr -> throwError (toClientError svcErr) + Right resp -> pure resp + +-- | Map a tower-hs 'ServiceError' to a servant 'ClientError'. +toClientError :: ServiceError -> ClientError +toClientError (TransportError e) = ConnectionError e +toClientError TimeoutError = ConnectionError (toException TimeoutEx) +toClientError CircuitBreakerOpen = ConnectionError (toException CircuitBreakerEx) +toClientError (RetryExhausted _ e) = toClientError e +toClientError (CustomError t) = ConnectionError (toException (userError (show t))) + +-- | Map a servant 'ClientError' to a tower-hs 'ServiceError'. +toServiceError :: ClientError -> ServiceError +toServiceError (ConnectionError e) = TransportError e +toServiceError e = TransportError (toException e) + +-- | Apply tower-hs middleware to a servant 'ClientEnv'. +-- +-- @ +-- let env' = withTowerMiddleware (withRetry (constantBackoff 3 1.0)) env +-- runClientM myApiCall env' +-- @ +withTowerMiddleware :: Middleware Request Response -> ClientEnv -> ClientEnv +withTowerMiddleware towerMw env = + env { middleware = toClientMiddleware towerMw . middleware env } + +-- Internal exception types for servant error mapping + +data TimeoutEx = TimeoutEx + deriving (Show, Exception) + +data CircuitBreakerEx = CircuitBreakerEx + deriving (Show, Exception) diff --git a/src/Servant/Tower/Middleware/Logging.hs b/src/Servant/Tower/Middleware/Logging.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Tower/Middleware/Logging.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Servant.Tower.Middleware.Logging +-- Description : Request/response logging for servant requests +-- License : MIT +module Servant.Tower.Middleware.Logging + ( withLogging + , withLoggingCustom + ) where + +import Data.Text (Text, pack) +import Data.Text.Encoding (decodeUtf8) +import Network.HTTP.Types.Status (statusCode) + +import qualified Tower.Middleware.Logging as Generic +import Servant.Client.Core (Request, Response, requestMethod, responseStatusCode) +import Tower.Service (Middleware) +import Tower.Error (ServiceError, displayError) + +-- | Logging middleware with a default servant-aware formatter. +-- Logs method, status code, and duration. +withLogging :: (Text -> IO ()) -> Middleware Request Response +withLogging = Generic.withLogging servantFormatter + +-- | Logging middleware with a custom formatter. +withLoggingCustom + :: (Request -> Either ServiceError Response -> Double -> Text) + -> (Text -> IO ()) + -> Middleware Request Response +withLoggingCustom = Generic.withLogging + +servantFormatter :: Request -> Either ServiceError Response -> Double -> Text +servantFormatter req result duration = + let method = decodeUtf8 (requestMethod req) + status = case result of + Right resp -> pack $ show (statusCode (responseStatusCode resp)) + Left err -> "ERR: " <> displayError err + dur = pack $ show (round (duration * 1000) :: Int) <> "ms" + in method <> " -> " <> status <> " (" <> dur <> ")" diff --git a/src/Servant/Tower/Middleware/RequestId.hs b/src/Servant/Tower/Middleware/RequestId.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Tower/Middleware/RequestId.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Servant.Tower.Middleware.RequestId +-- Description : Generate unique request IDs for servant requests +-- License : MIT +module Servant.Tower.Middleware.RequestId + ( withRequestId + , withRequestIdHeader + ) where + +import Data.ByteString.Char8 (pack) +import Data.UUID (toString) +import Data.UUID.V4 (nextRandom) +import qualified Data.Sequence as Seq +import Network.HTTP.Types.Header (HeaderName) + +import Servant.Client.Core (Request, Response, requestHeaders) +import Tower.Service (Middleware) +import Tower.Middleware.Transform (withMapRequest) + +-- | Add a unique @X-Request-ID@ header with a UUID v4 to every request. +withRequestId :: Middleware Request Response +withRequestId = withRequestIdHeader "X-Request-ID" + +-- | Add a unique request ID using a custom header name. +withRequestIdHeader :: HeaderName -> Middleware Request Response +withRequestIdHeader headerName = withMapRequest $ \req -> do + uuid <- nextRandom + let reqId = pack (toString uuid) + pure req { requestHeaders = requestHeaders req Seq.|> (headerName, reqId) } diff --git a/src/Servant/Tower/Middleware/SetHeader.hs b/src/Servant/Tower/Middleware/SetHeader.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Tower/Middleware/SetHeader.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Servant.Tower.Middleware.SetHeader +-- Description : Add headers to every servant request +-- License : MIT +module Servant.Tower.Middleware.SetHeader + ( withHeader + , withHeaders + , withBearerAuth + , withUserAgent + ) where + +import Data.ByteString (ByteString) +import qualified Data.Sequence as Seq +import Network.HTTP.Types.Header (HeaderName) + +import Servant.Client.Core (Request, Response, requestHeaders) +import Tower.Service (Middleware) +import Tower.Middleware.Transform (withMapRequestPure) + +-- | Add a single header to every request. +withHeader :: HeaderName -> ByteString -> Middleware Request Response +withHeader name value = withMapRequestPure $ \req -> + req { requestHeaders = requestHeaders req Seq.|> (name, value) } + +-- | Add multiple headers to every request. +withHeaders :: [(HeaderName, ByteString)] -> Middleware Request Response +withHeaders hdrs = withMapRequestPure $ \req -> + req { requestHeaders = requestHeaders req <> Seq.fromList hdrs } + +-- | Add a @Authorization: Bearer \@ header. +withBearerAuth :: ByteString -> Middleware Request Response +withBearerAuth token = withHeader "Authorization" ("Bearer " <> token) + +-- | Set the @User-Agent@ header. +withUserAgent :: ByteString -> Middleware Request Response +withUserAgent = withHeader "User-Agent" diff --git a/src/Servant/Tower/Middleware/Tracing.hs b/src/Servant/Tower/Middleware/Tracing.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Tower/Middleware/Tracing.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Servant.Tower.Middleware.Tracing +-- Description : OpenTelemetry tracing for servant requests +-- License : MIT +module Servant.Tower.Middleware.Tracing + ( withTracing + , withTracingTracer + , servantTracingConfig + ) where + +import Control.Monad (when) +import Data.Text (Text, pack) +import Data.Text.Encoding (decodeUtf8) +import qualified Data.Version as V +import Network.HTTP.Types.Status (statusCode) +import qualified Paths_servant_tower_hs as Pkg + +import OpenTelemetry.Attributes (emptyAttributes) +import OpenTelemetry.Trace.Core + ( Tracer + , InstrumentationLibrary(..) + , TracerOptions(..) + , SpanKind(..) + , SpanStatus(..) + , makeTracer + , getGlobalTracerProvider + , addAttribute + , setStatus + ) + +import Servant.Client.Core (Request, Response, requestMethod, responseStatusCode) +import Tower.Service (Service(..), Middleware) +import Tower.Middleware.Tracing (TracingConfig(..), defaultTracingConfig, withTracingConfig) + +-- | Tracing middleware using the global TracerProvider. +withTracing :: Middleware Request Response +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. +withTracingTracer :: Tracer -> Middleware Request Response +withTracingTracer tracer = withTracingConfig tracer servantTracingConfig + +-- | Tracing config with HTTP semantic conventions for servant types. +servantTracingConfig :: TracingConfig Request Response +servantTracingConfig = (defaultTracingConfig "") + { tracingSpanName = decodeUtf8 . requestMethod + , tracingSpanKind = Client + , tracingReqAttrs = \req s -> do + addAttribute s "http.request.method" (decodeUtf8 (requestMethod req)) + , tracingResAttrs = \resp s -> do + let code = statusCode (responseStatusCode 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") + } + +instrumentationLibrary :: InstrumentationLibrary +instrumentationLibrary = InstrumentationLibrary + { libraryName = "servant-tower-hs" + , libraryVersion = pack (V.showVersion Pkg.version) + , librarySchemaUrl = "" + , libraryAttributes = emptyAttributes + } diff --git a/src/Servant/Tower/Middleware/Validate.hs b/src/Servant/Tower/Middleware/Validate.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Tower/Middleware/Validate.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Servant.Tower.Middleware.Validate +-- Description : Response validation middleware for servant +-- License : MIT +module Servant.Tower.Middleware.Validate + ( withValidateStatus + , withValidateHeader + , withValidateContentType + ) where + +import Data.ByteString (ByteString, isInfixOf) +import Data.Text (pack) +import qualified Data.Foldable as F +import Network.HTTP.Types.Header (HeaderName) +import Network.HTTP.Types.Status (statusCode) + +import Servant.Client.Core (Request, Response, responseStatusCode, responseHeaders) +import Tower.Service (Middleware) +import Tower.Middleware.Validate (withValidate) + +-- | Validate the response status code. Returns a 'CustomError' if the +-- predicate returns 'False'. +withValidateStatus :: (Int -> Bool) -> Middleware Request Response +withValidateStatus isValid = withValidate $ \resp -> + let code = statusCode (responseStatusCode resp) + in if isValid code + then Nothing + else Just ("Unexpected status code: " <> pack (show code)) + +-- | Validate that a specific response header is present. +withValidateHeader :: HeaderName -> Middleware Request Response +withValidateHeader headerName = withValidate $ \resp -> + if F.any (\(n, _) -> n == headerName) (responseHeaders resp) + then Nothing + else Just ("Missing required header: " <> pack (show headerName)) + +-- | Validate the @Content-Type@ header contains the expected value. +-- +-- Uses substring matching, so @\"application\/json\"@ matches +-- @\"application\/json; charset=utf-8\"@. +withValidateContentType :: ByteString -> Middleware Request Response +withValidateContentType expected = withValidate $ \resp -> + let ct = F.find (\(n, _) -> n == "Content-Type") (responseHeaders resp) + in case ct of + Just (_, v) | expected `isInfixOf` v -> Nothing + Just (_, v) -> Just ("Unexpected Content-Type: " <> pack (show v)) + Nothing -> Just "Missing Content-Type header" diff --git a/test/Servant/Tower/AdapterSpec.hs b/test/Servant/Tower/AdapterSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/Tower/AdapterSpec.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Servant.Tower.AdapterSpec (spec) where + +import Control.Exception (toException) +import Test.Hspec + +import Servant.Client (ClientError(..)) +import Tower.Error (ServiceError(..)) +import Tower.Error.Testing () +import Servant.Tower.Adapter (toClientError, toServiceError) + +spec :: Spec +spec = describe "Servant.Tower.Adapter" $ do + describe "toServiceError" $ do + it "maps ConnectionError to TransportError" $ do + let clientErr = ConnectionError (toException (userError "connection refused")) + svcErr = toServiceError clientErr + case svcErr of + TransportError _ -> pure () + other -> expectationFailure $ "Expected TransportError, got: " ++ show other + + describe "toClientError" $ do + it "maps TimeoutError to ConnectionError" $ do + let svcErr = TimeoutError + clientErr = toClientError svcErr + case clientErr of + ConnectionError _ -> pure () + other -> expectationFailure $ "Expected ConnectionError, got: " ++ show other + + it "maps CircuitBreakerOpen to ConnectionError" $ do + let svcErr = CircuitBreakerOpen + clientErr = toClientError svcErr + case clientErr of + ConnectionError _ -> pure () + other -> expectationFailure $ "Expected ConnectionError, got: " ++ show other + + it "maps CustomError to ConnectionError" $ do + let svcErr = CustomError "test error" + clientErr = toClientError svcErr + case clientErr of + ConnectionError _ -> pure () + other -> expectationFailure $ "Expected ConnectionError, got: " ++ show other + + it "unwraps RetryExhausted" $ do + let svcErr = RetryExhausted 3 TimeoutError + clientErr = toClientError svcErr + case clientErr of + ConnectionError _ -> pure () + other -> expectationFailure $ "Expected ConnectionError, got: " ++ show other diff --git a/test/Servant/Tower/IntegrationSpec.hs b/test/Servant/Tower/IntegrationSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/Tower/IntegrationSpec.hs @@ -0,0 +1,308 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +module Servant.Tower.IntegrationSpec (spec) where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.STM (newTVarIO, readTVar, TVar, modifyTVar', atomically) +import Control.Monad.IO.Class (liftIO) +import Data.IORef +import Data.Proxy (Proxy(..)) +import Data.Text (Text, isInfixOf) +import Network.HTTP.Client (newManager, defaultManagerSettings) +import Network.Wai.Handler.Warp (testWithApplication) +import Servant +import Servant.Client +import Test.Hspec + +import Servant.Tower.Adapter (withTowerMiddleware) +import qualified Servant.Tower.Middleware.Logging as STL +import qualified Servant.Tower.Middleware.SetHeader as STS +import qualified Servant.Tower.Middleware.Validate as STV +import Tower.Middleware.CircuitBreaker +import Tower.Middleware.Filter +import Tower.Middleware.Hedge +import qualified Tower.Middleware.Logging as TL +import qualified Tower.Middleware.Tracing +import Tower.Middleware.Retry +import Tower.Middleware.Timeout + +import OpenTelemetry.Attributes (emptyAttributes) +import OpenTelemetry.Trace.Core (InstrumentationLibrary(..)) + +-- --------------------------------------------------------------------------- +-- Test API +-- --------------------------------------------------------------------------- + +type TestAPI = + "hello" :> Get '[JSON] String + :<|> "slow" :> Get '[JSON] String + :<|> "flaky" :> Get '[JSON] String + :<|> "fail500" :> Get '[JSON] String + +testServer :: TVar Int -> Server TestAPI +testServer callCount = + helloHandler + :<|> slowHandler + :<|> flakyHandler callCount + :<|> fail500Handler + +helloHandler :: Handler String +helloHandler = pure "hello" + +slowHandler :: Handler String +slowHandler = do + liftIO $ threadDelay 2_000_000 -- 2 seconds + pure "slow" + +flakyHandler :: TVar Int -> Handler String +flakyHandler callCount = do + n <- liftIO $ atomically $ do + modifyTVar' callCount (+ 1) + readTVar callCount + if n <= 2 + then throwError err500 { errBody = "flaky failure" } + else pure "recovered" + +fail500Handler :: Handler String +fail500Handler = throwError err500 { errBody = "always fails" } + +testApp :: TVar Int -> Application +testApp callCount = serve (Proxy :: Proxy TestAPI) (testServer callCount) + +-- --------------------------------------------------------------------------- +-- Client functions +-- --------------------------------------------------------------------------- + +helloClient :: ClientM String +slowClient :: ClientM String +flakyClient :: ClientM String +fail500Client :: ClientM String +helloClient :<|> slowClient :<|> flakyClient :<|> fail500Client = + client (Proxy :: Proxy TestAPI) + +-- --------------------------------------------------------------------------- +-- Helpers +-- --------------------------------------------------------------------------- + +withTestServer :: (Int -> IO a) -> IO a +withTestServer action = do + callCount <- newTVarIO 0 + testWithApplication (pure (testApp callCount)) action + +runWithMiddleware :: Int -> ClientM a -> (ClientEnv -> ClientEnv) -> IO (Either ClientError a) +runWithMiddleware port action applyMw = do + manager <- newManager defaultManagerSettings + baseUrl' <- parseBaseUrl $ "http://localhost:" ++ show port + let env = applyMw (mkClientEnv manager baseUrl') + runClientM action env + +runPlain :: Int -> ClientM a -> IO (Either ClientError a) +runPlain port action = runWithMiddleware port action id + +-- --------------------------------------------------------------------------- +-- Tests +-- --------------------------------------------------------------------------- + +spec :: Spec +spec = describe "Servant.Tower integration" $ around withTestServer $ do + + -- Baseline: middleware adapter does not break normal requests + describe "baseline (no middleware)" $ do + it "calls a simple endpoint" $ \port -> do + result <- runPlain port helloClient + result `shouldBe` Right "hello" + + -- Retry middleware + describe "withRetry" $ do + it "retries flaky endpoint and eventually succeeds" $ \port -> do + result <- runWithMiddleware port flakyClient $ + withTowerMiddleware (withRetry (constantBackoff 3 0)) + result `shouldBe` Right "recovered" + + it "exhausts retries on permanently failing endpoint" $ \port -> do + result <- runWithMiddleware port fail500Client $ + withTowerMiddleware (withRetry (constantBackoff 2 0)) + case result of + Left _ -> pure () + Right _ -> expectationFailure "Expected failure after retry exhaustion" + + -- Timeout middleware + describe "withTimeout" $ do + it "passes fast requests through" $ \port -> do + result <- runWithMiddleware port helloClient $ + withTowerMiddleware (withTimeout 5000) + result `shouldBe` Right "hello" + + it "times out slow requests" $ \port -> do + result <- runWithMiddleware port slowClient $ + withTowerMiddleware (withTimeout 500) -- 500ms, server takes 2s + case result of + Left _ -> pure () + Right _ -> expectationFailure "Expected timeout error" + + -- Circuit breaker middleware + describe "withCircuitBreaker" $ do + it "trips open after repeated failures and rejects fast" $ \port -> do + breaker <- newCircuitBreaker + let config = CircuitBreakerConfig { cbFailureThreshold = 2, cbCooldownPeriod = 10 } + mw = withTowerMiddleware (withCircuitBreaker config breaker) + + -- Two failures trip the breaker + _ <- runWithMiddleware port fail500Client mw + _ <- runWithMiddleware port fail500Client mw + getCircuitBreakerState breaker >>= (`shouldBe` Open) + + -- Third call should be rejected immediately by circuit breaker + result <- runWithMiddleware port fail500Client mw + case result of + Left _ -> pure () + Right _ -> expectationFailure "Expected circuit breaker rejection" + + -- Composed middleware stack + describe "composed middleware" $ do + it "retry + timeout works together on fast endpoint" $ \port -> do + result <- runWithMiddleware port helloClient $ + withTowerMiddleware + ( withRetry (constantBackoff 2 0) + . withTimeout 5000 + ) + result `shouldBe` Right "hello" + + it "timeout fires before retry can succeed on slow endpoint" $ \port -> do + result <- runWithMiddleware port slowClient $ + withTowerMiddleware + ( withRetry (constantBackoff 2 0) + . withTimeout 500 + ) + case result of + Left _ -> pure () + Right _ -> expectationFailure "Expected timeout through retry" + + it "retry + circuit breaker compose correctly" $ \port -> do + breaker <- newCircuitBreaker + let config = CircuitBreakerConfig { cbFailureThreshold = 5, cbCooldownPeriod = 10 } + result <- runWithMiddleware port flakyClient $ + withTowerMiddleware + ( withRetry (constantBackoff 3 0) + . withCircuitBreaker config breaker + ) + result `shouldBe` Right "recovered" + -- Breaker should be closed since it recovered + getCircuitBreakerState breaker >>= (`shouldBe` Closed) + + -- Filter middleware + describe "withFilter" $ do + it "passes requests that match the predicate" $ \port -> do + result <- runWithMiddleware port helloClient $ + withTowerMiddleware (withFilter (const True)) + result `shouldBe` Right "hello" + + it "rejects requests that don't match the predicate" $ \port -> do + result <- runWithMiddleware port helloClient $ + withTowerMiddleware (withFilter (const False)) + case result of + Left _ -> pure () + Right _ -> expectationFailure "Expected filter rejection" + + -- Hedge middleware + describe "withHedge" $ do + it "returns result for fast endpoint" $ \port -> do + result <- runWithMiddleware port helloClient $ + withTowerMiddleware (withHedge 500) + result `shouldBe` Right "hello" + + -- Full middleware stack: generic + servant-specific combined + describe "full middleware stack" $ do + it "composes generic tower-hs and servant-specific middleware together" $ \port -> do + logRef <- newIORef ([] :: [Text]) + breaker <- newCircuitBreaker + let config = CircuitBreakerConfig { cbFailureThreshold = 10, cbCooldownPeriod = 30 } + result <- runWithMiddleware port helloClient $ + withTowerMiddleware + ( -- Generic tower-hs middleware + withRetry (exponentialBackoff 2 0.1 2.0) + . withTimeout 5000 + . withCircuitBreaker config breaker + -- Servant-specific middleware + . STS.withBearerAuth "my-token" + . STS.withUserAgent "test-agent/1.0" + . STS.withHeader "X-Custom" "value" + . STV.withValidateStatus (\c -> c >= 200 && c < 300) + . STL.withLogging (\msg -> modifyIORef' logRef (msg :)) + ) + result `shouldBe` Right "hello" + getCircuitBreakerState breaker >>= (`shouldBe` Closed) + -- Verify logging happened + logs <- readIORef logRef + length logs `shouldBe` 1 + + -- ----------------------------------------------------------------------- + -- Servant-specific middleware + -- ----------------------------------------------------------------------- + + -- SetHeader middleware + describe "Servant.Tower.Middleware.SetHeader" $ do + it "adds headers without breaking requests" $ \port -> do + result <- runWithMiddleware port helloClient $ + withTowerMiddleware + ( STS.withBearerAuth "my-token" + . STS.withUserAgent "test-agent/1.0" + . STS.withHeader "X-Custom" "value" + ) + result `shouldBe` Right "hello" + + -- Validate middleware + describe "Servant.Tower.Middleware.Validate" $ do + it "passes valid status codes" $ \port -> do + result <- runWithMiddleware port helloClient $ + withTowerMiddleware (STV.withValidateStatus (\c -> c >= 200 && c < 300)) + result `shouldBe` Right "hello" + + it "rejects invalid status codes" $ \port -> do + result <- runWithMiddleware port fail500Client $ + withTowerMiddleware (STV.withValidateStatus (\c -> c >= 200 && c < 300)) + case result of + Left _ -> pure () + Right _ -> expectationFailure "Expected validation failure" + + -- Logging middleware + describe "Servant.Tower.Middleware.Logging" $ do + it "logs successful requests" $ \port -> do + logRef <- newIORef ([] :: [Text]) + let logger msg = modifyIORef' logRef (msg :) + result <- runWithMiddleware port helloClient $ + withTowerMiddleware (STL.withLogging logger) + result `shouldBe` Right "hello" + logs <- readIORef logRef + length logs `shouldBe` 1 + isInfixOf "GET" (head logs) `shouldBe` True + + it "logs with generic formatter" $ \port -> do + logRef <- newIORef ([] :: [Text]) + let logger msg = modifyIORef' logRef (msg :) + formatter _ _ _ = "custom-log" + result <- runWithMiddleware port helloClient $ + withTowerMiddleware (TL.withLogging formatter logger) + result `shouldBe` Right "hello" + logs <- readIORef logRef + head logs `shouldBe` "custom-log" + + -- Tracing middleware (no-op without SDK, but must be transparent) + describe "Servant.Tower.Middleware.Tracing" $ do + it "passes requests through transparently" $ \port -> do + -- Import locally to avoid name clash + result <- runWithMiddleware port helloClient $ + withTowerMiddleware + (Tower.Middleware.Tracing.withTracingGlobal testLib (Tower.Middleware.Tracing.defaultTracingConfig "test")) + result `shouldBe` Right "hello" + +testLib :: InstrumentationLibrary +testLib = InstrumentationLibrary + { libraryName = "servant-tower-hs-test" + , libraryVersion = "0.0.0" + , librarySchemaUrl = "" + , libraryAttributes = emptyAttributes + } diff --git a/test/Servant/Tower/Middleware/TracingIntegrationSpec.hs b/test/Servant/Tower/Middleware/TracingIntegrationSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/Tower/Middleware/TracingIntegrationSpec.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +module Servant.Tower.Middleware.TracingIntegrationSpec (spec) where + +import Control.Concurrent (threadDelay) +import Data.IORef +import Data.Proxy (Proxy(..)) +import Network.HTTP.Client (newManager, defaultManagerSettings) +import Network.Wai.Handler.Warp (testWithApplication) +import Servant +import Servant.Client +import Test.Hspec + +import OpenTelemetry.Attributes (emptyAttributes, lookupAttribute) +import OpenTelemetry.Trace.Core + ( Tracer + , makeTracer + , InstrumentationLibrary(..) + , TracerOptions(..) + , ImmutableSpan(..) + , setGlobalTracerProvider + , shutdownTracerProvider + ) +import OpenTelemetry.Trace + ( createTracerProvider + , emptyTracerProviderOptions + ) +import OpenTelemetry.Exporter.InMemory (inMemoryListExporter) + +import Servant.Tower.Adapter (withTowerMiddleware) +import Servant.Tower.Middleware.Tracing (withTracingTracer) + +-- --------------------------------------------------------------------------- +-- Test API +-- --------------------------------------------------------------------------- + +type TestAPI = + "ok" :> Get '[JSON] String + :<|> "fail500" :> Get '[JSON] String + +testServer :: Server TestAPI +testServer = okHandler :<|> fail500Handler + +okHandler :: Handler String +okHandler = pure "ok" + +fail500Handler :: Handler String +fail500Handler = throwError err500 { errBody = "server error" } + +testApp :: Application +testApp = serve (Proxy :: Proxy TestAPI) testServer + +okClient :: ClientM String +fail500Client' :: ClientM String +okClient :<|> fail500Client' = client (Proxy :: Proxy TestAPI) + +-- --------------------------------------------------------------------------- +-- Helpers +-- --------------------------------------------------------------------------- + +withTestServer :: (Int -> IO a) -> IO a +withTestServer = testWithApplication (pure testApp) + +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 = "servant-tower-hs-test" + , libraryVersion = "0.0.0" + , librarySchemaUrl = "" + , libraryAttributes = emptyAttributes + }) + (TracerOptions Nothing) + result <- action tracer spanRef + shutdownTracerProvider tp + pure result + +runWithTracer :: Tracer -> Int -> ClientM a -> IO (Either ClientError a) +runWithTracer tracer port action = do + manager <- newManager defaultManagerSettings + baseUrl' <- parseBaseUrl $ "http://localhost:" ++ show port + let env = withTowerMiddleware (withTracingTracer tracer) (mkClientEnv manager baseUrl') + runClientM action env + +-- --------------------------------------------------------------------------- +-- Tests +-- --------------------------------------------------------------------------- + +spec :: Spec +spec = describe "Servant tracing integration (in-memory exporter)" $ around withTestServer $ do + + it "creates a span for each request" $ \port -> withTestTracer $ \tracer spanRef -> do + _ <- runWithTracer tracer port okClient + threadDelay 100_000 + spans <- readIORef spanRef + length spans `shouldSatisfy` (>= 1) + + it "sets span name to HTTP method" $ \port -> withTestTracer $ \tracer spanRef -> do + _ <- runWithTracer tracer port okClient + threadDelay 100_000 + spans <- readIORef spanRef + let names = map spanName spans + elem "GET" names `shouldBe` True + + it "records http.request.method attribute" $ \port -> withTestTracer $ \tracer spanRef -> do + _ <- runWithTracer tracer port okClient + threadDelay 100_000 + spans <- readIORef spanRef + length spans `shouldSatisfy` (>= 1) + let attrs = spanAttributes (head spans) + lookupAttribute attrs "http.request.method" `shouldSatisfy` (/= Nothing) + + it "records http.response.status_code on success" $ \port -> withTestTracer $ \tracer spanRef -> do + _ <- runWithTracer tracer port okClient + 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" $ \port -> withTestTracer $ \tracer spanRef -> do + _ <- runWithTracer tracer port fail500Client' + threadDelay 100_000 + spans <- readIORef spanRef + length spans `shouldSatisfy` (>= 1) + let attrs = spanAttributes (head spans) + lookupAttribute attrs "error.type" `shouldSatisfy` (/= Nothing) 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 #-}