diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs index 04baf856..1abda7d0 100644 --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -14,7 +14,7 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.IORef (newIORef, readIORef, writeIORef) import Data.List (unfoldr) -import Data.Maybe (catMaybes) +import Data.Maybe (catMaybes, fromMaybe) import Data.Monoid (Monoid, mempty, mappend) import Data.Proxy (Proxy(Proxy)) import Data.String (fromString) @@ -66,6 +66,8 @@ toApplication ra request respond = do respond $ responseLBS methodNotAllowed405 [] "method not allowed" routingRespond (Left (InvalidBody err)) = respond $ responseLBS badRequest400 [] $ fromString $ "Invalid JSON in request body: " ++ err + routingRespond (Left (HttpError status body)) = + respond $ responseLBS status [] $ fromMaybe (BL.fromStrict $ statusMessage status) body routingRespond (Right response) = respond response @@ -74,12 +76,15 @@ data RouteMismatch = NotFound -- ^ the usual "not found" error | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error | 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, Show) -- | -- @ -- > mempty = NotFound -- > +-- > _ `mappend` HttpError s b = HttpError s b +-- > HttpError s b `mappend` _ = HttpError s b -- > NotFound `mappend` x = x -- > WrongMethod `mappend` InvalidBody s = InvalidBody s -- > WrongMethod `mappend` _ = WrongMethod @@ -88,6 +93,8 @@ data RouteMismatch = instance Monoid RouteMismatch where mempty = NotFound + _ `mappend` HttpError s b = HttpError s b + HttpError s b `mappend` _ = HttpError s b NotFound `mappend` x = x WrongMethod `mappend` InvalidBody s = InvalidBody s WrongMethod `mappend` _ = WrongMethod diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs index 56e98d94..ee3a8d22 100644 --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -11,11 +11,12 @@ module Servant.ServerSpec where import Control.Monad.Trans.Either (EitherT, left) import Data.Aeson (ToJSON, FromJSON, encode, decode') import Data.Char (toUpper) +import Data.Monoid ((<>)) import Data.Proxy (Proxy(Proxy)) import Data.String (fromString) import Data.String.Conversions (cs) import GHC.Generics (Generic) -import Network.HTTP.Types (parseQuery, ok200) +import Network.HTTP.Types (parseQuery, ok200, status409) import Network.Wai (Application, Request, responseLBS, pathInfo, queryString, rawQueryString) import Network.Wai.Test (runSession, request, defaultRequest, simpleBody) import Test.Hspec (Spec, describe, it, shouldBe) @@ -31,6 +32,7 @@ import Servant.API.Raw (Raw) import Servant.API.Sub ((:>)) import Servant.API.Alternative ((:<|>)((:<|>))) import Servant.Server (Server, serve) +import Servant.Server.Internal (RouteMismatch(..)) -- * test data types @@ -74,6 +76,7 @@ spec = do postSpec rawSpec unionSpec + errorsSpec type CaptureApi = Capture "legs" Integer :> Get Animal @@ -364,3 +367,48 @@ unionSpec = do liftIO $ do decode' (simpleBody response_) `shouldBe` Just jerry + +-- | 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