From 641ee69eba1d414cabd444a0e7a722af459e7e55 Mon Sep 17 00:00:00 2001 From: Alp Mestanogullari Date: Tue, 28 Oct 2014 14:34:28 +0100 Subject: [PATCH] improve the routing mechanism by augmenting the routing error type with some information and a sound monoid instance. this addresses #10 --- src/Servant/API/Capture.hs | 4 +-- src/Servant/API/Delete.hs | 6 ++-- src/Servant/API/Get.hs | 6 ++-- src/Servant/API/Post.hs | 6 ++-- src/Servant/API/Put.hs | 7 +++-- src/Servant/API/RQBody.hs | 2 +- src/Servant/API/Raw.hs | 2 +- src/Servant/API/Sub.hs | 2 +- src/Servant/API/Union.hs | 15 ++++++---- src/Servant/Server.hs | 56 ++++++++++++++++++++++++++++++++++---- test/Servant/ServerSpec.hs | 4 +-- 11 files changed, 85 insertions(+), 25 deletions(-) diff --git a/src/Servant/API/Capture.hs b/src/Servant/API/Capture.hs index a3e5ffea..428934f5 100644 --- a/src/Servant/API/Capture.hs +++ b/src/Servant/API/Capture.hs @@ -31,11 +31,11 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout) route Proxy subserver request respond = case pathInfo request of (first : rest) -> case captured captureProxy first of - Nothing -> respond Nothing + Nothing -> respond $ failWith NotFound Just v -> route (Proxy :: Proxy sublayout) (subserver v) request{ pathInfo = rest } respond - _ -> respond Nothing + _ -> respond $ failWith NotFound where captureProxy = Proxy :: Proxy (Capture capture a) diff --git a/src/Servant/API/Delete.hs b/src/Servant/API/Delete.hs index 5dcc0bf1..fb1a7982 100644 --- a/src/Servant/API/Delete.hs +++ b/src/Servant/API/Delete.hs @@ -26,12 +26,14 @@ instance HasServer Delete where route Proxy action request respond | null (pathInfo request) && requestMethod request == methodDelete = do e <- runEitherT action - respond $ Just $ case e of + respond $ succeedWith $ case e of Right () -> responseLBS status204 [] "" Left (status, message) -> responseLBS (mkStatus status (cs message)) [] (cs message) - | otherwise = respond Nothing + | null (pathInfo request) && requestMethod request /= methodDelete = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound instance HasClient Delete where type Client Delete = URI -> EitherT String IO () diff --git a/src/Servant/API/Get.hs b/src/Servant/API/Get.hs index 7e21e44e..0598b372 100644 --- a/src/Servant/API/Get.hs +++ b/src/Servant/API/Get.hs @@ -27,12 +27,14 @@ instance ToJSON result => HasServer (Get result) where route Proxy action request respond | null (pathInfo request) && requestMethod request == methodGet = do e <- runEitherT action - respond $ Just $ case e of + respond . succeedWith $ case e of Right output -> responseLBS ok200 [("Content-Type", "application/json")] (encode output) Left (status, message) -> responseLBS (mkStatus status (cs message)) [] (cs message) - | otherwise = respond Nothing + | null (pathInfo request) && requestMethod request /= methodGet = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound instance FromJSON result => HasClient (Get result) where type Client (Get result) = URI -> EitherT String IO result diff --git a/src/Servant/API/Post.hs b/src/Servant/API/Post.hs index cfb0f10c..c4f0044c 100644 --- a/src/Servant/API/Post.hs +++ b/src/Servant/API/Post.hs @@ -29,12 +29,14 @@ instance ToJSON a => HasServer (Post a) where route Proxy action request respond | null (pathInfo request) && requestMethod request == methodPost = do e <- runEitherT action - respond $ Just $ case e of + respond . succeedWith $ case e of Right out -> responseLBS status201 [("Content-Type", "application/json")] (encode out) Left (status, message) -> responseLBS (mkStatus status (cs message)) [] (cs message) - | otherwise = respond Nothing + | null (pathInfo request) && requestMethod request /= methodPost = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound instance FromJSON a => HasClient (Post a) where type Client (Post a) = URI -> EitherT String IO a diff --git a/src/Servant/API/Put.hs b/src/Servant/API/Put.hs index 86f8b87f..3b2e2d51 100644 --- a/src/Servant/API/Put.hs +++ b/src/Servant/API/Put.hs @@ -27,12 +27,15 @@ instance ToJSON a => HasServer (Put a) where route Proxy action request respond | null (pathInfo request) && requestMethod request == methodPut = do e <- runEitherT action - respond $ Just $ case e of + respond . succeedWith $ case e of Right out -> responseLBS ok200 [("Content-Type", "application/json")] (encode out) Left (status, message) -> responseLBS (mkStatus status (cs message)) [] (cs message) - | otherwise = respond Nothing + | null (pathInfo request) && requestMethod request /= methodPut = + respond $ failWith WrongMethod + + | otherwise = respond $ failWith NotFound instance FromJSON a => HasClient (Put a) where type Client (Put a) = URI -> EitherT String IO a diff --git a/src/Servant/API/RQBody.hs b/src/Servant/API/RQBody.hs index 5696dbdc..3805d9f7 100644 --- a/src/Servant/API/RQBody.hs +++ b/src/Servant/API/RQBody.hs @@ -26,7 +26,7 @@ instance (FromJSON a, HasServer sublayout) route Proxy subserver request respond = do mrqbody <- decode' <$> lazyRequestBody request case mrqbody of - Nothing -> respond Nothing + Nothing -> respond $ failWith NotFound Just v -> route (Proxy :: Proxy sublayout) (subserver v) request respond instance (ToJSON a, HasClient sublayout) diff --git a/src/Servant/API/Raw.hs b/src/Servant/API/Raw.hs index c530da20..d26d3855 100644 --- a/src/Servant/API/Raw.hs +++ b/src/Servant/API/Raw.hs @@ -15,4 +15,4 @@ data Raw instance HasServer Raw where type Server Raw = Application route Proxy rawApplication request respond = - rawApplication request (respond . Just) + rawApplication request (respond . succeedWith) diff --git a/src/Servant/API/Sub.hs b/src/Servant/API/Sub.hs index 9abc8da8..710728b3 100644 --- a/src/Servant/API/Sub.hs +++ b/src/Servant/API/Sub.hs @@ -25,7 +25,7 @@ instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout -> route (Proxy :: Proxy sublayout) subserver request{ pathInfo = rest } respond - _ -> respond Nothing + _ -> respond $ failWith NotFound where proxyPath = Proxy :: Proxy path diff --git a/src/Servant/API/Union.hs b/src/Servant/API/Union.hs index 8d2b710a..6fd51aea 100644 --- a/src/Servant/API/Union.hs +++ b/src/Servant/API/Union.hs @@ -14,11 +14,16 @@ infixr 8 :<|> instance (HasServer a, HasServer b) => HasServer (a :<|> b) where type Server (a :<|> b) = Server a :<|> Server b - route Proxy (a :<|> b) request respond = do - route (Proxy :: Proxy a) a request $ \ mResponse -> - case mResponse of - Nothing -> route (Proxy :: Proxy b) b request respond - Just resp -> respond $ Just resp + route Proxy (a :<|> b) request respond = + route pa a request $ \ mResponse -> + case isMismatch mResponse of + True -> route pb b request $ \mResponse' -> + respond (mResponse <> mResponse') + False -> respond mResponse + + + where pa = Proxy :: Proxy a + pb = Proxy :: Proxy b instance (HasClient a, HasClient b) => HasClient (a :<|> b) where type Client (a :<|> b) = Client a :<|> Client b diff --git a/src/Servant/Server.hs b/src/Servant/Server.hs index 1ca83e74..e272d304 100644 --- a/src/Servant/Server.hs +++ b/src/Servant/Server.hs @@ -7,6 +7,7 @@ module Servant.Server where +import Data.Monoid import Data.Proxy import Network.HTTP.Types import Network.Wai @@ -19,17 +20,62 @@ serve p server = toApplication (route p server) toApplication :: RoutingApplication -> Application toApplication ra request respond = do - ra request routingRespond + ra request (routingRespond . routeResult) where - routingRespond :: Maybe Response -> IO ResponseReceived - routingRespond Nothing = + routingRespond :: Either RouteMismatch Response -> IO ResponseReceived + routingRespond (Left NotFound) = respond $ responseLBS notFound404 [] "not found" - routingRespond (Just response) = + routingRespond (Left WrongMethod) = + respond $ responseLBS methodNotAllowed405 [] "method not allowed" + routingRespond (Right response) = respond response +-- * Route mismatch +data RouteMismatch = + NotFound -- ^ the usual "not found" error + | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error + deriving (Eq, Show) + +-- | +-- @ +-- 'NotFound' <> x = x +-- 'WrongMethod' <> _ = 'WrongMethod' +-- @ +instance Monoid RouteMismatch where + mempty = NotFound + + NotFound `mappend` x = x + WrongMethod `mappend` _ = WrongMethod + +-- | A wrapper around @'Either' 'RouteMismatch' a@. +newtype RouteResult a = + RR { routeResult :: Either RouteMismatch a } + deriving (Eq, Show) + +failWith :: RouteMismatch -> RouteResult a +failWith = RR . Left + +succeedWith :: a -> RouteResult a +succeedWith = RR . Right + +isMismatch :: RouteResult a -> Bool +isMismatch (RR (Left _)) = True +isMismatch _ = False + +-- | If we get a `Right`, it has precedence over everything else. +-- +-- This in particular means that if we could get several 'Right's, +-- only the first we encounter would be taken into account. +instance Monoid (RouteResult a) where + mempty = RR $ Left mempty + + RR (Left x) `mappend` RR (Left y) = RR $ Left (x <> y) + RR (Left _) `mappend` RR (Right y) = RR $ Right y + r `mappend` _ = r + type RoutingApplication = Request -- ^ the request, the field 'pathInfo' may be modified by url routing - -> (Maybe Response -> IO ResponseReceived) -> IO ResponseReceived + -> (RouteResult 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 1e8113ec..de122695 100644 --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -113,8 +113,8 @@ getSpec = do liftIO $ do decode' (simpleBody response) `shouldBe` Just alice - it "throws 404 on POSTs" $ do - post "/" "" `shouldRespondWith` 404 + it "throws 405 (wrong method) on POSTs" $ do + post "/" "" `shouldRespondWith` 405 type GetParamApi = GetParam "name" String :> Get Person