diff --git a/servant.cabal b/servant.cabal index 342b3afe..3ce50d87 100644 --- a/servant.cabal +++ b/servant.cabal @@ -23,6 +23,7 @@ library Servant.API.Get Servant.API.GetParam Servant.API.Post + Servant.API.Raw Servant.API.RQBody Servant.API.Sub Servant.API.Union diff --git a/src/Servant/API/Capture.hs b/src/Servant/API/Capture.hs index c6f2c38c..1794498f 100644 --- a/src/Servant/API/Capture.hs +++ b/src/Servant/API/Capture.hs @@ -26,14 +26,14 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout) type Server (Capture capture a :> sublayout) = a -> Server sublayout - route Proxy subserver request = case pathInfo request of + route Proxy subserver globalPathInfo request respond = case pathInfo request of (first : rest) -> case captured captureProxy first of - Nothing -> return Nothing - Just v -> route (Proxy :: Proxy sublayout) (subserver v) request{ + Nothing -> respond Nothing + Just v -> route (Proxy :: Proxy sublayout) (subserver v) globalPathInfo request{ pathInfo = rest - } - _ -> return Nothing + } respond + _ -> respond Nothing where captureProxy = Proxy :: Proxy (Capture capture a) diff --git a/src/Servant/API/Get.hs b/src/Servant/API/Get.hs index 26b7d562..a4eaf65e 100644 --- a/src/Servant/API/Get.hs +++ b/src/Servant/API/Get.hs @@ -22,15 +22,15 @@ data Get a instance ToJSON result => HasServer (Get result) where type Server (Get result) = EitherT (Int, String) IO result - route Proxy action request + route Proxy action _globalPathInfo request respond | null (pathInfo request) && requestMethod request == methodGet = do e <- runEitherT action - return $ Just $ case e of + respond $ Just $ case e of Right output -> responseLBS ok200 [("Content-Type", "application/json")] (encode output) Left (status, message) -> responseLBS (mkStatus status (cs message)) [] (cs message) - | otherwise = return Nothing + | otherwise = respond Nothing instance FromJSON result => HasClient (Get result) where type Client (Get result) = URI -> EitherT String IO result diff --git a/src/Servant/API/GetParam.hs b/src/Servant/API/GetParam.hs index fbc120fa..c0eacec3 100644 --- a/src/Servant/API/GetParam.hs +++ b/src/Servant/API/GetParam.hs @@ -25,7 +25,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) type Server (GetParam sym a :> sublayout) = Maybe a -> Server sublayout - route Proxy subserver request = do + route Proxy subserver globalPathInfo request respond = do let querytext = parseQueryText $ rawQueryString request param = case lookup paramName querytext of @@ -34,7 +34,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) Just (Just v) -> fromText v -- if present, we try to convert to -- the right type - route (Proxy :: Proxy sublayout) (subserver param) request + route (Proxy :: Proxy sublayout) (subserver param) globalPathInfo request respond where paramName = cs $ symbolVal (Proxy :: Proxy sym) diff --git a/src/Servant/API/Post.hs b/src/Servant/API/Post.hs index 3c0c15ad..5bee0ccc 100644 --- a/src/Servant/API/Post.hs +++ b/src/Servant/API/Post.hs @@ -22,15 +22,15 @@ data Post a instance ToJSON a => HasServer (Post a) where type Server (Post a) = EitherT (Int, String) IO a - route Proxy action request + route Proxy action _globalPathInfo request respond | null (pathInfo request) && requestMethod request == methodPost = do e <- runEitherT action - return $ Just $ case e of + respond $ Just $ case e of Right out -> responseLBS status201 [("Content-Type", "application/json")] (encode out) Left (status, message) -> responseLBS (mkStatus status (cs message)) [] (cs message) - | otherwise = return Nothing + | otherwise = respond Nothing instance FromJSON a => HasClient (Post a) where type Client (Post a) = URI -> EitherT String IO a diff --git a/src/Servant/API/RQBody.hs b/src/Servant/API/RQBody.hs index 624263a6..caa2c1dc 100644 --- a/src/Servant/API/RQBody.hs +++ b/src/Servant/API/RQBody.hs @@ -22,11 +22,11 @@ instance (FromJSON a, HasServer sublayout) type Server (RQBody a :> sublayout) = a -> Server sublayout - route Proxy subserver request = do + route Proxy subserver globalPathInfo request respond = do mrqbody <- decode' <$> lazyRequestBody request case mrqbody of - Nothing -> return Nothing - Just v -> route (Proxy :: Proxy sublayout) (subserver v) request + Nothing -> respond Nothing + Just v -> route (Proxy :: Proxy sublayout) (subserver v) globalPathInfo request respond instance (ToJSON a, HasClient sublayout) => HasClient (RQBody a :> sublayout) where diff --git a/src/Servant/API/Raw.hs b/src/Servant/API/Raw.hs new file mode 100644 index 00000000..103864b8 --- /dev/null +++ b/src/Servant/API/Raw.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +module Servant.API.Raw where + +import Data.Proxy +import Network.Wai +import Servant.Server + +-- | Endpoint for plugging in your own Wai 'Application's. +-- The given Application will get the original request received by the server +-- (i.e. with unmodified 'pathInfo', etc.) +data Raw + +instance HasServer Raw where + type Server Raw = Application + route Proxy rawApplication globalPathInfo request respond = + rawApplication request{pathInfo = globalPathInfo} (respond . Just) diff --git a/src/Servant/API/Sub.hs b/src/Servant/API/Sub.hs index 5c402c06..f7ba499e 100644 --- a/src/Servant/API/Sub.hs +++ b/src/Servant/API/Sub.hs @@ -18,13 +18,13 @@ infixr 9 :> instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where type Server (path :> sublayout) = Server sublayout - route Proxy subserver request = case pathInfo request of + route Proxy subserver globalPathInfo request respond = case pathInfo request of (first : rest) | first == cs (symbolVal proxyPath) - -> route (Proxy :: Proxy sublayout) subserver request{ + -> route (Proxy :: Proxy sublayout) subserver globalPathInfo request{ pathInfo = rest - } - _ -> return Nothing + } respond + _ -> respond Nothing where proxyPath = Proxy :: Proxy path diff --git a/src/Servant/API/Union.hs b/src/Servant/API/Union.hs index 55c392b6..87278a83 100644 --- a/src/Servant/API/Union.hs +++ b/src/Servant/API/Union.hs @@ -13,14 +13,14 @@ infixr 8 :<|> instance (HasServer a, HasServer b) => HasServer (a :<|> b) where type Server (a :<|> b) = Server a :<|> Server b - route Proxy (a :<|> b) request = do - m <- route (Proxy :: Proxy a) a request - case m of - Nothing -> route (Proxy :: Proxy b) b request - Just response -> return $ Just response + route Proxy (a :<|> b) globalPathInfo request respond = do + route (Proxy :: Proxy a) a globalPathInfo request $ \ mResponse -> + case mResponse of + Nothing -> route (Proxy :: Proxy b) b globalPathInfo request respond + Just response -> respond $ Just response instance (HasClient a, HasClient b) => HasClient (a :<|> b) where type Client (a :<|> b) = Client a :<|> Client b clientWithRoute Proxy req = clientWithRoute (Proxy :: Proxy a) req :<|> - clientWithRoute (Proxy :: Proxy b) req \ No newline at end of file + clientWithRoute (Proxy :: Proxy b) req diff --git a/src/Servant/Server.hs b/src/Servant/Server.hs index bc6e7e6a..8224943f 100644 --- a/src/Servant/Server.hs +++ b/src/Servant/Server.hs @@ -3,6 +3,7 @@ module Servant.Server where import Data.Proxy +import Data.Text import Network.HTTP.Types import Network.Wai @@ -13,14 +14,19 @@ serve :: HasServer layout => Proxy layout -> Server layout -> Application serve p server = toApplication (route p server) toApplication :: RoutingApplication -> Application -toApplication ra = \ request respond -> do - m <- ra request - case m of - Nothing -> respond $ responseLBS notFound404 [] "not found" - Just response -> respond response +toApplication ra request respond = do + ra (pathInfo request) request routingRespond + where + routingRespond :: Maybe Response -> IO ResponseReceived + routingRespond Nothing = + respond $ responseLBS notFound404 [] "not found" + routingRespond (Just response) = + respond response type RoutingApplication = - Request -> IO (Maybe Response) + [Text] -- ^ the unmodified 'pathInfo' + -> Request -- ^ the request, the field 'pathInfo' may be modified by url routing + -> (Maybe Response -> IO ResponseReceived) -> IO ResponseReceived class HasServer layout where type Server layout :: * diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs index 87ef2aac..c690f1e4 100644 --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -10,6 +10,7 @@ module Servant.ServerSpec where import Data.Aeson import Data.Proxy +import Data.String.Conversions import GHC.Generics import Network.HTTP.Types import Network.Wai @@ -20,6 +21,7 @@ import Test.Hspec.Wai import Servant.API.Get import Servant.API.GetParam import Servant.API.Post +import Servant.API.Raw import Servant.API.RQBody import Servant.API.Sub import Servant.API.Union @@ -60,6 +62,7 @@ spec = do getSpec getParamSpec postSpec + rawSpec unionSpec @@ -67,7 +70,8 @@ type GetApi = Get Person getApi :: Proxy GetApi getApi = Proxy -getSpec :: Spec = do +getSpec :: Spec +getSpec = do describe "Servant.API.Get" $ do with (return (serve getApi (return alice))) $ do it "allows to GET a Person" $ do @@ -118,6 +122,32 @@ postSpec = do } +type RawApi = "foo" :> Raw +rawApi :: Proxy RawApi +rawApi = Proxy +rawApplication :: Show a => (Request -> a) -> Application +rawApplication f request respond = respond $ responseLBS ok200 [] (cs $ show $ f request) + +rawSpec :: Spec +rawSpec = do + describe "Servant.API.Raw" $ do + it "runs applications" $ do + (flip runSession) (serve rawApi (rawApplication (const (42 :: Integer)))) $ do + response <- Network.Wai.Test.request defaultRequest{ + pathInfo = ["foo"] + } + liftIO $ do + simpleBody response `shouldBe` "42" + + it "gets the pathInfo unmodified" $ do + (flip runSession) (serve rawApi (rawApplication pathInfo)) $ do + response <- Network.Wai.Test.request defaultRequest{ + pathInfo = ["foo"] + } + liftIO $ do + simpleBody response `shouldBe` cs (show ["foo" :: String]) + + type UnionApi = "foo" :> Get Person :<|> "bar" :> Get Animal