tower-hs 0.1.0.0 → 0.2.0.0
raw patch · 15 files changed
+125/−55 lines, 15 filesdep +profunctors
Dependencies added: profunctors
Files
- CHANGELOG.md +9/−0
- src/Tower.hs +7/−4
- src/Tower/Middleware/Tracing.hs +2/−1
- src/Tower/Service.hs +47/−1
- test/Tower/Middleware/CircuitBreakerSpec.hs +8/−7
- test/Tower/Middleware/FilterSpec.hs +4/−3
- test/Tower/Middleware/HedgeSpec.hs +4/−3
- test/Tower/Middleware/LoggingSpec.hs +5/−4
- test/Tower/Middleware/RetrySpec.hs +5/−4
- test/Tower/Middleware/TimeoutSpec.hs +4/−3
- test/Tower/Middleware/TracingSpec.hs +8/−7
- test/Tower/Middleware/TransformSpec.hs +11/−10
- test/Tower/Middleware/ValidateSpec.hs +6/−5
- test/Tower/ServiceSpec.hs +3/−2
- tower-hs.cabal +2/−1
CHANGELOG.md view
@@ -1,5 +1,14 @@ # Changelog +## 0.2.0.0 — 2026-04-07++- Add `Functor` instance for `Service req` — use `fmap` to transform successful responses+- Add `Profunctor` instance for `Service` — use `dimap`/`lmap` to adapt request and response types+- Add `contramapService` and `dimapService` as named synonyms for `lmap` and `dimap`+- `mapService` is now a synonym for `fmap`+- New dependency: `profunctors`+- Adopt `(&)` from `Data.Function` as idiomatic style in docs, tests, and examples+ ## 0.1.0.0 — 2026-04-06 - Initial release
src/Tower.hs view
@@ -7,15 +7,16 @@ -- Build composable middleware stacks for any service type. -- -- @+-- import Data.Function (('&')) -- 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+-- -- Compose middleware using '&'+-- let robust = svc+-- '&' 'withTimeout' 5000+-- '&' 'withRetry' ('constantBackoff' 3 1.0) -- @ -- -- All errors are returned as @'Either' 'ServiceError' response@ — no exceptions@@ -25,6 +26,8 @@ Service(..) , Middleware , mapService+ , contramapService+ , dimapService , composeMiddleware -- * Errors , ServiceError(..)
src/Tower/Middleware/Tracing.hs view
@@ -9,9 +9,10 @@ -- 'TracingConfig' to control the span name, kind, and attribute extraction. -- -- @+-- import Data.Function (('&')) -- let config = ('defaultTracingConfig' "my-service") -- { 'tracingReqAttrs' = \\req s -> addAttribute s "my.attr" (show req) }--- client |> 'withTracingConfig' tracer config+-- svc '&' 'withTracingConfig' tracer config -- @ module Tower.Middleware.Tracing ( TracingConfig(..)
src/Tower/Service.hs view
@@ -10,14 +10,23 @@ ( Service(..) , Middleware , mapService+ , contramapService+ , dimapService , composeMiddleware ) where +import Data.Profunctor (Profunctor(..)) import Tower.Error (ServiceError) -- | A service transforms a request into an effectful response. -- This is the fundamental building block — middleware wraps services. --+-- 'Service' is a 'Functor' in its response type and a 'Profunctor' over+-- both request and response types. Use 'fmap' to transform responses,+-- 'lmap' to transform requests, or 'dimap' to transform both — useful for+-- lifting a @Service Http.Request Http.Response@ into a+-- @Service MyBinding.SomeRequest MyBinding.SomeResponse@.+-- -- @ -- let echoService = 'Service' $ \\req -> pure (Right req) -- result <- 'runService' echoService "hello"@@ -28,6 +37,14 @@ -- ^ Execute the service with a request, returning either an error or a response. } +instance Functor (Service req) where+ fmap f (Service run) = Service $ \req -> fmap (fmap f) (run req)++instance Profunctor Service where+ dimap f g (Service run) = Service $ \req -> fmap (fmap g) (run (f req))+ lmap f (Service run) = Service (run . f)+ rmap = fmap+ -- | Middleware wraps a service to add behavior (retry, timeout, logging, etc.) -- -- A middleware is simply a function from 'Service' to 'Service':@@ -39,6 +56,8 @@ -- | Transform the response of a service, leaving errors unchanged. --+-- This is a synonym for 'fmap' on the 'Functor' instance.+-- -- @ -- let svc = 'Service' $ \\_ -> pure (Right 10) -- let doubled = 'mapService' (* 2) svc@@ -46,7 +65,34 @@ -- -- result == Right 20 -- @ mapService :: (a -> b) -> Service req a -> Service req b-mapService f (Service run) = Service $ \req -> fmap (fmap f) (run req)+mapService = fmap++-- | Transform the request type of a service.+--+-- This is a synonym for 'lmap' on the 'Profunctor' instance.+--+-- @+-- let svc :: Service String String+-- svc = 'Service' $ \\req -> pure (Right req)+-- adapted = 'contramapService' show svc -- now Service Int String+-- result <- 'runService' adapted 42+-- -- result == Right \"42\"+-- @+contramapService :: (a -> b) -> Service b res -> Service a res+contramapService = lmap++-- | Transform both request and response types of a service.+--+-- This is a synonym for 'dimap' on the 'Profunctor' instance.+-- Useful for adapting a generic service to a domain-specific API:+--+-- @+-- let httpSvc :: Service Http.Request Http.Response+-- let apiSvc = 'dimapService' toHttpRequest fromHttpResponse httpSvc+-- -- apiSvc :: Service MyRequest MyResponse+-- @+dimapService :: (a -> b) -> (c -> d) -> Service b c -> Service a d+dimapService = dimap -- | Compose two middleware, applying the outer first, then the inner. --
test/Tower/Middleware/CircuitBreakerSpec.hs view
@@ -10,6 +10,7 @@ import Tower.Service import Tower.Error import Tower.Error.Testing ()+import Data.Function ((&)) import Tower.Middleware.CircuitBreaker spec :: Spec@@ -24,7 +25,7 @@ breaker <- newCircuitBreaker let svc :: Service () String svc = Service $ \_ -> pure (Right "ok")- wrapped = withCircuitBreaker config breaker svc+ wrapped = svc & withCircuitBreaker config breaker result <- runService wrapped () result `shouldBe` Right "ok" getCircuitBreakerState breaker >>= (`shouldBe` Closed)@@ -36,7 +37,7 @@ svc = Service $ \_ -> do modifyIORef' callCount (+ 1) pure (Left (CustomError "fail"))- wrapped = withCircuitBreaker config breaker svc+ wrapped = svc & withCircuitBreaker config breaker -- 2 failures, threshold is 3 _ <- runService wrapped () _ <- runService wrapped ()@@ -48,7 +49,7 @@ breaker <- newCircuitBreaker let svc :: Service () String svc = Service $ \_ -> pure (Left (CustomError "fail"))- wrapped = withCircuitBreaker config breaker svc+ wrapped = svc & withCircuitBreaker config breaker -- 3 failures = threshold _ <- runService wrapped () _ <- runService wrapped ()@@ -62,7 +63,7 @@ failSvc = Service $ \_ -> do modifyIORef' callCount (+ 1) pure (Left (CustomError "fail"))- wrapped = withCircuitBreaker config breaker failSvc+ wrapped = failSvc & withCircuitBreaker config breaker -- Trip the breaker _ <- runService wrapped () _ <- runService wrapped ()@@ -80,7 +81,7 @@ breaker <- newCircuitBreaker let svc :: Service () String svc = Service $ \_ -> pure (Left (CustomError "fail"))- wrapped = withCircuitBreaker fastConfig breaker svc+ wrapped = svc & withCircuitBreaker fastConfig breaker -- Trip the breaker _ <- runService wrapped () _ <- runService wrapped ()@@ -104,7 +105,7 @@ if n < 3 then pure (Left (CustomError "fail")) else pure (Right "recovered")- wrapped = withCircuitBreaker fastConfig breaker svc+ wrapped = svc & withCircuitBreaker fastConfig breaker -- Trip the breaker (3 failures) _ <- runService wrapped () _ <- runService wrapped ()@@ -128,7 +129,7 @@ if n == 1 -- second call succeeds then pure (Right "ok") else pure (Left (CustomError "fail"))- wrapped = withCircuitBreaker config breaker svc+ wrapped = svc & withCircuitBreaker config breaker -- Fail once _ <- runService wrapped () -- Succeed — resets counter
test/Tower/Middleware/FilterSpec.hs view
@@ -7,6 +7,7 @@ import Tower.Service import Tower.Error import Tower.Error.Testing ()+import Data.Function ((&)) import Tower.Middleware.Filter spec :: Spec@@ -15,21 +16,21 @@ it "allows matching requests through" $ do let svc :: Service String String svc = Service $ \_ -> pure (Right "ok")- filtered = withFilter (const True) svc+ filtered = svc & withFilter (const True) 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+ filtered = svc & withFilter (const False) 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+ onlyGet = svc & withFilter (== "GET") getResult <- runService onlyGet "GET" postResult <- runService onlyGet "POST" getResult `shouldBe` Right "ok"
test/Tower/Middleware/HedgeSpec.hs view
@@ -10,6 +10,7 @@ import Tower.Service import Tower.Error import Tower.Error.Testing ()+import Data.Function ((&)) import Tower.Middleware.Hedge spec :: Spec@@ -17,7 +18,7 @@ it "returns result from fast primary without hedging" $ do let svc :: Service () String svc = Service $ \_ -> pure (Right "fast")- hedged = withHedge 1000 svc+ hedged = svc & withHedge 1000 result <- runService hedged () result `shouldBe` Right "fast" @@ -31,7 +32,7 @@ threadDelay 500_000 -- primary: slow pure (Right "primary") else pure (Right "hedge") -- hedge: instant- hedged = withHedge 50 svc+ hedged = svc & withHedge 50 result <- runService hedged () case result of Right _ -> pure ()@@ -44,7 +45,7 @@ modifyIORef' callCount (+ 1) threadDelay 100_000 pure (Right "done")- hedged = withHedge 50 svc+ hedged = svc & withHedge 50 _ <- runService hedged () threadDelay 200_000 count <- readIORef callCount
test/Tower/Middleware/LoggingSpec.hs view
@@ -10,6 +10,7 @@ import Tower.Service import Tower.Error import Tower.Error.Testing ()+import Data.Function ((&)) import Tower.Middleware.Logging spec :: Spec@@ -22,7 +23,7 @@ Left err -> "ERR: " <> displayError err svc :: Service () Text svc = Service $ \_ -> pure (Right "done")- logged = withLogging formatter logger svc+ logged = svc & withLogging formatter logger _ <- runService logged () logs <- readIORef logRef length logs `shouldBe` 1@@ -36,7 +37,7 @@ Left err -> "ERR: " <> displayError err svc :: Service () Text svc = Service $ \_ -> pure (Left TimeoutError)- logged = withLogging formatter logger svc+ logged = svc & withLogging formatter logger _ <- runService logged () logs <- readIORef logRef length logs `shouldBe` 1@@ -47,7 +48,7 @@ formatter _ _ _ = "ignored" svc :: Service () Text svc = Service $ \_ -> pure (Right "original")- logged = withLogging formatter logger svc+ logged = svc & withLogging formatter logger result <- runService logged () result `shouldBe` Right "original" @@ -57,7 +58,7 @@ formatter req _ _ = "request=" <> req svc :: Service Text Text svc = Service $ \_ -> pure (Right "ok")- logged = withLogging formatter logger svc+ logged = svc & withLogging formatter logger _ <- runService logged "my-request" logs <- readIORef logRef head logs `shouldBe` "request=my-request"
test/Tower/Middleware/RetrySpec.hs view
@@ -10,6 +10,7 @@ import Tower.Service import Tower.Error import Tower.Error.Testing ()+import Data.Function ((&)) import Tower.Middleware.Retry spec :: Spec@@ -21,7 +22,7 @@ svc = Service $ \_ -> do modifyIORef' callCount (+ 1) pure (Right "ok")- retried = withRetry (constantBackoff 3 0) svc+ retried = svc & withRetry (constantBackoff 3 0) result <- runService retried () result `shouldBe` Right "ok" readIORef callCount >>= (`shouldBe` 1)@@ -32,7 +33,7 @@ svc = Service $ \_ -> do modifyIORef' callCount (+ 1) pure (Left (CustomError "fail"))- retried = withRetry (constantBackoff 3 0) svc+ retried = svc & withRetry (constantBackoff 3 0) result <- runService retried () case result of Left (RetryExhausted n _) -> n `shouldBe` 3@@ -48,7 +49,7 @@ if n < 2 then pure (Left (CustomError "transient")) else pure (Right "recovered")- retried = withRetry (constantBackoff 3 0) svc+ retried = svc & withRetry (constantBackoff 3 0) result <- runService retried () result `shouldBe` Right "recovered" readIORef callCount >>= (`shouldBe` 3) -- 2 failures + 1 success@@ -59,7 +60,7 @@ svc = Service $ \_ -> do modifyIORef' callCount (+ 1) pure (Left (CustomError "fail"))- retried = withRetry (constantBackoff 0 0) svc+ retried = svc & withRetry (constantBackoff 0 0) result <- runService retried () case result of Left (RetryExhausted 0 _) -> pure ()
test/Tower/Middleware/TimeoutSpec.hs view
@@ -9,6 +9,7 @@ import Tower.Service import Tower.Error import Tower.Error.Testing ()+import Data.Function ((&)) import Tower.Middleware.Timeout spec :: Spec@@ -16,7 +17,7 @@ it "allows fast requests through" $ do let svc :: Service () String svc = Service $ \_ -> pure (Right "fast")- timed = withTimeout 1000 svc+ timed = svc & withTimeout 1000 result <- runService timed () result `shouldBe` Right "fast" @@ -25,13 +26,13 @@ svc = Service $ \_ -> do threadDelay 500_000 -- 500ms pure (Right "slow")- timed = withTimeout 100 svc -- 100ms timeout+ timed = svc & withTimeout 100 -- 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+ timed = svc & withTimeout 1000 result <- runService timed () result `shouldBe` Left (CustomError "inner error")
test/Tower/Middleware/TracingSpec.hs view
@@ -12,6 +12,7 @@ import Tower.Service import Tower.Error import Tower.Error.Testing ()+import Data.Function ((&)) import Tower.Middleware.Tracing spec :: Spec@@ -23,7 +24,7 @@ let config = defaultTracingConfig "test-span" svc :: Service () String svc = Service $ \_ -> pure (Right "hello")- traced = withTracingGlobal testLib config svc+ traced = svc & withTracingGlobal testLib config result <- runService traced () result `shouldBe` Right "hello" @@ -31,7 +32,7 @@ let config = defaultTracingConfig "test-span" svc :: Service () String svc = Service $ \_ -> pure (Left TimeoutError)- traced = withTracingGlobal testLib config svc+ traced = svc & withTracingGlobal testLib config result <- runService traced () result `shouldBe` Left TimeoutError @@ -42,7 +43,7 @@ svc = Service $ \_ -> do modifyIORef' callCount (+ 1) pure (Right "ok")- traced = withTracingGlobal testLib config svc+ traced = svc & withTracingGlobal testLib config _ <- runService traced () readIORef callCount >>= (`shouldBe` 1) @@ -51,7 +52,7 @@ { tracingSpanName = ("span-" <>) } svc :: Service Text String svc = Service $ \_ -> pure (Right "ok")- traced = withTracingGlobal testLib config svc+ traced = svc & withTracingGlobal testLib config result <- runService traced "test" result `shouldBe` Right "ok" @@ -61,7 +62,7 @@ { tracingReqAttrs = \_ _ -> writeIORef hookCalled True } svc :: Service () String svc = Service $ \_ -> pure (Right "ok")- traced = withTracingGlobal testLib config svc+ traced = svc & withTracingGlobal testLib config _ <- runService traced () readIORef hookCalled >>= (`shouldBe` True) @@ -71,7 +72,7 @@ { tracingResAttrs = \_ _ -> writeIORef hookCalled True } svc :: Service () String svc = Service $ \_ -> pure (Right "ok")- traced = withTracingGlobal testLib config svc+ traced = svc & withTracingGlobal testLib config _ <- runService traced () readIORef hookCalled >>= (`shouldBe` True) @@ -81,7 +82,7 @@ { tracingResAttrs = \_ _ -> writeIORef hookCalled True } svc :: Service () String svc = Service $ \_ -> pure (Left (CustomError "fail"))- traced = withTracingGlobal testLib config svc+ traced = svc & withTracingGlobal testLib config _ <- runService traced () readIORef hookCalled >>= (`shouldBe` False)
test/Tower/Middleware/TransformSpec.hs view
@@ -8,6 +8,7 @@ import Tower.Service import Tower.Error import Tower.Error.Testing ()+import Data.Function ((&)) import Tower.Middleware.Transform spec :: Spec@@ -16,26 +17,26 @@ it "transforms the request before passing to inner service" $ do let svc :: Service String String svc = Service $ \req -> pure (Right req)- transformed = withMapRequestPure (++ "!") svc+ transformed = svc & withMapRequestPure (++ "!") 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+ transformed = svc & withMapRequestPure (++ "!") 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+ transformed = svc+ & withMapRequestPure (++ "1")+ & withMapRequestPure (++ "2")+ & withMapRequestPure (++ "3") result <- runService transformed "base"- -- Middleware composes right-to-left: 1 applied first, then 2, then 3+ -- Middleware applies left-to-right: 1 applied first, then 2, then 3 result `shouldBe` Right "base321" describe "withMapRequest" $ do@@ -43,9 +44,9 @@ counter <- newIORef (0 :: Int) let svc :: Service String String svc = Service $ \req -> pure (Right req)- transformed = withMapRequest (\req -> do+ transformed = svc & withMapRequest (\req -> do n <- atomicModifyIORef' counter (\c -> (c + 1, c))- pure (req ++ "-" ++ show n)) svc+ pure (req ++ "-" ++ show n)) r1 <- runService transformed "req" r2 <- runService transformed "req" r1 `shouldBe` Right "req-0"@@ -54,6 +55,6 @@ 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+ transformed = svc & withMapRequest (\req -> pure (req ++ "!")) result <- runService transformed "hello" result `shouldBe` Left (CustomError "fail")
test/Tower/Middleware/ValidateSpec.hs view
@@ -7,6 +7,7 @@ import Tower.Service import Tower.Error import Tower.Error.Testing ()+import Data.Function ((&)) import Tower.Middleware.Validate spec :: Spec@@ -14,34 +15,34 @@ it "passes responses that return Nothing" $ do let svc :: Service () String svc = Service $ \_ -> pure (Right "ok")- validated = withValidate (const Nothing) svc+ validated = svc & withValidate (const Nothing) 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+ validated = svc & withValidate (\_ -> Just "validation failed") 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+ validated = svc & withValidate (const (Just "should not trigger")) 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+ validated = svc & withValidate (\n -> if n > 100 then Just "too big" else Nothing) 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+ validated = svc & withValidate (\n -> if n > 100 then Just "too big" else Nothing) result <- runService validated () result `shouldBe` Left (CustomError "too big")
test/Tower/ServiceSpec.hs view
@@ -6,6 +6,7 @@ import Tower.Service import Tower.Error+import Data.Function ((&)) import Tower.Error.Testing () spec :: Spec@@ -26,14 +27,14 @@ it "transforms successful responses" $ do let svc :: Service () Int svc = Service $ \_ -> pure (Right 10)- mapped = mapService (* 3) svc+ mapped = svc & mapService (* 3) 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+ mapped = svc & mapService (* 3) result <- runService mapped () result `shouldBe` Left TimeoutError
tower-hs.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: tower-hs-version: 0.1.0.0+version: 0.2.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@@ -53,6 +53,7 @@ async ==2.2.* , base >=4.14 && <5 , hs-opentelemetry-api ==0.3.*+ , profunctors ==5.6.* , stm ==2.5.* , text >=2.0 && <2.2 , time >=1.11 && <1.15