servant-tower-hs (empty) → 0.1.0.0

raw patch · 14 files changed

+950/−0 lines, 14 filesdep +basedep +bytestringdep +containers

Dependencies added: base, bytestring, containers, hs-opentelemetry-api, hs-opentelemetry-exporter-in-memory, hs-opentelemetry-sdk, hspec, hspec-discover, http-client, http-types, mtl, servant, servant-client, servant-client-core, servant-server, servant-tower-hs, stm, text, tower-hs, unagi-chan, uuid, warp

Files

• CHANGELOG.md +7/−0
• LICENSE +21/−0
• README.md +12/−0
• servant-tower-hs.cabal +92/−0
• src/Servant/Tower/Adapter.hs +99/−0
• src/Servant/Tower/Middleware/Logging.hs +40/−0
• src/Servant/Tower/Middleware/RequestId.hs +31/−0
• src/Servant/Tower/Middleware/SetHeader.hs +38/−0
• src/Servant/Tower/Middleware/Tracing.hs +69/−0
• src/Servant/Tower/Middleware/Validate.hs +49/−0
• test/Servant/Tower/AdapterSpec.hs +50/−0
• test/Servant/Tower/IntegrationSpec.hs +308/−0
• test/Servant/Tower/Middleware/TracingIntegrationSpec.hs +133/−0
• test/Spec.hs +1/−0

@@ -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

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

@@ -0,0 +1,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

@@ -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

@@ -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)

@@ -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 <> ")"

@@ -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) }

@@ -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 \<token\>@ 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"

@@ -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+  }

@@ -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"

@@ -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

@@ -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+  }

@@ -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)

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