Merge pull request #22 from anchor/arbitrary-routemismatch

Add RouteMismatch constructor for arbitrary HTTP response code
This commit is contained in:
Julian Arni 2015-01-30 05:50:30 +01:00
commit b6a6505ecf
2 changed files with 57 additions and 2 deletions

View file

@ -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

View file

@ -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