git.iko.soy/typeable/servant
on master help sign in
improve the routing mechanism by augmenting the routing error type with some information and a sound monoid instance. this addresses #10
commit641ee69eba1d414cabd444a0e7a722af459e7e55 authorAlp Mestanogullari <alpmestan@gmail.com> dateTue 28 Oct 2014, 14:34 (12 years ago) parent71de673
11 files changed+85−25
compare with master
unifiedsplit
src/Servant/API/Capture.hs+2−2 src/Servant/API/Delete.hs+4−2 src/Servant/API/Get.hs+4−2 src/Servant/API/Post.hs+4−2 src/Servant/API/Put.hs+5−2 src/Servant/API/RQBody.hs+1−1 src/Servant/API/Raw.hs+1−1 src/Servant/API/Sub.hs+1−1 src/Servant/API/Union.hs+10−5 src/Servant/Server.hs+51−5 test/Servant/ServerSpec.hs+2−2
src/Servant/API/Capture.hs+2−2
@@ -31,11 +31,11 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout)
3131 route Proxy subserver request respond = case pathInfo request of
3232 (first : rest)
3333 -> case captured captureProxy first of
34− Nothing -> respond Nothing
34+ Nothing -> respond $ failWith NotFound
3535 Just v -> route (Proxy :: Proxy sublayout) (subserver v) request{
3636 pathInfo = rest
3737 } respond
38− _ -> respond Nothing
38+ _ -> respond $ failWith NotFound
3939
4040 where captureProxy = Proxy :: Proxy (Capture capture a)
4141
src/Servant/API/Delete.hs+4−2
@@ -26,12 +26,14 @@ instance HasServer Delete where
2626 route Proxy action request respond
2727 | null (pathInfo request) && requestMethod request == methodDelete = do
2828 e <- runEitherT action
29− respond $ Just $ case e of
29+ respond $ succeedWith $ case e of
3030 Right () ->
3131 responseLBS status204 [] ""
3232 Left (status, message) ->
3333 responseLBS (mkStatus status (cs message)) [] (cs message)
34− | otherwise = respond Nothing
34+ | null (pathInfo request) && requestMethod request /= methodDelete =
35+ respond $ failWith WrongMethod
36+ | otherwise = respond $ failWith NotFound
3537
3638instance HasClient Delete where
3739 type Client Delete = URI -> EitherT String IO ()
src/Servant/API/Get.hs+4−2
@@ -27,12 +27,14 @@ instance ToJSON result => HasServer (Get result) where
2727 route Proxy action request respond
2828 | null (pathInfo request) && requestMethod request == methodGet = do
2929 e <- runEitherT action
30− respond $ Just $ case e of
30+ respond . succeedWith $ case e of
3131 Right output ->
3232 responseLBS ok200 [("Content-Type", "application/json")] (encode output)
3333 Left (status, message) ->
3434 responseLBS (mkStatus status (cs message)) [] (cs message)
35− | otherwise = respond Nothing
35+ | null (pathInfo request) && requestMethod request /= methodGet =
36+ respond $ failWith WrongMethod
37+ | otherwise = respond $ failWith NotFound
3638
3739instance FromJSON result => HasClient (Get result) where
3840 type Client (Get result) = URI -> EitherT String IO result
src/Servant/API/Post.hs+4−2
@@ -29,12 +29,14 @@ instance ToJSON a => HasServer (Post a) where
2929 route Proxy action request respond
3030 | null (pathInfo request) && requestMethod request == methodPost = do
3131 e <- runEitherT action
32− respond $ Just $ case e of
32+ respond . succeedWith $ case e of
3333 Right out ->
3434 responseLBS status201 [("Content-Type", "application/json")] (encode out)
3535 Left (status, message) ->
3636 responseLBS (mkStatus status (cs message)) [] (cs message)
37− | otherwise = respond Nothing
37+ | null (pathInfo request) && requestMethod request /= methodPost =
38+ respond $ failWith WrongMethod
39+ | otherwise = respond $ failWith NotFound
3840
3941instance FromJSON a => HasClient (Post a) where
4042 type Client (Post a) = URI -> EitherT String IO a
src/Servant/API/Put.hs+5−2
@@ -27,12 +27,15 @@ instance ToJSON a => HasServer (Put a) where
2727 route Proxy action request respond
2828 | null (pathInfo request) && requestMethod request == methodPut = do
2929 e <- runEitherT action
30− respond $ Just $ case e of
30+ respond . succeedWith $ case e of
3131 Right out ->
3232 responseLBS ok200 [("Content-Type", "application/json")] (encode out)
3333 Left (status, message) ->
3434 responseLBS (mkStatus status (cs message)) [] (cs message)
35− | otherwise = respond Nothing
35+ | null (pathInfo request) && requestMethod request /= methodPut =
36+ respond $ failWith WrongMethod
37+
38+ | otherwise = respond $ failWith NotFound
3639
3740instance FromJSON a => HasClient (Put a) where
3841 type Client (Put a) = URI -> EitherT String IO a
src/Servant/API/RQBody.hs+1−1
@@ -26,7 +26,7 @@ instance (FromJSON a, HasServer sublayout)
2626 route Proxy subserver request respond = do
2727 mrqbody <- decode' <$> lazyRequestBody request
2828 case mrqbody of
29− Nothing -> respond Nothing
29+ Nothing -> respond $ failWith NotFound
3030 Just v -> route (Proxy :: Proxy sublayout) (subserver v) request respond
3131
3232instance (ToJSON a, HasClient sublayout)
src/Servant/API/Raw.hs+1−1
@@ -15,4 +15,4 @@ data Raw
1515instance HasServer Raw where
1616 type Server Raw = Application
1717 route Proxy rawApplication request respond =
18− rawApplication request (respond . Just)
18+ rawApplication request (respond . succeedWith)
src/Servant/API/Sub.hs+1−1
@@ -25,7 +25,7 @@ instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout
2525 -> route (Proxy :: Proxy sublayout) subserver request{
2626 pathInfo = rest
2727 } respond
28− _ -> respond Nothing
28+ _ -> respond $ failWith NotFound
2929
3030 where proxyPath = Proxy :: Proxy path
3131
src/Servant/API/Union.hs+10−5
@@ -14,11 +14,16 @@ infixr 8 :<|>
1414
1515instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
1616 type Server (a :<|> b) = Server a :<|> Server b
17− route Proxy (a :<|> b) request respond = do
18− route (Proxy :: Proxy a) a request $ \ mResponse ->
19− case mResponse of
20− Nothing -> route (Proxy :: Proxy b) b request respond
21− Just resp -> respond $ Just resp
17+ route Proxy (a :<|> b) request respond =
18+ route pa a request $ \ mResponse ->
19+ case isMismatch mResponse of
20+ True -> route pb b request $ \mResponse' ->
21+ respond (mResponse <> mResponse')
22+ False -> respond mResponse
23+
24+
25+ where pa = Proxy :: Proxy a
26+ pb = Proxy :: Proxy b
2227
2328instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
2429 type Client (a :<|> b) = Client a :<|> Client b
src/Servant/Server.hs+51−5
@@ -7,6 +7,7 @@
77
88module Servant.Server where
99
10+import Data.Monoid
1011import Data.Proxy
1112import Network.HTTP.Types
1213import Network.Wai
@@ -19,17 +20,62 @@ serve p server = toApplication (route p server)
1920
2021toApplication :: RoutingApplication -> Application
2122toApplication ra request respond = do
22− ra request routingRespond
23+ ra request (routingRespond . routeResult)
2324 where
24− routingRespond :: Maybe Response -> IO ResponseReceived
25− routingRespond Nothing =
25+ routingRespond :: Either RouteMismatch Response -> IO ResponseReceived
26+ routingRespond (Left NotFound) =
2627 respond $ responseLBS notFound404 [] "not found"
27− routingRespond (Just response) =
28+ routingRespond (Left WrongMethod) =
29+ respond $ responseLBS methodNotAllowed405 [] "method not allowed"
30+ routingRespond (Right response) =
2831 respond response
2932
33+-- * Route mismatch
34+data RouteMismatch =
35+ NotFound -- ^ the usual "not found" error
36+ | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error
37+ deriving (Eq, Show)
38+
39+-- |
40+-- @
41+-- 'NotFound' <> x = x
42+-- 'WrongMethod' <> _ = 'WrongMethod'
43+-- @
44+instance Monoid RouteMismatch where
45+ mempty = NotFound
46+
47+ NotFound `mappend` x = x
48+ WrongMethod `mappend` _ = WrongMethod
49+
50+-- | A wrapper around @'Either' 'RouteMismatch' a@.
51+newtype RouteResult a =
52+ RR { routeResult :: Either RouteMismatch a }
53+ deriving (Eq, Show)
54+
55+failWith :: RouteMismatch -> RouteResult a
56+failWith = RR . Left
57+
58+succeedWith :: a -> RouteResult a
59+succeedWith = RR . Right
60+
61+isMismatch :: RouteResult a -> Bool
62+isMismatch (RR (Left _)) = True
63+isMismatch _ = False
64+
65+-- | If we get a `Right`, it has precedence over everything else.
66+--
67+-- This in particular means that if we could get several 'Right's,
68+-- only the first we encounter would be taken into account.
69+instance Monoid (RouteResult a) where
70+ mempty = RR $ Left mempty
71+
72+ RR (Left x) `mappend` RR (Left y) = RR $ Left (x <> y)
73+ RR (Left _) `mappend` RR (Right y) = RR $ Right y
74+ r `mappend` _ = r
75+
3076type RoutingApplication =
3177 Request -- ^ the request, the field 'pathInfo' may be modified by url routing
32− -> (Maybe Response -> IO ResponseReceived) -> IO ResponseReceived
78+ -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived
3379
3480class HasServer layout where
3581 type Server layout :: *
test/Servant/ServerSpec.hs+2−2
@@ -113,8 +113,8 @@ getSpec = do
113113 liftIO $ do
114114 decode' (simpleBody response) `shouldBe` Just alice
115115
116− it "throws 404 on POSTs" $ do
117− post "/" "" `shouldRespondWith` 404
116+ it "throws 405 (wrong method) on POSTs" $ do
117+ post "/" "" `shouldRespondWith` 405
118118
119119
120120type GetParamApi = GetParam "name" String :> Get Person