From a3b5652ab9604759a62ecc5e07f02a35566a359c Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Wed, 9 Sep 2015 23:49:19 -0700 Subject: [PATCH] Refactor RouteResult. Fix rerouting tests Fix 405 > 404 issue with Capture. Remove ServantErrWithPriority and Monoid instance More tests Update auth-combinator for routing changes --- .../auth-combinator/auth-combinator.hs | 5 +- servant-server/src/Servant/Server.hs | 2 +- servant-server/src/Servant/Server/Internal.hs | 32 ++--- .../src/Servant/Server/Internal/Router.hs | 15 ++- .../Server/Internal/RoutingApplication.hs | 109 ++++++------------ .../src/Servant/Server/Internal/ServantErr.hs | 2 +- .../test/Servant/Server/ErrorSpec.hs | 94 +++++++++++---- servant-server/test/Servant/ServerSpec.hs | 67 ++--------- servant/test/Servant/API/ContentTypesSpec.hs | 15 +++ 9 files changed, 165 insertions(+), 176 deletions(-) diff --git a/servant-examples/auth-combinator/auth-combinator.hs b/servant-examples/auth-combinator/auth-combinator.hs index c82510f3..e183b82e 100644 --- a/servant-examples/auth-combinator/auth-combinator.hs +++ b/servant-examples/auth-combinator/auth-combinator.hs @@ -5,6 +5,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} + import Data.Aeson import Data.ByteString (ByteString) import Data.Text (Text) @@ -31,12 +32,12 @@ instance HasServer rest => HasServer (AuthProtected :> rest) where route Proxy a = WithRequest $ \ request -> route (Proxy :: Proxy rest) $ do case lookup "Cookie" (requestHeaders request) of - Nothing -> return $ failWith $ HttpError status401 (Just "Missing auth header.") + Nothing -> return $! failFatallyWith err401 { errBody = "Missing auth header" } Just v -> do authGranted <- isGoodCookie v if authGranted then a - else return $ failWith $ HttpError status403 (Just "Invalid cookie.") + else return $! failFatallyWith err403 { errBody = "Invalid cookie" } type PrivateAPI = Get '[JSON] [PrivateData] diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index 2a886683..eadd5174 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -103,7 +103,7 @@ import Servant.Server.Internal.Enter -- > main = Network.Wai.Handler.Warp.run 8080 app -- serve :: HasServer layout => Proxy layout -> Server layout -> Application -serve p server = toApplication (runRouter (route p (return (RR (Right server))))) +serve p server = toApplication (runRouter (route p (return (HandlerVal server)))) -- Documentation diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index c5e1cf70..3d85eb81 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -113,11 +113,10 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout) a -> ServerT sublayout m route Proxy subserver = - DynamicRouter $ \ first -> - route (Proxy :: Proxy sublayout) - (case captured captureProxy first of - Nothing -> return $ failWith NotFound - Just v -> feedTo subserver v) + DynamicRouter $ \ first -> case captured captureProxy first of + Nothing -> LeafRouter (\_ r -> r $ failWith err404) + Just v -> route (Proxy :: Proxy sublayout) (feedTo subserver v) + where captureProxy = Proxy :: Proxy (Capture capture a) allowedMethodHead :: Method -> Request -> Bool @@ -131,7 +130,7 @@ processMethodRouter :: forall a. ConvertibleStrings a B.ByteString -> Maybe [(HeaderName, B.ByteString)] -> Request -> RouteResult Response processMethodRouter handleA status method headers request = case handleA of - Nothing -> failWith UnsupportedMediaType + Nothing -> failFatallyWith err406 Just (contentT, body) -> succeedWith $ responseLBS status hdrs bdy where bdy = if allowedMethodHead method request then "" else body @@ -150,8 +149,8 @@ methodRouter method proxy status action = LeafRouter route' handleA = handleAcceptH proxy (AcceptHeader accH) output processMethodRouter handleA status method Nothing request | pathIsEmpty request && requestMethod request /= method = - respond $ failWith WrongMethod - | otherwise = respond $ failWith NotFound + respond $ failWith err405 + | otherwise = respond $ failWith err404 methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v) => Method -> Proxy ctypes -> Status @@ -167,8 +166,8 @@ methodRouterHeaders method proxy status action = LeafRouter route' handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output) processMethodRouter handleA status method (Just headers) request | pathIsEmpty request && requestMethod request /= method = - respond $ failWith WrongMethod - | otherwise = respond $ failWith NotFound + respond $ failWith err405 + | otherwise = respond $ failWith err404 methodRouterEmpty :: Method -> IO (RouteResult (ExceptT ServantErr IO ())) @@ -180,8 +179,8 @@ methodRouterEmpty method action = LeafRouter route' runAction action respond $ \ () -> succeedWith $ responseLBS noContent204 [] "" | pathIsEmpty request && requestMethod request /= method = - respond $ failWith WrongMethod - | otherwise = respond $ failWith NotFound + respond $ failWith err405 + | otherwise = respond $ failWith err404 -- | If you have a 'Delete' endpoint in your API, -- the handler for this endpoint is meant to delete @@ -558,8 +557,9 @@ instance HasServer Raw where route Proxy rawApplication = LeafRouter $ \ request respond -> do r <- rawApplication case r of - RR (Left err) -> respond $ failWith err - RR (Right app) -> app request (respond . succeedWith) + HandlerVal app -> app request (respond . succeedWith) + Retriable e -> respond $ failWith e + NonRetriable e -> respond $! failFatallyWith e -- | If you use 'ReqBody' in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function @@ -599,8 +599,8 @@ instance ( AllCTUnrender list a, HasServer sublayout mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH) <$> lazyRequestBody request case mrqbody of - Nothing -> return $ failWith $ UnsupportedMediaType - Just (Left e) -> return $ failWith $ InvalidBody e + Nothing -> return $! failFatallyWith err415 + Just (Left e) -> return $! failFatallyWith err400 { errBody = cs e } Just (Right v) -> feedTo subserver v -- | Make sure the incoming request starts with @"/path"@, strip it and diff --git a/servant-server/src/Servant/Server/Internal/Router.hs b/servant-server/src/Servant/Server/Internal/Router.hs index 6d41d6cd..e461133c 100644 --- a/servant-server/src/Servant/Server/Internal/Router.hs +++ b/servant-server/src/Servant/Server/Internal/Router.hs @@ -7,6 +7,8 @@ import qualified Data.Map as M import Data.Monoid ((<>)) import Data.Text (Text) import Network.Wai (Request, Response, pathInfo) +import Servant.Server.Internal.ServantErr +import Servant.Server.Internal.PathInfo import Servant.Server.Internal.RoutingApplication type Router = Router' RoutingApplication @@ -63,17 +65,24 @@ runRouter (StaticRouter table) request respond = | Just router <- M.lookup first table -> let request' = request { pathInfo = rest } in runRouter router request' respond - _ -> respond $ failWith NotFound + _ -> respond $ failWith err404 runRouter (DynamicRouter fun) request respond = case pathInfo request of first : rest -> let request' = request { pathInfo = rest } in runRouter (fun first) request' respond - _ -> respond $ failWith NotFound + _ -> respond $ failWith err404 runRouter (LeafRouter app) request respond = app request respond runRouter (Choice r1 r2) request respond = runRouter r1 request $ \ mResponse1 -> if isMismatch mResponse1 then runRouter r2 request $ \ mResponse2 -> - respond (mResponse1 <> mResponse2) + respond (highestPri mResponse1 mResponse2) else respond mResponse1 + where + highestPri (Retriable r1) (Retriable r2) = + if errHTTPCode r1 == 404 && errHTTPCode r2 /= 404 + then (Retriable r2) + else (Retriable r1) + highestPri (Retriable _) y = y + highestPri x _ = x diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index 117ac97c..579ac0c3 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} @@ -6,21 +7,17 @@ module Servant.Server.Internal.RoutingApplication where #if !MIN_VERSION_base(4,8,0) import Control.Applicative (Applicative, (<$>)) -import Data.Monoid (Monoid, mappend, mempty) +import Data.Monoid (Monoid, mappend, mempty, + (<>)) #endif import Control.Monad.Trans.Except (ExceptT, runExceptT) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.IORef (newIORef, readIORef, writeIORef) -import Data.Maybe (fromMaybe) -import Data.Monoid ((<>)) -import Data.String (fromString) -import Network.HTTP.Types hiding (Header, - ResponseHeaders) import Network.Wai (Application, Request, Response, ResponseReceived, - requestBody, responseLBS, + requestBody, strictRequestBody) import Servant.API ((:<|>) (..)) import Servant.Server.Internal.ServantErr @@ -30,39 +27,12 @@ type RoutingApplication = -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived -- | A wrapper around @'Either' 'RouteMismatch' a@. -newtype RouteResult a = - RR { routeResult :: Either RouteMismatch a } - deriving (Eq, Show, Functor, Applicative) - --- | 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 - --- Note that the ordering of the constructors has great significance! It --- determines the Ord instance and, consequently, the monoid instance. -data RouteMismatch = - NotFound -- ^ the usual "not found" error - | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error - | UnsupportedMediaType -- ^ request body has unsupported media type - | InvalidBody String -- ^ an even more informative "your json request body wasn't valid" error - | HttpError Status (Maybe BL.ByteString) -- ^ an even even more informative arbitrary HTTP response code error. - deriving (Eq, Ord, Show) - -instance Monoid RouteMismatch where - mempty = NotFound - -- The following isn't great, since it picks @InvalidBody@ based on - -- alphabetical ordering, but any choice would be arbitrary. - -- - -- "As one judge said to the other, 'Be just and if you can't be just, be - -- arbitrary'" -- William Burroughs - mappend = max +data RouteResult a = + Retriable ServantErr -- ^ Keep trying other paths. The @ServantErr@ + -- should only be 404 or 405. + | NonRetriable ServantErr -- ^ Stop trying. + | HandlerVal a + deriving (Eq, Show, Read, Functor) data ReqBodyState = Uncalled | Called !B.ByteString @@ -91,55 +61,52 @@ toApplication ra request respond = do writeIORef reqBodyRef $ Called bs return B.empty - ra request{ requestBody = memoReqBody } (routingRespond . routeResult) + ra request{ requestBody = memoReqBody } routingRespond where - routingRespond :: Either RouteMismatch Response -> IO ResponseReceived - routingRespond (Left NotFound) = - respond $ responseLBS notFound404 [] "not found" - routingRespond (Left WrongMethod) = - respond $ responseLBS methodNotAllowed405 [] "method not allowed" - routingRespond (Left (InvalidBody err)) = - respond $ responseLBS badRequest400 [] $ fromString $ "invalid request body: " ++ err - routingRespond (Left UnsupportedMediaType) = - respond $ responseLBS unsupportedMediaType415 [] "unsupported media type" - routingRespond (Left (HttpError status body)) = - respond $ responseLBS status [] $ fromMaybe (BL.fromStrict $ statusMessage status) body - routingRespond (Right response) = - respond response + routingRespond :: RouteResult Response -> IO ResponseReceived + routingRespond (Retriable err) = respond $! responseServantErr err + routingRespond (NonRetriable err) = respond $! responseServantErr err + routingRespond (HandlerVal v) = respond v runAction :: IO (RouteResult (ExceptT ServantErr IO a)) -> (RouteResult Response -> IO r) -> (a -> RouteResult Response) -> IO r -runAction action respond k = do - r <- action - go r +runAction action respond k = action >>= go >>= respond where - go (RR (Right a)) = do + go (Retriable e) = return $! Retriable e + go (NonRetriable e) = return . succeedWith $! responseServantErr e + go (HandlerVal a) = do e <- runExceptT a - respond $ case e of - Right x -> k x - Left err -> succeedWith $ responseServantErr err - go (RR (Left err)) = respond $ failWith err + case e of + Left err -> return . succeedWith $! responseServantErr err + Right x -> return $! k x feedTo :: IO (RouteResult (a -> b)) -> a -> IO (RouteResult b) feedTo f x = (($ x) <$>) <$> f extractL :: RouteResult (a :<|> b) -> RouteResult a -extractL (RR (Right (a :<|> _))) = RR (Right a) -extractL (RR (Left err)) = RR (Left err) +extractL (HandlerVal (a :<|> _)) = HandlerVal a +extractL (Retriable x) = Retriable x +extractL (NonRetriable x) = NonRetriable x extractR :: RouteResult (a :<|> b) -> RouteResult b -extractR (RR (Right (_ :<|> b))) = RR (Right b) -extractR (RR (Left err)) = RR (Left err) +extractR (HandlerVal (_ :<|> b)) = HandlerVal b +extractR (Retriable x) = Retriable x +extractR (NonRetriable x) = NonRetriable x -failWith :: RouteMismatch -> RouteResult a -failWith = RR . Left +-- | Fail with a @ServantErr@, but keep trying other paths and. +failWith :: ServantErr -> RouteResult a +failWith = Retriable +-- | Fail with immediately @ServantErr@. +failFatallyWith :: ServantErr -> RouteResult a +failFatallyWith = NonRetriable + +-- | Return a value, and don't try other paths. succeedWith :: a -> RouteResult a -succeedWith = RR . Right +succeedWith = HandlerVal isMismatch :: RouteResult a -> Bool -isMismatch (RR (Left _)) = True +isMismatch (Retriable _) = True isMismatch _ = False - diff --git a/servant-server/src/Servant/Server/Internal/ServantErr.hs b/servant-server/src/Servant/Server/Internal/ServantErr.hs index a308022e..6cfa3e90 100644 --- a/servant-server/src/Servant/Server/Internal/ServantErr.hs +++ b/servant-server/src/Servant/Server/Internal/ServantErr.hs @@ -11,7 +11,7 @@ data ServantErr = ServantErr { errHTTPCode :: Int , errReasonPhrase :: String , errBody :: LBS.ByteString , errHeaders :: [HTTP.Header] - } deriving (Show, Eq) + } deriving (Show, Eq, Read) responseServantErr :: ServantErr -> Response responseServantErr ServantErr{..} = responseLBS status errHeaders errBody diff --git a/servant-server/test/Servant/Server/ErrorSpec.hs b/servant-server/test/Servant/Server/ErrorSpec.hs index 008642b7..30a8b41c 100644 --- a/servant-server/test/Servant/Server/ErrorSpec.hs +++ b/servant-server/test/Servant/Server/ErrorSpec.hs @@ -7,9 +7,9 @@ module Servant.Server.ErrorSpec (spec) where import Data.Aeson (encode) import qualified Data.ByteString.Lazy.Char8 as BC -import Control.Monad.Trans.Either (left) import Data.Proxy -import Network.HTTP.Types (methodGet, methodPost) +import Network.HTTP.Types (hAccept, hContentType, methodGet, + methodPost) import Test.Hspec import Test.Hspec.Wai @@ -31,8 +31,9 @@ import Servant spec :: Spec spec = describe "HTTP Errors" $ do - errorOrder - errorRetry + errorOrderSpec + errorRetrySpec + errorChoiceSpec ------------------------------------------------------------------------------ -- * Error Order {{{ @@ -42,24 +43,24 @@ type ErrorOrderApi = "home" :> Capture "t" Int :> Post '[JSON] Int + errorOrderApi :: Proxy ErrorOrderApi errorOrderApi = Proxy errorOrderServer :: Server ErrorOrderApi -errorOrderServer = \_ _ -> left err402 +errorOrderServer = \_ _ -> return 5 -errorOrder :: Spec -errorOrder = describe "HTTP error order" +errorOrderSpec :: Spec +errorOrderSpec = describe "HTTP error order" $ with (return $ serve errorOrderApi errorOrderServer) $ do - let badContentType = ("Content-Type", "text/plain") - badAccept = ("Accept", "text/plain") + let badContentType = (hContentType, "text/plain") + badAccept = (hAccept, "text/plain") badMethod = methodGet badUrl = "home/nonexistent" badBody = "nonsense" - goodContentType = ("Content-Type", "application/json") - goodAccept = ("Accept", "application/json") + goodContentType = (hContentType, "application/json") goodMethod = methodPost - goodUrl = "home/5" + goodUrl = "home/2" goodBody = encode (5 :: Int) it "has 404 as its highest priority error" $ do @@ -82,10 +83,6 @@ errorOrder = describe "HTTP error order" request goodMethod goodUrl [goodContentType, badAccept] goodBody `shouldRespondWith` 406 - it "returns handler errors as its lower priority errors" $ do - request goodMethod goodUrl [goodContentType, goodAccept] goodBody - `shouldRespondWith` 402 - -- }}} ------------------------------------------------------------------------------ -- * Error Retry {{{ @@ -95,9 +92,10 @@ type ErrorRetryApi :<|> "a" :> ReqBody '[PlainText] Int :> Post '[JSON] Int -- 1 :<|> "a" :> ReqBody '[JSON] Int :> Post '[PlainText] Int -- 2 :<|> "a" :> ReqBody '[JSON] String :> Post '[JSON] Int -- 3 - :<|> "a" :> ReqBody '[JSON] Int :> Get '[PlainText] Int -- 4 - :<|> ReqBody '[JSON] Int :> Get '[JSON] Int -- 5 + :<|> "a" :> ReqBody '[JSON] Int :> Get '[JSON] Int -- 4 + :<|> "a" :> ReqBody '[JSON] Int :> Get '[PlainText] Int -- 5 :<|> ReqBody '[JSON] Int :> Get '[JSON] Int -- 6 + :<|> ReqBody '[JSON] Int :> Post '[JSON] Int -- 7 errorRetryApi :: Proxy ErrorRetryApi errorRetryApi = Proxy @@ -111,19 +109,21 @@ errorRetryServer :<|> (\_ -> return 4) :<|> (\_ -> return 5) :<|> (\_ -> return 6) + :<|> (\_ -> return 7) -errorRetry :: Spec -errorRetry = describe "Handler search" +errorRetrySpec :: Spec +errorRetrySpec = describe "Handler search" $ with (return $ serve errorRetryApi errorRetryServer) $ do - let plainCT = ("Content-Type", "text/plain") - plainAccept = ("Accept", "text/plain") - jsonCT = ("Content-Type", "application/json") - jsonAccept = ("Accept", "application/json") + + let plainCT = (hContentType, "text/plain") + plainAccept = (hAccept, "text/plain") + jsonCT = (hContentType, "application/json") + jsonAccept = (hAccept, "application/json") jsonBody = encode (1797 :: Int) it "should continue when URLs don't match" $ do request methodPost "" [jsonCT, jsonAccept] jsonBody - `shouldRespondWith` 201 { matchBody = Just $ encode (5 :: Int) } + `shouldRespondWith` 201 { matchBody = Just $ encode (7 :: Int) } it "should continue when methods don't match" $ do request methodGet "a" [jsonCT, jsonAccept] jsonBody @@ -141,6 +141,50 @@ errorRetry = describe "Handler search" request methodPost "a" [jsonCT, plainAccept] jsonBody `shouldRespondWith` 406 +-- }}} +------------------------------------------------------------------------------ +-- * Error Choice {{{ + +type ErrorChoiceApi + = "path0" :> Get '[JSON] Int -- 0 + :<|> "path1" :> Post '[JSON] Int -- 1 + :<|> "path2" :> Post '[PlainText] Int -- 2 + :<|> "path3" :> ReqBody '[JSON] Int :> Post '[PlainText] Int -- 3 + :<|> "path4" :> (ReqBody '[PlainText] Int :> Post '[PlainText] Int -- 4 + :<|> ReqBody '[PlainText] Int :> Post '[JSON] Int) -- 5 + +errorChoiceApi :: Proxy ErrorChoiceApi +errorChoiceApi = Proxy + +errorChoiceServer :: Server ErrorChoiceApi +errorChoiceServer = return 0 + :<|> return 1 + :<|> return 2 + :<|> (\_ -> return 3) + :<|> (\_ -> return 4) + :<|> (\_ -> return 5) + + +errorChoiceSpec :: Spec +errorChoiceSpec = describe "Multiple handlers return errors" + $ with (return $ serve errorChoiceApi errorChoiceServer) $ do + + it "should respond with 404 if no path matches" $ do + request methodGet "" [] "" `shouldRespondWith` 404 + + it "should respond with 405 if a path but not method matches" $ do + request methodGet "path2" [] "" `shouldRespondWith` 405 + + it "should respond with the corresponding error if path and method match" $ do + request methodPost "path3" [(hContentType, "text/plain;charset=utf-8")] "" + `shouldRespondWith` 415 + request methodPost "path3" [(hContentType, "application/json")] "" + `shouldRespondWith` 400 + request methodPost "path4" [(hContentType, "text/plain;charset=utf-8"), + (hAccept, "application/json")] "" + `shouldRespondWith` 406 + + -- }}} ------------------------------------------------------------------------------ -- * Instances {{{ diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 9926dea5..c9bf11ce 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -17,7 +17,6 @@ import Control.Monad.Trans.Except (ExceptT, throwE) import Data.Aeson (FromJSON, ToJSON, decode', encode) import Data.ByteString.Conversion () import Data.Char (toUpper) -import Data.Monoid ((<>)) import Data.Proxy (Proxy (Proxy)) import Data.String (fromString) import Data.String.Conversions (cs) @@ -26,8 +25,7 @@ import GHC.Generics (Generic) import Network.HTTP.Types (hAccept, hContentType, methodDelete, methodGet, methodHead, methodPatch, methodPost, methodPut, - ok200, parseQuery, status409, - Status(..)) + ok200, parseQuery, Status(..)) import Network.Wai (Application, Request, pathInfo, queryString, rawQueryString, responseLBS, responseBuilder) @@ -99,7 +97,6 @@ spec = do rawSpec unionSpec prioErrorsSpec - errorsSpec routerSpec responseHeadersSpec miscReqCombinatorsSpec @@ -158,9 +155,9 @@ getSpec = do it "returns 204 if the type is '()'" $ do get "/empty" `shouldRespondWith` ""{ matchStatus = 204 } - it "returns 415 if the Accept header is not supported" $ do + it "returns 406 if the Accept header is not supported" $ do Test.Hspec.Wai.request methodGet "" [(hAccept, "crazy/mime")] "" - `shouldRespondWith` 415 + `shouldRespondWith` 406 headSpec :: Spec @@ -186,9 +183,9 @@ headSpec = do response <- Test.Hspec.Wai.request methodHead "/empty" [] "" return response `shouldRespondWith` ""{ matchStatus = 204 } - it "returns 415 if the Accept header is not supported" $ do + it "returns 406 if the Accept header is not supported" $ do Test.Hspec.Wai.request methodHead "" [(hAccept, "crazy/mime")] "" - `shouldRespondWith` 415 + `shouldRespondWith` 406 type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person @@ -311,7 +308,7 @@ postSpec = do it "returns 204 if the type is '()'" $ do post' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 } - it "responds with 415 if the requested media type is unsupported" $ do + it "responds with 415 if the request body media type is unsupported" $ do let post'' x = Test.Hspec.Wai.request methodPost x [(hContentType , "application/nonsense")] post'' "/" "anything at all" `shouldRespondWith` 415 @@ -353,7 +350,7 @@ putSpec = do it "returns 204 if the type is '()'" $ do put' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 } - it "responds with 415 if the requested media type is unsupported" $ do + it "responds with 415 if the request body media type is unsupported" $ do let put'' x = Test.Hspec.Wai.request methodPut x [(hContentType , "application/nonsense")] put'' "/" "anything at all" `shouldRespondWith` 415 @@ -395,7 +392,7 @@ patchSpec = do it "returns 204 if the type is '()'" $ do patch' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 } - it "responds with 415 if the requested media type is unsupported" $ do + it "responds with 415 if the request body media type is unsupported" $ do let patch'' x = Test.Hspec.Wai.request methodPatch x [(hContentType , "application/nonsense")] patch'' "/" "anything at all" `shouldRespondWith` 415 @@ -524,10 +521,10 @@ responseHeadersSpec = describe "ResponseHeaders" $ do Test.Hspec.Wai.request method "blahblah" [] "" `shouldRespondWith` 404 - it "returns 415 if the Accept header is not supported" $ + it "returns 406 if the Accept header is not supported" $ forM_ methods $ \(method,_) -> Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] "" - `shouldRespondWith` 415 + `shouldRespondWith` 406 type PrioErrorsApi = ReqBody '[JSON] Person :> "foo" :> Get '[JSON] Integer @@ -578,50 +575,6 @@ prioErrorsSpec = describe "PrioErrors" $ do check put' "/bar" vjson 404 check put' "/foo" vjson 405 --- | Test server error functionality. -errorsSpec :: Spec -errorsSpec = do - let he = HttpError status409 (Just "A custom error") - let ib = InvalidBody "The body is invalid" - let wm = WrongMethod - let nf = NotFound - - describe "Servant.Server.Internal.RouteMismatch" $ do - it "HttpError > *" $ do - ib <> he `shouldBe` he - wm <> he `shouldBe` he - nf <> he `shouldBe` he - - he <> ib `shouldBe` he - he <> wm `shouldBe` he - he <> nf `shouldBe` he - - it "HE > InvalidBody > (WM,NF)" $ do - he <> ib `shouldBe` he - wm <> ib `shouldBe` ib - nf <> ib `shouldBe` ib - - ib <> he `shouldBe` he - ib <> wm `shouldBe` ib - ib <> nf `shouldBe` ib - - it "HE > IB > WrongMethod > NF" $ do - he <> wm `shouldBe` he - ib <> wm `shouldBe` ib - nf <> wm `shouldBe` wm - - wm <> he `shouldBe` he - wm <> ib `shouldBe` ib - wm <> nf `shouldBe` wm - - it "* > NotFound" $ do - he <> nf `shouldBe` he - ib <> nf `shouldBe` ib - wm <> nf `shouldBe` wm - - nf <> he `shouldBe` he - nf <> ib `shouldBe` ib - nf <> wm `shouldBe` wm routerSpec :: Spec routerSpec = do diff --git a/servant/test/Servant/API/ContentTypesSpec.hs b/servant/test/Servant/API/ContentTypesSpec.hs index 76faea67..062b6b2b 100644 --- a/servant/test/Servant/API/ContentTypesSpec.hs +++ b/servant/test/Servant/API/ContentTypesSpec.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Servant.API.ContentTypesSpec where @@ -34,6 +35,20 @@ import Servant.API.ContentTypes spec :: Spec spec = describe "Servant.API.ContentTypes" $ do + describe "handleAcceptH" $ do + let p = Proxy :: Proxy '[PlainText] + + it "matches any charset if none were provided" $ do + let without = handleAcceptH p (AcceptHeader "text/plain") + with = handleAcceptH p (AcceptHeader "text/plain;charset=utf-8") + wisdom = "ubi sub ubi" :: String + without wisdom `shouldBe` with wisdom + + it "does not match non utf-8 charsets" $ do + let badCharset = handleAcceptH p (AcceptHeader "text/plain;charset=whoknows") + s = "cheese" :: String + badCharset s `shouldBe` Nothing + describe "The JSON Content-Type type" $ do let p = Proxy :: Proxy JSON