improve the routing mechanism by augmenting the routing error type with some information and a sound monoid instance. this addresses #10
This commit is contained in:
parent
71de673df2
commit
641ee69eba
11 changed files with 85 additions and 25 deletions
|
@ -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)
|
||||
|
||||
|
|
|
@ -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 ()
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 :: *
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue