diff --git a/servant-server/src/Servant/Server/CombinatorUtils.hs b/servant-server/src/Servant/Server/CombinatorUtils.hs index 3fca9b57..c1ca2f69 100644 --- a/servant-server/src/Servant/Server/CombinatorUtils.hs +++ b/servant-server/src/Servant/Server/CombinatorUtils.hs @@ -7,11 +7,11 @@ module Servant.Server.CombinatorUtils ( CombinatorImplementation, runCI, - implementCaptureCombinator, - implementRequestCheck, - implementAuthCombinator, - argumentCombinator, - implementRequestStreamingCombinator, + makeCaptureCombinator, + makeRequestCheckCombinator, + makeAuthCombinator, + makeReqBodyCombinator, + makeCombinator, -- * re-exports @@ -46,57 +46,57 @@ runCI :: CombinatorImplementation combinator arg api context -> Router' env RoutingApplication runCI (CI i) = i -implementCaptureCombinator :: +makeCaptureCombinator :: forall api combinator arg context . (HasServer api context, WithArg arg (ServerT api Handler) ~ (arg -> ServerT api Handler)) => (Text -> RouteResult arg) -> CombinatorImplementation combinator arg api context -implementCaptureCombinator getArg = CI $ \ Proxy context delayed -> +makeCaptureCombinator getArg = CI $ \ Proxy context delayed -> CaptureRouter $ route (Proxy :: Proxy api) context $ addCapture delayed $ \ captured -> (liftRouteResult (getArg captured)) -implementRequestCheck :: +makeRequestCheckCombinator :: forall api combinator context . (HasServer api context, WithArg () (ServerT api Handler) ~ ServerT api Handler) => (Request -> RouteResult ()) -> CombinatorImplementation combinator () api context -implementRequestCheck check = CI $ \ Proxy context delayed -> +makeRequestCheckCombinator check = CI $ \ Proxy context delayed -> route (Proxy :: Proxy api) context $ addMethodCheck delayed $ withRequest $ \ request -> liftRouteResult $ check request -implementAuthCombinator :: +makeAuthCombinator :: forall api combinator arg context . (HasServer api context, WithArg arg (ServerT api Handler) ~ (arg -> ServerT api Handler)) => (Request -> RouteResult arg) -> CombinatorImplementation combinator arg api context -implementAuthCombinator authCheck = CI $ \ Proxy context delayed -> +makeAuthCombinator authCheck = CI $ \ Proxy context delayed -> route (Proxy :: Proxy api) context $ addAuthCheck delayed $ withRequest $ \ request -> liftRouteResult $ authCheck request -argumentCombinator :: - forall api combinator arg context . - (ServerT (combinator :> api) Handler ~ (arg -> ServerT api Handler), - WithArg arg (ServerT api Handler) ~ (arg -> ServerT api Handler), - HasServer api context) => - (Request -> RouteResult arg) - -> CombinatorImplementation combinator arg api context -argumentCombinator getArg = CI $ \ Proxy context delayed -> - route (Proxy :: Proxy api) context $ addBodyCheck delayed -- fixme: shouldn't be body - (return ()) - (\ () -> withRequest $ \ request -> liftRouteResult (getArg request)) - -implementRequestStreamingCombinator :: +makeReqBodyCombinator :: forall api combinator arg context . (ServerT (combinator :> api) Handler ~ (arg -> ServerT api Handler), WithArg arg (ServerT api Handler) ~ (arg -> ServerT api Handler), HasServer api context) => (IO ByteString -> arg) -> CombinatorImplementation combinator arg api context -implementRequestStreamingCombinator getArg = CI $ \ Proxy context delayed -> +makeReqBodyCombinator getArg = CI $ \ Proxy context delayed -> route (Proxy :: Proxy api) context $ addBodyCheck delayed (return ()) (\ () -> withRequest $ \ request -> liftRouteResult $ Route $ getArg $ requestBody request) + +makeCombinator :: + forall api combinator arg context . + (ServerT (combinator :> api) Handler ~ (arg -> ServerT api Handler), + WithArg arg (ServerT api Handler) ~ (arg -> ServerT api Handler), + HasServer api context) => + (Request -> RouteResult arg) + -> CombinatorImplementation combinator arg api context +makeCombinator getArg = CI $ \ Proxy context delayed -> + route (Proxy :: Proxy api) context $ addBodyCheck delayed -- fixme: shouldn't be body + (return ()) + (\ () -> withRequest $ \ request -> liftRouteResult $ getArg request) diff --git a/servant-server/test/Servant/Server/CombinatorUtilsSpec.hs b/servant-server/test/Servant/Server/CombinatorUtilsSpec.hs index f33a829e..f8a0c4bd 100644 --- a/servant-server/test/Servant/Server/CombinatorUtilsSpec.hs +++ b/servant-server/test/Servant/Server/CombinatorUtilsSpec.hs @@ -176,7 +176,7 @@ data StringCapture instance HasServer api context => HasServer (StringCapture :> api) context where type ServerT (StringCapture :> api) m = String -> ServerT api m - route = runCI $ implementCaptureCombinator getCapture + route = runCI $ makeCaptureCombinator getCapture getCapture :: Text -> RouteResult String getCapture = \case @@ -187,7 +187,7 @@ data CheckFooHeader instance HasServer api context => HasServer (CheckFooHeader :> api) context where type ServerT (CheckFooHeader :> api) m = ServerT api m - route = runCI $ implementRequestCheck checkFooHeader + route = runCI $ makeRequestCheckCombinator checkFooHeader checkFooHeader :: Request -> RouteResult () checkFooHeader request = case lookup "Foo" (requestHeaders request) of @@ -201,7 +201,7 @@ data User = User String instance HasServer api context => HasServer (AuthCombinator :> api) context where type ServerT (AuthCombinator :> api) m = User -> ServerT api m - route = runCI $ implementAuthCombinator checkAuth + route = runCI $ makeAuthCombinator checkAuth checkAuth :: Request -> RouteResult User checkAuth request = case lookup "Auth" (requestHeaders request) of @@ -213,7 +213,7 @@ data FooHeader instance HasServer api context => HasServer (FooHeader :> api) context where type ServerT (FooHeader :> api) m = String -> ServerT api m - route = runCI $ argumentCombinator getCustom + route = runCI $ makeCombinator getCustom getCustom :: Request -> RouteResult String getCustom request = case lookup "Foo" (requestHeaders request) of @@ -226,7 +226,7 @@ data Source = Source (IO SBS.ByteString) instance HasServer api context => HasServer (StreamRequest :> api) context where type ServerT (StreamRequest :> api) m = Source -> ServerT api m - route = runCI $ implementRequestStreamingCombinator getSource + route = runCI $ makeReqBodyCombinator getSource getSource :: IO SBS.ByteString -> Source getSource = Source