packages feed

tower-hs (empty) → 0.1.0.0

raw patch · 30 files changed

+1758/−0 lines, 30 filesdep +QuickCheckdep +asyncdep +base

Dependencies added: QuickCheck, async, base, bytestring, hedis, hs-opentelemetry-api, hspec, hspec-discover, process, stm, testcontainers, text, time, tower-hs

Files

+ CHANGELOG.md view
@@ -0,0 +1,8 @@+# Changelog++## 0.1.0.0 — 2026-04-06++- Initial release+- Core `Service`/`Middleware` abstractions+- Middleware: Retry, Timeout, CircuitBreaker, Filter, Hedge, Logging, Tracing (OpenTelemetry), Validate, Transform, TestDouble+- `Tower.Error.Testing` module with shared `Eq ServiceError` instance
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,12 @@+# tower-hs++Composable service middleware for Haskell, inspired by Rust's [Tower](https://docs.rs/tower/latest/tower/).++Generic `Service`/`Middleware` abstractions with protocol-agnostic middleware: retry, timeout, circuit breaker, filter, hedge, tracing (OpenTelemetry), logging, validation, request transformation, and test doubles.++Part of the [tower-hs](https://github.com/jarlah/tower-hs) mono-repo. See the repo README for full documentation and examples.++## Related packages++- [http-tower-hs](https://hackage.haskell.org/package/http-tower-hs) — HTTP client middleware built on tower-hs+- [servant-tower-hs](https://hackage.haskell.org/package/servant-tower-hs) — Servant client middleware built on tower-hs
+ src/Tower.hs view
@@ -0,0 +1,80 @@+-- |+-- Module      : Tower+-- Description : Composable service middleware for Haskell+-- License     : MIT+--+-- Inspired by Rust's <https://docs.rs/tower/latest/tower/ Tower> crate.+-- Build composable middleware stacks for any service type.+--+-- @+-- import Tower+--+-- -- Define a service+-- let svc = 'Service' $ \\req -> pure (Right (process req))+--+-- -- Compose middleware+-- let robust = 'withRetry' ('constantBackoff' 3 1.0)+--            . 'withTimeout' 5000+--            $ svc+-- @+--+-- All errors are returned as @'Either' 'ServiceError' response@ — no exceptions+-- escape the middleware stack.+module Tower+  ( -- * Core types+    Service(..)+  , Middleware+  , mapService+  , composeMiddleware+    -- * Errors+  , ServiceError(..)+  , displayError+    -- * Middleware+    -- ** Retry+  , BackoffStrategy(..)+  , constantBackoff+  , exponentialBackoff+  , withRetry+    -- ** Timeout+  , withTimeout+    -- ** Circuit Breaker+  , CircuitBreakerConfig(..)+  , CircuitBreakerState(..)+  , CircuitBreaker+  , newCircuitBreaker+  , withCircuitBreaker+  , getCircuitBreakerState+    -- ** Filter+  , withFilter+  , withNoRetryOn+    -- ** Hedge+  , withHedge+    -- ** Logging+  , withLogging+    -- ** Tracing (OpenTelemetry)+  , TracingConfig(..)+  , defaultTracingConfig+  , withTracingConfig+  , withTracingGlobal+    -- ** Request Transform+  , withMapRequest+  , withMapRequestPure+    -- ** Response Validation+  , Tower.Middleware.Validate.withValidate+    -- ** Test Doubles+  , withMock+  , withRecorder+  ) where++import Tower.Service+import Tower.Error+import Tower.Middleware.Retry+import Tower.Middleware.Timeout+import Tower.Middleware.CircuitBreaker+import Tower.Middleware.Filter+import Tower.Middleware.Hedge+import Tower.Middleware.Logging+import Tower.Middleware.Tracing+import Tower.Middleware.Transform+import Tower.Middleware.Validate+import Tower.Middleware.TestDouble
+ src/Tower/Error.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Tower.Error+-- Description : Error types for the middleware stack+-- License     : MIT+--+-- All middleware returns @Either 'ServiceError' response@ — no exceptions+-- escape the middleware stack.+module 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+  = TransportError SomeException+    -- ^ An underlying transport 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 (TransportError e)    = pack $ "Transport 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
+ src/Tower/Error/Testing.hs view
@@ -0,0 +1,20 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- |+-- Module      : Tower.Error.Testing+-- Description : Eq instance for ServiceError (testing only)+-- License     : MIT+--+-- Provides an 'Eq' instance for 'ServiceError' using @show@-based comparison+-- for the 'TransportError' case. Import this module in test suites only.+module Tower.Error.Testing () where++import Tower.Error (ServiceError(..))++instance Eq ServiceError where+  TransportError a   == TransportError b   = show a == show b+  TimeoutError       == TimeoutError       = True+  RetryExhausted n e == RetryExhausted m f = n == m && e == f+  CircuitBreakerOpen == CircuitBreakerOpen = True+  CustomError a      == CustomError b      = a == b+  _                  == _                  = False
+ src/Tower/Middleware/CircuitBreaker.hs view
@@ -0,0 +1,132 @@+-- |+-- Module      : 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 }+-- @+--+-- == 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 Tower.Middleware.CircuitBreaker+  ( CircuitBreakerConfig(..)+  , CircuitBreakerState(..)+  , CircuitBreaker+  , newCircuitBreaker+  , withCircuitBreaker+  , getCircuitBreakerState+  ) where++import Control.Concurrent.STM+import Data.Time.Clock (UTCTime, NominalDiffTime, getCurrentTime, diffUTCTime)++import Tower.Service (Service(..), Middleware)+import 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'+-- @+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
+ src/Tower/Middleware/Filter.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Tower.Middleware.Filter+-- Description : Predicate-based request and response filtering+-- License     : MIT+--+-- @+-- -- Only allow certain requests+-- 'withFilter' predicate+--+-- -- Don't retry matching responses+-- 'withNoRetryOn' predicate+-- @+module Tower.Middleware.Filter+  ( withFilter+  , withNoRetryOn+  ) where++import Tower.Service (Service(..), Middleware)+import 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
+ src/Tower/Middleware/Hedge.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE NumericUnderscores #-}++-- |+-- Module      : 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.+--+-- @+-- 'withHedge' 200  -- hedge after 200ms+-- @+--+-- __Only use for idempotent requests__ since the request may+-- be sent twice.+module Tower.Middleware.Hedge+  ( withHedge+  ) where++import Control.Concurrent (threadDelay)+import Control.Concurrent.Async (race)++import Tower.Service (Service(..), Middleware)+import 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
+ src/Tower/Middleware/Logging.hs view
@@ -0,0 +1,39 @@+-- |+-- Module      : Tower.Middleware.Logging+-- Description : Generic request/response logging middleware+-- License     : MIT+--+-- Times each service call and delegates formatting to a user-provided function.+--+-- @+-- let formatter req result duration = case result of+--       Right _  -> "OK (" <> pack (show (round (duration * 1000))) <> "ms)"+--       Left err -> "ERR: " <> displayError err+-- 'withLogging' formatter putStrLn+-- @+module Tower.Middleware.Logging+  ( withLogging+  ) where++import Data.Text (Text)+import Data.Time.Clock (getCurrentTime, diffUTCTime)++import Tower.Service (Service(..), Middleware)+import Tower.Error (ServiceError)++-- | Generic logging middleware: times the service call and passes+-- the request, result, and duration (in seconds) to a formatter.+--+-- The formatter produces a 'Text' message which is passed to the logger.+-- This middleware does not alter the result.+withLogging+  :: (req -> Either ServiceError res -> Double -> Text)  -- ^ Formatter+  -> (Text -> IO ())                                      -- ^ Logger+  -> Middleware req res+withLogging 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
+ src/Tower/Middleware/Retry.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE NumericUnderscores #-}++-- |+-- Module      : Tower.Middleware.Retry+-- Description : Retry middleware with configurable backoff+-- License     : MIT+--+-- Retries failed requests with constant or exponential backoff.+--+-- @+-- 'withRetry' ('constantBackoff' 3 1.0)+-- 'withRetry' ('exponentialBackoff' 5 0.5 2.0)+-- @+module Tower.Middleware.Retry+  ( BackoffStrategy(..)+  , constantBackoff+  , exponentialBackoff+  , withRetry+  , computeDelay+  ) where++import Control.Concurrent (threadDelay)+import Data.Time.Clock (NominalDiffTime)++import Tower.Service (Service(..), Middleware)+import 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)
+ src/Tower/Middleware/TestDouble.hs view
@@ -0,0 +1,41 @@+-- |+-- Module      : Tower.Middleware.TestDouble+-- Description : Mock services and request recording for testing+-- License     : MIT+--+-- @+-- -- Replace the service entirely+-- 'withMock' (\\req -> pure (Right fakeResponse))+--+-- -- Record requests for assertions+-- recorder <- newIORef []+-- 'withRecorder' recorder+-- @+module Tower.Middleware.TestDouble+  ( withMock+  , withRecorder+  ) where++import Data.IORef++import Tower.Service (Service(..), Middleware)+import Tower.Error (ServiceError)++-- | Replace the inner service entirely with a mock function.+-- The inner service is never called.+withMock+  :: (req -> IO (Either ServiceError res))+  -> Middleware req res+withMock handler _inner = Service handler++-- | 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 svc = 'withRecorder' recorder innerService+-- @+withRecorder :: IORef [req] -> Middleware req res+withRecorder ref inner = Service $ \req -> do+  modifyIORef' ref (req :)+  runService inner req
+ src/Tower/Middleware/Timeout.hs view
@@ -0,0 +1,29 @@+-- |+-- Module      : Tower.Middleware.Timeout+-- Description : Timeout middleware+-- License     : MIT+--+-- Fails with 'TimeoutError' if the inner service doesn't respond within+-- the specified number of milliseconds.+--+-- @+-- 'withTimeout' 5000  -- 5 second timeout+-- @+module Tower.Middleware.Timeout+  ( withTimeout+  ) where++import qualified System.Timeout as Sys++import Tower.Service (Service(..), Middleware)+import 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
+ src/Tower/Middleware/Tracing.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Tower.Middleware.Tracing+-- Description : Generic OpenTelemetry tracing middleware+-- License     : MIT+--+-- Wraps each service call in an OpenTelemetry span. Users provide a+-- 'TracingConfig' to control the span name, kind, and attribute extraction.+--+-- @+-- let config = ('defaultTracingConfig' "my-service")+--       { 'tracingReqAttrs' = \\req s -> addAttribute s "my.attr" (show req) }+-- client |> 'withTracingConfig' tracer config+-- @+module Tower.Middleware.Tracing+  ( TracingConfig(..)+  , defaultTracingConfig+  , withTracingConfig+  , withTracingGlobal+  ) where++import Data.Text (Text)++import OpenTelemetry.Attributes (emptyAttributes)+import OpenTelemetry.Trace.Core+  ( Tracer+  , Span+  , InstrumentationLibrary(..)+  , TracerOptions(..)+  , SpanArguments(..)+  , SpanKind(..)+  , SpanStatus(..)+  , makeTracer+  , getGlobalTracerProvider+  , defaultSpanArguments+  , addAttribute+  , setStatus+  , inSpan'+  )++import Tower.Service (Service(..), Middleware)+import Tower.Error (ServiceError, displayError)++-- | Configuration for the generic tracing middleware.+data TracingConfig req res = TracingConfig+  { tracingSpanName :: req -> Text+    -- ^ Derive the span name from the request.+  , tracingSpanKind :: SpanKind+    -- ^ The span kind (e.g., 'Client', 'Server', 'Internal').+  , tracingReqAttrs :: req -> Span -> IO ()+    -- ^ Add request attributes to the span before the call.+  , tracingResAttrs :: res -> Span -> IO ()+    -- ^ Add response attributes to the span after a successful call.+  , tracingErrAttrs :: ServiceError -> Span -> IO ()+    -- ^ Add error attributes to the span on failure (in addition to setting error status).+  }++-- | Default tracing config: fixed span name, 'Client' kind, no attributes.+-- On error, adds @error.type@ attribute with the error description.+defaultTracingConfig :: Text -> TracingConfig req res+defaultTracingConfig name = TracingConfig+  { tracingSpanName = const name+  , tracingSpanKind = Client+  , tracingReqAttrs = \_ _ -> pure ()+  , tracingResAttrs = \_ _ -> pure ()+  , tracingErrAttrs = \err s -> addAttribute s "error.type" (displayError err)+  }++-- | Tracing middleware using a specific 'Tracer' and 'TracingConfig'.+--+-- Wraps each service call in an OpenTelemetry span. On success, calls+-- 'tracingResAttrs' to record response attributes. On failure, sets+-- the span status to error with the 'ServiceError' description.+withTracingConfig :: Tracer -> TracingConfig req res -> Middleware req res+withTracingConfig tracer config inner = Service $ \req -> do+  let spanName = tracingSpanName config req+      spanArgs = defaultSpanArguments { kind = tracingSpanKind config }+  inSpan' tracer spanName spanArgs $ \s -> do+    tracingReqAttrs config req s+    result <- runService inner req+    case result of+      Right res -> do+        tracingResAttrs config res s+        pure (Right res)+      Left err -> do+        tracingErrAttrs config err s+        setStatus s (Error (displayError err))+        pure (Left err)++-- | 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.+withTracingGlobal :: InstrumentationLibrary -> TracingConfig req res -> Middleware req res+withTracingGlobal lib config inner = Service $ \req -> do+  tp <- getGlobalTracerProvider+  let tracer = makeTracer tp lib (TracerOptions Nothing)+  runService (withTracingConfig tracer config inner) req
+ src/Tower/Middleware/Transform.hs view
@@ -0,0 +1,30 @@+-- |+-- Module      : Tower.Middleware.Transform+-- Description : Generic request transformation middleware+-- License     : MIT+--+-- Transform the request before passing it to the inner service.+--+-- @+-- 'withMapRequest' (\\req -> addCorrelationId req)+-- 'withMapRequestPure' (\\req -> req { field = newValue })+-- @+module Tower.Middleware.Transform+  ( withMapRequest+  , withMapRequestPure+  ) where++import Tower.Service (Service(..), Middleware)++-- | Transform the request using an effectful function before passing+-- it to the inner service. Useful for adding generated IDs, timestamps, etc.+withMapRequest :: (req -> IO req) -> Middleware req res+withMapRequest f inner = Service $ \req -> do+  req' <- f req+  runService inner req'++-- | Transform the request using a pure function before passing+-- it to the inner service. Useful for adding static headers, tags, etc.+withMapRequestPure :: (req -> req) -> Middleware req res+withMapRequestPure f inner = Service $ \req ->+  runService inner (f req)
+ src/Tower/Middleware/Validate.hs view
@@ -0,0 +1,31 @@+-- |+-- Module      : Tower.Middleware.Validate+-- Description : Generic response validation middleware+-- License     : MIT+--+-- Reject responses that fail a check.+--+-- @+-- 'withValidate' (\\res -> if isValid res then Nothing else Just "invalid")+-- @+module Tower.Middleware.Validate+  ( withValidate+  ) where++import Data.Text (Text)++import Tower.Service (Service(..), Middleware)+import Tower.Error (ServiceError(..))++-- | Reject responses that fail a validation check.+--+-- The check function inspects the response and returns 'Nothing' if valid,+-- or @'Just' errorMessage@ to reject with a 'CustomError'.+withValidate :: (res -> Maybe Text) -> Middleware req res+withValidate check inner = Service $ \req -> do+  result <- runService inner req+  case result of+    Right res -> case check res of+      Nothing  -> pure (Right res)+      Just err -> pure (Left (CustomError err))+    Left err -> pure (Left err)
+ src/Tower/Service.hs view
@@ -0,0 +1,55 @@+-- |+-- Module      : Tower.Service+-- 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 Tower.Service+  ( Service(..)+  , Middleware+  , mapService+  , composeMiddleware+  ) where++import 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
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/Tower/Middleware/CircuitBreakerSpec.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NumericUnderscores #-}++module Tower.Middleware.CircuitBreakerSpec (spec) where++import Control.Concurrent (threadDelay)+import Data.IORef+import Test.Hspec++import Tower.Service+import Tower.Error+import Tower.Error.Testing ()+import 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)
+ test/Tower/Middleware/FilterSpec.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE OverloadedStrings #-}++module Tower.Middleware.FilterSpec (spec) where++import Test.Hspec++import Tower.Service+import Tower.Error+import Tower.Error.Testing ()+import Tower.Middleware.Filter++spec :: Spec+spec = describe "Filter middleware" $ do+  describe "withFilter" $ do+    it "allows matching requests through" $ do+      let svc :: Service String String+          svc = Service $ \_ -> pure (Right "ok")+          filtered = withFilter (const True) svc+      result <- runService filtered "request"+      result `shouldBe` Right "ok"++    it "rejects non-matching requests" $ do+      let svc :: Service String String+          svc = Service $ \_ -> pure (Right "ok")+          filtered = withFilter (const False) svc+      result <- runService filtered "request"+      result `shouldBe` Left (CustomError "Request filtered out")++    it "filters based on request properties" $ do+      let svc :: Service String String+          svc = Service $ \_ -> pure (Right "ok")+          onlyGet = withFilter (== "GET") svc+      getResult <- runService onlyGet "GET"+      postResult <- runService onlyGet "POST"+      getResult `shouldBe` Right "ok"+      postResult `shouldBe` Left (CustomError "Request filtered out")
+ test/Tower/Middleware/HedgeSpec.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NumericUnderscores #-}++module Tower.Middleware.HedgeSpec (spec) where++import Control.Concurrent (threadDelay)+import Data.IORef+import Test.Hspec++import Tower.Service+import Tower.Error+import Tower.Error.Testing ()+import 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)
+ test/Tower/Middleware/LoggingSpec.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE OverloadedStrings #-}++module Tower.Middleware.LoggingSpec (spec) where++import Data.IORef+import qualified Data.Text+import Data.Text (Text, isInfixOf)+import Test.Hspec++import Tower.Service+import Tower.Error+import Tower.Error.Testing ()+import Tower.Middleware.Logging++spec :: Spec+spec = describe "Logging middleware (generic)" $ do+  it "logs successful requests" $ do+    logRef <- newIORef ([] :: [Text])+    let logger msg = modifyIORef' logRef (msg :)+        formatter _ result duration = case result of+          Right res -> "OK: " <> res <> " (" <> showMs duration <> ")"+          Left err  -> "ERR: " <> displayError err+        svc :: Service () Text+        svc = Service $ \_ -> pure (Right "done")+        logged = withLogging formatter logger svc+    _ <- runService logged ()+    logs <- readIORef logRef+    length logs `shouldBe` 1+    isInfixOf "OK: done" (head logs) `shouldBe` True++  it "logs failed requests" $ do+    logRef <- newIORef ([] :: [Text])+    let logger msg = modifyIORef' logRef (msg :)+        formatter _ result _ = case result of+          Right _  -> "OK"+          Left err -> "ERR: " <> displayError err+        svc :: Service () Text+        svc = Service $ \_ -> pure (Left TimeoutError)+        logged = withLogging formatter logger svc+    _ <- runService logged ()+    logs <- readIORef logRef+    length logs `shouldBe` 1+    isInfixOf "ERR" (head logs) `shouldBe` True++  it "does not alter the result" $ do+    let logger _ = pure ()+        formatter _ _ _ = "ignored"+        svc :: Service () Text+        svc = Service $ \_ -> pure (Right "original")+        logged = withLogging formatter logger svc+    result <- runService logged ()+    result `shouldBe` Right "original"++  it "passes the request to the formatter" $ do+    logRef <- newIORef ([] :: [Text])+    let logger msg = modifyIORef' logRef (msg :)+        formatter req _ _ = "request=" <> req+        svc :: Service Text Text+        svc = Service $ \_ -> pure (Right "ok")+        logged = withLogging formatter logger svc+    _ <- runService logged "my-request"+    logs <- readIORef logRef+    head logs `shouldBe` "request=my-request"++showMs :: Double -> Text+showMs d = let ms = round (d * 1000) :: Int+           in Data.Text.pack (show ms) <> "ms"
+ test/Tower/Middleware/RedisDockerSpec.hs view
@@ -0,0 +1,191 @@+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Integration test demonstrating tower-hs generic middleware with a real+-- Redis database via testcontainers. This proves that retry, timeout,+-- circuit breaker, logging, and validation compose for non-HTTP services+-- just as naturally as they do for HTTP or servant.+module Tower.Middleware.RedisDockerSpec (spec) where++import Control.Concurrent (threadDelay)+import Control.Exception (SomeException, try)+import Control.Monad.IO.Class (liftIO)+import Data.ByteString (ByteString)+import Data.IORef+import Data.Text (Text, isInfixOf)+import qualified Data.Text as T+import System.Process (readProcess)+import Test.Hspec++import qualified Database.Redis as Redis++import qualified TestContainers as TC+import TestContainers.Hspec (withContainers)++import Tower.Service+import Tower.Error+import Tower.Error.Testing ()+import Tower.Middleware.CircuitBreaker+import Tower.Middleware.Logging (withLogging)+import Tower.Middleware.Retry+import Tower.Middleware.Timeout+import Tower.Middleware.Validate (withValidate)++-- ---------------------------------------------------------------------------+-- Redis container setup+-- ---------------------------------------------------------------------------++setupRedis :: TC.TestContainer Redis.Connection+setupRedis = do+  container <- TC.run $ TC.containerRequest (TC.fromTag "redis:7-alpine")+    TC.& TC.setExpose [6379]+    TC.& TC.setWaitingFor (TC.waitUntilTimeout 30 (TC.waitUntilMappedPortReachable 6379))+  let port = TC.containerPort container 6379+  liftIO $ do+    -- Small delay to ensure Redis is accepting commands+    threadDelay 500_000+    Redis.checkedConnect Redis.defaultConnectInfo+      { Redis.connectHost = "localhost"+      , Redis.connectPort = Redis.PortNumber (fromIntegral port)+      }++-- ---------------------------------------------------------------------------+-- Redis service wrapped as tower-hs Service+-- ---------------------------------------------------------------------------++-- | A Redis SET+GET service: takes a (key, value) pair, stores it, and+-- returns the value read back. Exercises a real database round-trip.+type RedisGetSet = Service (ByteString, ByteString) ByteString++mkRedisService :: Redis.Connection -> RedisGetSet+mkRedisService conn = Service $ \(key, value) -> do+  result <- try $ Redis.runRedis conn $ do+    _ <- Redis.set key value+    Redis.get key+  pure $ case result of+    Left (err :: SomeException) -> Left (TransportError err)+    Right (Right (Just v))      -> Right v+    Right (Right Nothing)       -> Left (CustomError "key not found after SET")+    Right (Left reply)          -> Left (CustomError ("Redis error: " <> T.pack (show reply)))++-- | A simple Redis PING service for connectivity checks.+type RedisPing = Service () Redis.Status++mkRedisPingService :: Redis.Connection -> RedisPing+mkRedisPingService conn = Service $ \_ -> do+  result <- try $ Redis.runRedis conn Redis.ping+  pure $ case result of+    Left (err :: SomeException) -> Left (TransportError err)+    Right (Right status)        -> Right status+    Right (Left reply)          -> Left (CustomError ("Redis error: " <> T.pack (show reply)))++-- ---------------------------------------------------------------------------+-- Helpers+-- ---------------------------------------------------------------------------++dockerAvailable :: IO Bool+dockerAvailable = do+  result <- try (readProcess "docker" ["info"] "") :: IO (Either SomeException String)+  pure $ case result of+    Right _ -> True+    Left _  -> False++-- ---------------------------------------------------------------------------+-- Tests+-- ---------------------------------------------------------------------------++spec :: Spec+spec = describe "Redis integration (testcontainers)" $ beforeAll dockerAvailable $ do++  it "SET and GET through a tower-hs service" $ \isAvailable -> do+    if not isAvailable+      then pendingWith "Docker not available"+      else withContainers setupRedis $ \conn -> do+        let svc = mkRedisService conn+        result <- runService svc ("tower-key", "tower-value")+        result `shouldBe` Right "tower-value"++  it "retry recovers from transient errors" $ \isAvailable -> do+    if not isAvailable+      then pendingWith "Docker not available"+      else withContainers setupRedis $ \conn -> do+        callCount <- newIORef (0 :: Int)+        let svc = Service $ \input -> do+              n <- atomicModifyIORef' callCount (\c -> (c + 1, c))+              if n < 2+                then pure (Left (CustomError "transient redis error"))+                else runService (mkRedisService conn) input+            robust = withRetry (constantBackoff 3 0) svc+        result <- runService robust ("retry-key", "retry-value")+        result `shouldBe` Right "retry-value"+        readIORef callCount >>= (`shouldBe` 3)++  it "timeout catches slow operations" $ \isAvailable -> do+    if not isAvailable+      then pendingWith "Docker not available"+      else withContainers setupRedis $ \conn -> do+        -- Wrap a service that artificially delays+        let slowSvc :: RedisGetSet+            slowSvc = Service $ \input -> do+              threadDelay 2_000_000  -- 2 seconds+              runService (mkRedisService conn) input+            timed = withTimeout 500 slowSvc  -- 500ms timeout+        result <- runService timed ("timeout-key", "timeout-value")+        result `shouldBe` Left TimeoutError++  it "circuit breaker trips after repeated failures" $ \isAvailable -> do+    if not isAvailable+      then pendingWith "Docker not available"+      else withContainers setupRedis $ \_ -> do+        breaker <- newCircuitBreaker+        let config = CircuitBreakerConfig { cbFailureThreshold = 2, cbCooldownPeriod = 10 }+            failSvc :: RedisGetSet+            failSvc = Service $ \_ -> pure (Left (CustomError "redis down"))+            protected = withCircuitBreaker config breaker failSvc+        _ <- runService protected ("k", "v")+        _ <- runService protected ("k", "v")+        getCircuitBreakerState breaker >>= (`shouldBe` Open)+        result <- runService protected ("k", "v")+        result `shouldBe` Left CircuitBreakerOpen++  it "validates results" $ \isAvailable -> do+    if not isAvailable+      then pendingWith "Docker not available"+      else withContainers setupRedis $ \conn -> do+        let svc = mkRedisService conn+            validated = withValidate (\v ->+              if v == "expected" then Nothing+              else Just ("Unexpected value: " <> T.pack (show v))) svc+        -- This should fail validation — the stored value won't be "expected"+        result <- runService validated ("val-key", "something-else")+        case result of+          Left (CustomError msg) -> isInfixOf "Unexpected value" msg `shouldBe` True+          other -> expectationFailure $ "Expected validation error, got: " <> show other++  it "composes full middleware stack for Redis service" $ \isAvailable -> do+    if not isAvailable+      then pendingWith "Docker not available"+      else withContainers setupRedis $ \conn -> do+        logRef <- newIORef ([] :: [Text])+        breaker <- newCircuitBreaker+        let config = CircuitBreakerConfig { cbFailureThreshold = 5, cbCooldownPeriod = 30 }+            svc = mkRedisPingService conn+            robust = withRetry (constantBackoff 2 0)+                   . withTimeout 5000+                   . withCircuitBreaker config breaker+                   . withValidate (\status ->+                       if status == Redis.Pong then Nothing+                       else Just ("Unexpected PING response: " <> T.pack (show status)))+                   . withLogging+                       (\_ result dur -> case result of+                         Right _ -> "Redis OK (" <> T.pack (show (round (dur * 1000) :: Int)) <> "ms)"+                         Left err -> "Redis ERR: " <> displayError err)+                       (\msg -> modifyIORef' logRef (msg :))+                   $ svc+        result <- runService robust ()+        result `shouldBe` Right Redis.Pong+        getCircuitBreakerState breaker >>= (`shouldBe` Closed)+        logs <- readIORef logRef+        length logs `shouldBe` 1+        isInfixOf "Redis OK" (head logs) `shouldBe` True
+ test/Tower/Middleware/RetrySpec.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE OverloadedStrings #-}++module Tower.Middleware.RetrySpec (spec) where++import Data.IORef+import Data.Time.Clock (NominalDiffTime)+import Test.Hspec+import Test.QuickCheck++import Tower.Service+import Tower.Error+import Tower.Error.Testing ()+import 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)
+ test/Tower/Middleware/TimeoutSpec.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NumericUnderscores #-}++module Tower.Middleware.TimeoutSpec (spec) where++import Control.Concurrent (threadDelay)+import Test.Hspec++import Tower.Service+import Tower.Error+import Tower.Error.Testing ()+import 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")
+ test/Tower/Middleware/TracingSpec.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE OverloadedStrings #-}++module Tower.Middleware.TracingSpec (spec) where++import Data.IORef+import Data.Text (Text)+import Test.Hspec++import OpenTelemetry.Attributes (emptyAttributes)+import OpenTelemetry.Trace.Core (InstrumentationLibrary(..))++import Tower.Service+import Tower.Error+import Tower.Error.Testing ()+import Tower.Middleware.Tracing++spec :: Spec+spec = describe "Tracing middleware (generic)" $ do+  -- No OTel SDK configured, so tracing is a no-op — but the middleware+  -- must be transparent.++  it "passes successful responses through unchanged" $ do+    let config = defaultTracingConfig "test-span"+        svc :: Service () String+        svc = Service $ \_ -> pure (Right "hello")+        traced = withTracingGlobal testLib config svc+    result <- runService traced ()+    result `shouldBe` Right "hello"++  it "passes errors through unchanged" $ do+    let config = defaultTracingConfig "test-span"+        svc :: Service () String+        svc = Service $ \_ -> pure (Left TimeoutError)+        traced = withTracingGlobal testLib config svc+    result <- runService traced ()+    result `shouldBe` Left TimeoutError++  it "calls the inner service exactly once" $ do+    callCount <- newIORef (0 :: Int)+    let config = defaultTracingConfig "test-span"+        svc :: Service () String+        svc = Service $ \_ -> do+          modifyIORef' callCount (+ 1)+          pure (Right "ok")+        traced = withTracingGlobal testLib config svc+    _ <- runService traced ()+    readIORef callCount >>= (`shouldBe` 1)++  it "uses request-dependent span name from config" $ do+    let config = (defaultTracingConfig "unused")+          { tracingSpanName = ("span-" <>) }+        svc :: Service Text String+        svc = Service $ \_ -> pure (Right "ok")+        traced = withTracingGlobal testLib config svc+    result <- runService traced "test"+    result `shouldBe` Right "ok"++  it "calls request attribute hook" $ do+    hookCalled <- newIORef False+    let config = (defaultTracingConfig "test")+          { tracingReqAttrs = \_ _ -> writeIORef hookCalled True }+        svc :: Service () String+        svc = Service $ \_ -> pure (Right "ok")+        traced = withTracingGlobal testLib config svc+    _ <- runService traced ()+    readIORef hookCalled >>= (`shouldBe` True)++  it "calls response attribute hook on success" $ do+    hookCalled <- newIORef False+    let config = (defaultTracingConfig "test")+          { tracingResAttrs = \_ _ -> writeIORef hookCalled True }+        svc :: Service () String+        svc = Service $ \_ -> pure (Right "ok")+        traced = withTracingGlobal testLib config svc+    _ <- runService traced ()+    readIORef hookCalled >>= (`shouldBe` True)++  it "does not call response attribute hook on error" $ do+    hookCalled <- newIORef False+    let config = (defaultTracingConfig "test")+          { tracingResAttrs = \_ _ -> writeIORef hookCalled True }+        svc :: Service () String+        svc = Service $ \_ -> pure (Left (CustomError "fail"))+        traced = withTracingGlobal testLib config svc+    _ <- runService traced ()+    readIORef hookCalled >>= (`shouldBe` False)++testLib :: InstrumentationLibrary+testLib = InstrumentationLibrary+  { libraryName = "tower-hs-test"+  , libraryVersion = "0.0.0"+  , librarySchemaUrl = ""+  , libraryAttributes = emptyAttributes+  }
+ test/Tower/Middleware/TransformSpec.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE OverloadedStrings #-}++module Tower.Middleware.TransformSpec (spec) where++import Data.IORef+import Test.Hspec++import Tower.Service+import Tower.Error+import Tower.Error.Testing ()+import Tower.Middleware.Transform++spec :: Spec+spec = describe "Transform middleware (generic)" $ do+  describe "withMapRequestPure" $ do+    it "transforms the request before passing to inner service" $ do+      let svc :: Service String String+          svc = Service $ \req -> pure (Right req)+          transformed = withMapRequestPure (++ "!") svc+      result <- runService transformed "hello"+      result `shouldBe` Right "hello!"++    it "does not alter the response" $ do+      let svc :: Service String String+          svc = Service $ \_ -> pure (Right "response")+          transformed = withMapRequestPure (++ "!") svc+      result <- runService transformed "request"+      result `shouldBe` Right "response"++    it "composes multiple transforms (right-to-left)" $ do+      let svc :: Service String String+          svc = Service $ \req -> pure (Right req)+          transformed = withMapRequestPure (++ "3")+                      . withMapRequestPure (++ "2")+                      . withMapRequestPure (++ "1")+                      $ svc+      result <- runService transformed "base"+      -- Middleware composes right-to-left: 1 applied first, then 2, then 3+      result `shouldBe` Right "base321"++  describe "withMapRequest" $ do+    it "transforms the request with IO" $ do+      counter <- newIORef (0 :: Int)+      let svc :: Service String String+          svc = Service $ \req -> pure (Right req)+          transformed = withMapRequest (\req -> do+            n <- atomicModifyIORef' counter (\c -> (c + 1, c))+            pure (req ++ "-" ++ show n)) svc+      r1 <- runService transformed "req"+      r2 <- runService transformed "req"+      r1 `shouldBe` Right "req-0"+      r2 `shouldBe` Right "req-1"++    it "passes through errors from inner service" $ do+      let svc :: Service String String+          svc = Service $ \_ -> pure (Left (CustomError "fail"))+          transformed = withMapRequest (\req -> pure (req ++ "!")) svc+      result <- runService transformed "hello"+      result `shouldBe` Left (CustomError "fail")
+ test/Tower/Middleware/ValidateSpec.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE OverloadedStrings #-}++module Tower.Middleware.ValidateSpec (spec) where++import Test.Hspec++import Tower.Service+import Tower.Error+import Tower.Error.Testing ()+import Tower.Middleware.Validate++spec :: Spec+spec = describe "Validate middleware (generic)" $ do+  it "passes responses that return Nothing" $ do+    let svc :: Service () String+        svc = Service $ \_ -> pure (Right "ok")+        validated = withValidate (const Nothing) svc+    result <- runService validated ()+    result `shouldBe` Right "ok"++  it "rejects responses that return Just" $ do+    let svc :: Service () String+        svc = Service $ \_ -> pure (Right "bad")+        validated = withValidate (\_ -> Just "validation failed") svc+    result <- runService validated ()+    result `shouldBe` Left (CustomError "validation failed")++  it "passes through errors from inner service" $ do+    let svc :: Service () String+        svc = Service $ \_ -> pure (Left TimeoutError)+        validated = withValidate (const (Just "should not trigger")) svc+    result <- runService validated ()+    result `shouldBe` Left TimeoutError++  it "can inspect the response value" $ do+    let svc :: Service () Int+        svc = Service $ \_ -> pure (Right 42)+        validated = withValidate (\n -> if n > 100 then Just "too big" else Nothing) svc+    result <- runService validated ()+    result `shouldBe` Right 42++  it "rejects based on response value" $ do+    let svc :: Service () Int+        svc = Service $ \_ -> pure (Right 200)+        validated = withValidate (\n -> if n > 100 then Just "too big" else Nothing) svc+    result <- runService validated ()+    result `shouldBe` Left (CustomError "too big")
+ test/Tower/ServiceSpec.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE OverloadedStrings #-}++module Tower.ServiceSpec (spec) where++import Test.Hspec++import Tower.Service+import Tower.Error+import Tower.Error.Testing ()++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]"
+ tower-hs.cabal view
@@ -0,0 +1,97 @@+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:           tower-hs+version:        0.1.0.0+synopsis:       Composable service middleware for Haskell, inspired by Rust's Tower+description:    tower-hs provides a composable middleware abstraction for any service type.+                Build middleware stacks with retry, timeout, circuit breaker, and more — all with+                pure error handling via Either (no exceptions).+category:       Control+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:+      Tower+      Tower.Service+      Tower.Error+      Tower.Error.Testing+      Tower.Middleware.Retry+      Tower.Middleware.Timeout+      Tower.Middleware.CircuitBreaker+      Tower.Middleware.Filter+      Tower.Middleware.Hedge+      Tower.Middleware.Logging+      Tower.Middleware.Transform+      Tower.Middleware.Tracing+      Tower.Middleware.Validate+      Tower.Middleware.TestDouble+  other-modules:+      Paths_tower_hs+  hs-source-dirs:+      src+  build-depends:+      async ==2.2.*+    , base >=4.14 && <5+    , hs-opentelemetry-api ==0.3.*+    , stm ==2.5.*+    , text >=2.0 && <2.2+    , time >=1.11 && <1.15+  default-language: Haskell2010++test-suite tower-hs-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Tower.Middleware.CircuitBreakerSpec+      Tower.Middleware.FilterSpec+      Tower.Middleware.HedgeSpec+      Tower.Middleware.LoggingSpec+      Tower.Middleware.RedisDockerSpec+      Tower.Middleware.RetrySpec+      Tower.Middleware.TimeoutSpec+      Tower.Middleware.TracingSpec+      Tower.Middleware.TransformSpec+      Tower.Middleware.ValidateSpec+      Tower.ServiceSpec+      Paths_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.*+    , async ==2.2.*+    , base >=4.14 && <5+    , bytestring >=0.11 && <0.13+    , hedis ==0.15.*+    , hs-opentelemetry-api ==0.3.*+    , hspec ==2.11.*+    , hspec-discover ==2.11.*+    , process ==1.6.*+    , stm ==2.5.*+    , testcontainers ==0.5.*+    , text >=2.0 && <2.2+    , time >=1.11 && <1.15+    , tower-hs+  default-language: Haskell2010