diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 1823eba3..f781068f 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -45,6 +45,7 @@ library exposed-modules: Servant Servant.Server + Servant.Server.CombinatorUtils Servant.Server.Experimental.Auth Servant.Server.Internal Servant.Server.Internal.BasicAuth @@ -132,10 +133,12 @@ test-suite spec main-is: Spec.hs other-modules: Servant.ArbitraryMonadServerSpec + Servant.Server.CombinatorUtilsSpec Servant.Server.ErrorSpec Servant.Server.Internal.ContextSpec Servant.Server.Internal.RoutingApplicationSpec Servant.Server.RouterSpec + Servant.ServerSpec Servant.Server.StreamingSpec Servant.Server.UsingContextSpec Servant.Server.UsingContextSpec.TestCombinators diff --git a/servant-server/src/Servant/Server/CombinatorUtils.hs b/servant-server/src/Servant/Server/CombinatorUtils.hs index abe4907e..c7e8dd66 100644 --- a/servant-server/src/Servant/Server/CombinatorUtils.hs +++ b/servant-server/src/Servant/Server/CombinatorUtils.hs @@ -5,9 +5,11 @@ module Servant.Server.CombinatorUtils ( RouteResult(..), argumentCombinator, + captureCombinator, ) where import Data.Proxy +import Data.Text import Network.Wai import Servant.API @@ -24,5 +26,19 @@ argumentCombinator :: -> Delayed env (Server (combinator :> api)) -> Router' env RoutingApplication argumentCombinator getArg Proxy context delayed = - route (Proxy :: Proxy api) context $ addBodyCheck delayed $ - DelayedIO $ \ request -> return $ getArg request + route (Proxy :: Proxy api) context $ addBodyCheck delayed + (DelayedIO (return ())) $ \ () -> + withRequest $ \ request -> liftRouteResult (getArg request) + +captureCombinator :: + forall api combinator arg context env . + (HasServer api context) => + (Text -> RouteResult arg) + -> Proxy (combinator :> api) + -> Context context + -> Delayed env (arg -> Server api) + -> Router' env RoutingApplication +captureCombinator getArg Proxy context delayed = + CaptureRouter $ + route (Proxy :: Proxy api) context $ addCapture delayed $ \ captured -> + (liftRouteResult (getArg captured)) diff --git a/servant-server/test/Servant/Server/CombinatorUtilsSpec.hs b/servant-server/test/Servant/Server/CombinatorUtilsSpec.hs index 217dbf4f..68f997c1 100644 --- a/servant-server/test/Servant/Server/CombinatorUtilsSpec.hs +++ b/servant-server/test/Servant/Server/CombinatorUtilsSpec.hs @@ -8,12 +8,13 @@ module Servant.Server.CombinatorUtilsSpec where -import Blaze.ByteString.Builder import Control.Concurrent +import Data.ByteString.Builder import Data.ByteString.Lazy import Data.Monoid import Data.Proxy import Data.String.Conversions +import Data.Text import Network.HTTP.Types import Network.Wai import Network.Wai.Internal @@ -49,10 +50,10 @@ spec :: Spec spec = do it "allows to write a combinator by providing a function (Request -> a)" $ do let server = return - app = serve (Proxy :: Proxy (Custom :> Get' String)) server + app = serve (Proxy :: Proxy (FooHeader :> Get' String)) server request = defaultRequest{ requestHeaders = - ("Custom", "foo") : + ("FooHeader", "foo") : requestHeaders defaultRequest } response <- runApp app request @@ -60,23 +61,57 @@ spec = do it "allows to write a combinator the errors out" $ do let server = return - app = serve (Proxy :: Proxy (Custom :> Get' String)) server + app = serve (Proxy :: Proxy (FooHeader :> Get' String)) server request = defaultRequest response <- runApp app request responseStatus response `shouldBe` status400 - it "allows to pick the phase of request consumption" $ do + it "allows to write capture combinators" $ do + let server = return + app = serve (Proxy :: Proxy (StringCapture :> Get' String)) server + request = defaultRequest{ + rawPathInfo = "/foo", + pathInfo = ["foo"] + } + response <- runApp app request + responseBodyLbs response `shouldReturn` "\"foo\"" + + it "allows to pick the request check phase" $ do + pending + + it "allows to write streaming combinators for request bodies" $ do + pending + + it "disallows to access the request body unless in the checkBody phase" $ do + pending + + it "allows to access the context" $ do + pending + + it "allows to write combinators without args" $ do + pending + + it "allows to implement combinators based in terms of existing combinators" $ do pending type Get' = Get '[JSON] -data Custom +data FooHeader -instance HasServer api context => HasServer (Custom :> api) context where - type ServerT (Custom :> api) m = String -> ServerT api m +instance HasServer api context => HasServer (FooHeader :> api) context where + type ServerT (FooHeader :> api) m = String -> ServerT api m route = argumentCombinator getCustom getCustom :: Request -> RouteResult String -getCustom request = case lookup "Custom" (requestHeaders request) of +getCustom request = case lookup "FooHeader" (requestHeaders request) of Nothing -> FailFatal err400 Just l -> Route $ cs l + +data StringCapture + +instance HasServer api context => HasServer (StringCapture :> api) context where + type ServerT (StringCapture :> api) m = String -> ServerT api m + route = captureCombinator getCapture + +getCapture :: Text -> RouteResult String +getCapture = Route . cs