641ee69 · typeable/servant

src/Servant/API/Capture.hs+2−2

compare with master

unifiedsplit

@@ -31,11 +31,11 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout)

31 route Proxy subserver request respond = case pathInfo request of

32 (first : rest)

33 -> case captured captureProxy first of

34− Nothing -> respond Nothing

34+ Nothing -> respond $ failWith NotFound

35 Just v -> route (Proxy :: Proxy sublayout) (subserver v) request{

36 pathInfo = rest

37 } respond

38− _ -> respond Nothing

38+ _ -> respond $ failWith NotFound

39

40 where captureProxy = Proxy :: Proxy (Capture capture a)

41

src/Servant/API/Delete.hs+4−2

@@ -26,12 +26,14 @@ instance HasServer Delete where

26 route Proxy action request respond

27 | null (pathInfo request) && requestMethod request == methodDelete = do

28 e <- runEitherT action

29− respond $ Just $ case e of

29+ respond $ succeedWith $ case e of

30 Right () ->

31 responseLBS status204 [] ""

32 Left (status, message) ->

33 responseLBS (mkStatus status (cs message)) [] (cs message)

34+ | null (pathInfo request) && requestMethod request /= methodDelete =

35+ respond $ failWith WrongMethod

34− | otherwise = respond Nothing

36+ | otherwise = respond $ failWith NotFound

35

37

36instance HasClient Delete where

38instance HasClient Delete where

37 type Client Delete = URI -> EitherT String IO ()

39 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

27 route Proxy action request respond

28 | null (pathInfo request) && requestMethod request == methodGet = do

29 e <- runEitherT action

30− respond $ Just $ case e of

30+ respond . succeedWith $ case e of

31 Right output ->

32 responseLBS ok200 [("Content-Type", "application/json")] (encode output)

33 Left (status, message) ->

34 responseLBS (mkStatus status (cs message)) [] (cs message)

35+ | null (pathInfo request) && requestMethod request /= methodGet =

36+ respond $ failWith WrongMethod

35− | otherwise = respond Nothing

37+ | otherwise = respond $ failWith NotFound

36

38

37instance FromJSON result => HasClient (Get result) where

39instance FromJSON result => HasClient (Get result) where

38 type Client (Get result) = URI -> EitherT String IO result

40 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

29 route Proxy action request respond

30 | null (pathInfo request) && requestMethod request == methodPost = do

31 e <- runEitherT action

32− respond $ Just $ case e of

32+ respond . succeedWith $ case e of

33 Right out ->

34 responseLBS status201 [("Content-Type", "application/json")] (encode out)

35 Left (status, message) ->

36 responseLBS (mkStatus status (cs message)) [] (cs message)

37+ | null (pathInfo request) && requestMethod request /= methodPost =

38+ respond $ failWith WrongMethod

37− | otherwise = respond Nothing

39+ | otherwise = respond $ failWith NotFound

38

40

39instance FromJSON a => HasClient (Post a) where

41instance FromJSON a => HasClient (Post a) where

40 type Client (Post a) = URI -> EitherT String IO a

42 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

27 route Proxy action request respond

28 | null (pathInfo request) && requestMethod request == methodPut = do

29 e <- runEitherT action

30− respond $ Just $ case e of

30+ respond . succeedWith $ case e of

31 Right out ->

32 responseLBS ok200 [("Content-Type", "application/json")] (encode out)

33 Left (status, message) ->

34 responseLBS (mkStatus status (cs message)) [] (cs message)

35+ | null (pathInfo request) && requestMethod request /= methodPut =

36+ respond $ failWith WrongMethod

37+

35− | otherwise = respond Nothing

38+ | otherwise = respond $ failWith NotFound

36

39

37instance FromJSON a => HasClient (Put a) where

40instance FromJSON a => HasClient (Put a) where

38 type Client (Put a) = URI -> EitherT String IO a

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

26 route Proxy subserver request respond = do

27 mrqbody <- decode' <$> lazyRequestBody request

28 case mrqbody of

29− Nothing -> respond Nothing

29+ Nothing -> respond $ failWith NotFound

30 Just v -> route (Proxy :: Proxy sublayout) (subserver v) request respond

31

32instance (ToJSON a, HasClient sublayout)

src/Servant/API/Raw.hs+1−1

@@ -15,4 +15,4 @@ data Raw

15instance HasServer Raw where

16 type Server Raw = Application

17 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

25 -> route (Proxy :: Proxy sublayout) subserver request{

26 pathInfo = rest

27 } respond

28− _ -> respond Nothing

28+ _ -> respond $ failWith NotFound

29

30 where proxyPath = Proxy :: Proxy path

31

src/Servant/API/Union.hs+10−5

@@ -14,11 +14,16 @@ infixr 8 :<|>

14

15instance (HasServer a, HasServer b) => HasServer (a :<|> b) where

16 type Server (a :<|> b) = Server a :<|> Server b

17− route Proxy (a :<|> b) request respond = do

17+ route Proxy (a :<|> b) request respond =

18− route (Proxy :: Proxy a) a request $ \ mResponse ->

18+ route pa a request $ \ mResponse ->

19− case mResponse of

19+ case isMismatch mResponse of

20− Nothing -> route (Proxy :: Proxy b) b request respond

20+ True -> route pb b request $ \mResponse' ->

21− Just resp -> respond $ Just resp

21+ respond (mResponse <> mResponse')

22+ False -> respond mResponse

23+

24+

25+ where pa = Proxy :: Proxy a

26+ pb = Proxy :: Proxy b

22

27

23instance (HasClient a, HasClient b) => HasClient (a :<|> b) where

28instance (HasClient a, HasClient b) => HasClient (a :<|> b) where

24 type Client (a :<|> b) = Client a :<|> Client b

29 type Client (a :<|> b) = Client a :<|> Client b

src/Servant/Server.hs+51−5

@@ -7,6 +7,7 @@

7

8module Servant.Server where

9

10+import Data.Monoid

10import Data.Proxy

11import Data.Proxy

11import Network.HTTP.Types

12import Network.HTTP.Types

12import Network.Wai

13import Network.Wai

@@ -19,17 +20,62 @@ serve p server = toApplication (route p server)

19

20

20toApplication :: RoutingApplication -> Application

21toApplication :: RoutingApplication -> Application

21toApplication ra request respond = do

22toApplication ra request respond = do

22− ra request routingRespond

23+ ra request (routingRespond . routeResult)

23 where

24 where

24− routingRespond :: Maybe Response -> IO ResponseReceived

25+ routingRespond :: Either RouteMismatch Response -> IO ResponseReceived

25− routingRespond Nothing =

26+ routingRespond (Left NotFound) =

26 respond $ responseLBS notFound404 [] "not found"

27 respond $ responseLBS notFound404 [] "not found"

27− routingRespond (Just response) =

28+ routingRespond (Left WrongMethod) =

29+ respond $ responseLBS methodNotAllowed405 [] "method not allowed"

30+ routingRespond (Right response) =

28 respond response

31 respond response

29

32

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+

30type RoutingApplication =

76type RoutingApplication =

31 Request -- ^ the request, the field 'pathInfo' may be modified by url routing

77 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

33

79

34class HasServer layout where

80class HasServer layout where

35 type Server layout :: *

81 type Server layout :: *

test/Servant/ServerSpec.hs+2−2

@@ -113,8 +113,8 @@ getSpec = do

113 liftIO $ do

114 decode' (simpleBody response) `shouldBe` Just alice

115

116− it "throws 404 on POSTs" $ do

116+ it "throws 405 (wrong method) on POSTs" $ do

117− post "/" "" `shouldRespondWith` 404

117+ post "/" "" `shouldRespondWith` 405

118

119

120type GetParamApi = GetParam "name" String :> Get Person