improve the routing mechanism by augmenting the routing error type with some information and a sound monoid instance. this addresses

This commit is contained in:
Alp Mestanogullari 2014-10-28 14:34:28 +01:00
parent 71de673df2
commit 641ee69eba
11 changed files with 85 additions and 25 deletions

View file

@ -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)

View file

@ -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 ()

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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)

View file

@ -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)

View file

@ -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

View file

@ -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

View file

@ -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 :: *

View file

@ -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