diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs index b92036c6..064eddab 100644 --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -273,14 +273,14 @@ instance ( AllCTRender ctypes a route Proxy action request respond | pathIsEmpty request && requestMethod request == methodGet = do e <- runEitherT action - respond . succeedWith $ case e of + respond $ case e of Right output -> do let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of - Nothing -> responseLBS (mkStatus 406 "Not Acceptable") [] "" - Just (contentT, body) -> responseLBS ok200 [ ("Content-Type" - , cs contentT)] body - Left (status, message) -> + Nothing -> failWith UnsupportedMediaType + Just (contentT, body) -> succeedWith $ + responseLBS ok200 [ ("Content-Type" , cs contentT)] body + Left (status, message) -> succeedWith $ responseLBS (mkStatus status (cs message)) [] (cs message) | pathIsEmpty request && requestMethod request /= methodGet = respond $ failWith WrongMethod @@ -351,14 +351,14 @@ instance ( AllCTRender ctypes a route Proxy action request respond | pathIsEmpty request && requestMethod request == methodPost = do e <- runEitherT action - respond . succeedWith $ case e of + respond $ case e of Right output -> do let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of - Nothing -> responseLBS (mkStatus 406 "") [] "" - Just (contentT, body) -> responseLBS status201 [ ("Content-Type" - , cs contentT)] body - Left (status, message) -> + Nothing -> failWith UnsupportedMediaType + Just (contentT, body) -> succeedWith $ + responseLBS status201 [ ("Content-Type" , cs contentT)] body + Left (status, message) -> succeedWith $ responseLBS (mkStatus status (cs message)) [] (cs message) | pathIsEmpty request && requestMethod request /= methodPost = respond $ failWith WrongMethod @@ -397,14 +397,14 @@ instance ( AllCTRender ctypes a route Proxy action request respond | pathIsEmpty request && requestMethod request == methodPut = do e <- runEitherT action - respond . succeedWith $ case e of + respond $ case e of Right output -> do let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of - Nothing -> responseLBS (mkStatus 406 "") [] "" - Just (contentT, body) -> responseLBS status200 [ ("Content-Type" - , cs contentT)] body - Left (status, message) -> + Nothing -> failWith UnsupportedMediaType + Just (contentT, body) -> succeedWith $ + responseLBS status200 [ ("Content-Type" , cs contentT)] body + Left (status, message) -> succeedWith $ responseLBS (mkStatus status (cs message)) [] (cs message) | pathIsEmpty request && requestMethod request /= methodPut = respond $ failWith WrongMethod @@ -441,14 +441,14 @@ instance ( AllCTRender ctypes a route Proxy action request respond | pathIsEmpty request && requestMethod request == methodPatch = do e <- runEitherT action - respond . succeedWith $ case e of + respond $ case e of Right output -> do let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of - Nothing -> responseLBS (mkStatus 406 "") [] "" - Just (contentT, body) -> responseLBS status200 [ ("Content-Type" - , cs contentT)] body - Left (status, message) -> + Nothing -> failWith UnsupportedMediaType + Just (contentT, body) -> succeedWith $ + responseLBS status200 [ ("Content-Type" , cs contentT)] body + Left (status, message) -> succeedWith $ responseLBS (mkStatus status (cs message)) [] (cs message) | pathIsEmpty request && requestMethod request /= methodPatch = respond $ failWith WrongMethod diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs index 6b44e409..ab03ae95 100644 --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -15,8 +15,10 @@ import Data.Monoid ((<>)) import Data.Proxy (Proxy (Proxy)) import Data.String (fromString) import Data.String.Conversions (cs) +import qualified Data.Text as T import GHC.Generics (Generic) -import Network.HTTP.Types (hContentType, methodDelete, +import Network.HTTP.Types (hAccept, hContentType, + methodDelete, methodGet, methodPatch, methodPost, methodPut, ok200, parseQuery, status409) import Network.Wai (Application, Request, pathInfo, @@ -31,8 +33,9 @@ import Test.Hspec.Wai (get, liftIO, matchStatus, post, import Servant.API ((:<|>) (..), (:>), Capture, Delete, Get, Header, JSON, MatrixFlag, MatrixParam, MatrixParams, Patch, - Post, Put, QueryFlag, QueryParam, - QueryParams, Raw, ReqBody) + PlainText, Post, Put, QueryFlag, + QueryParam, QueryParams, Raw, + ReqBody) import Servant.Server (Server, serve) import Servant.Server.Internal (RouteMismatch (..)) @@ -41,7 +44,7 @@ import Servant.Server.Internal (RouteMismatch (..)) data Person = Person { name :: String, - age :: Integer + age :: Integer } deriving (Eq, Show, Generic) @@ -52,7 +55,7 @@ alice :: Person alice = Person "Alice" 42 data Animal = Animal { - species :: String, + species :: String, numberOfLegs :: Integer } deriving (Eq, Show, Generic) @@ -97,10 +100,13 @@ captureSpec :: Spec captureSpec = do describe "Servant.API.Capture" $ do with (return (serve captureApi captureServer)) $ do + it "can capture parts of the 'pathInfo'" $ do response <- get "/2" - liftIO $ do - decode' (simpleBody response) `shouldBe` Just tweety + liftIO $ decode' (simpleBody response) `shouldBe` Just tweety + + it "returns 404 if the decoding fails" $ do + get "/notAnInt" `shouldRespondWith` 404 with (return (serve (Proxy :: Proxy (Capture "captured" String :> Raw)) @@ -120,18 +126,23 @@ getSpec = do describe "Servant.API.Get" $ do let server = return alice :<|> return () with (return $ serve getApi server) $ do + it "allows to GET a Person" $ do response <- get "/" return response `shouldRespondWith` 200 - liftIO $ do - decode' (simpleBody response) `shouldBe` Just alice + liftIO $ decode' (simpleBody response) `shouldBe` Just alice it "throws 405 (wrong method) on POSTs" $ do post "/" "" `shouldRespondWith` 405 + post "/empty" "" `shouldRespondWith` 405 it "returns 204 if the type is '()'" $ do get "empty" `shouldRespondWith` ""{ matchStatus = 204 } + it "returns 415 if the Accept header is not supported" $ do + Test.Hspec.Wai.request methodGet "" [(hAccept, "crazy/mime")] "" + `shouldRespondWith` 415 + type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person @@ -483,6 +494,10 @@ rawSpec = do type AlternativeApi = "foo" :> Get '[JSON] Person :<|> "bar" :> Get '[JSON] Animal + :<|> "foo" :> Get '[PlainText] T.Text + :<|> "bar" :> Post '[JSON] Animal + :<|> "bar" :> Put '[JSON] Animal + :<|> "bar" :> Delete unionApi :: Proxy AlternativeApi unionApi = Proxy @@ -490,11 +505,16 @@ unionServer :: Server AlternativeApi unionServer = return alice :<|> return jerry + :<|> return "a string" + :<|> return jerry + :<|> return jerry + :<|> return () unionSpec :: Spec unionSpec = do describe "Servant.API.Alternative" $ do with (return $ serve unionApi unionServer) $ do + it "unions endpoints" $ do response <- get "/foo" liftIO $ do @@ -505,6 +525,12 @@ unionSpec = do decode' (simpleBody response_) `shouldBe` Just jerry + it "checks all endpoints before returning 415" $ do + get "/foo" `shouldRespondWith` 200 + + it "returns 404 if the path does not exist" $ do + get "/nonexistent" `shouldRespondWith` 404 + -- | Test server error functionality. errorsSpec :: Spec errorsSpec = do