Merge pull request #22 from anchor/arbitrary-routemismatch
Add RouteMismatch constructor for arbitrary HTTP response code
This commit is contained in:
commit
b6a6505ecf
2 changed files with 57 additions and 2 deletions
|
@ -14,7 +14,7 @@ import qualified Data.ByteString as B
|
||||||
import qualified Data.ByteString.Lazy as BL
|
import qualified Data.ByteString.Lazy as BL
|
||||||
import Data.IORef (newIORef, readIORef, writeIORef)
|
import Data.IORef (newIORef, readIORef, writeIORef)
|
||||||
import Data.List (unfoldr)
|
import Data.List (unfoldr)
|
||||||
import Data.Maybe (catMaybes)
|
import Data.Maybe (catMaybes, fromMaybe)
|
||||||
import Data.Monoid (Monoid, mempty, mappend)
|
import Data.Monoid (Monoid, mempty, mappend)
|
||||||
import Data.Proxy (Proxy(Proxy))
|
import Data.Proxy (Proxy(Proxy))
|
||||||
import Data.String (fromString)
|
import Data.String (fromString)
|
||||||
|
@ -66,6 +66,8 @@ toApplication ra request respond = do
|
||||||
respond $ responseLBS methodNotAllowed405 [] "method not allowed"
|
respond $ responseLBS methodNotAllowed405 [] "method not allowed"
|
||||||
routingRespond (Left (InvalidBody err)) =
|
routingRespond (Left (InvalidBody err)) =
|
||||||
respond $ responseLBS badRequest400 [] $ fromString $ "Invalid JSON in request body: " ++ 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) =
|
routingRespond (Right response) =
|
||||||
respond response
|
respond response
|
||||||
|
|
||||||
|
@ -74,12 +76,15 @@ data RouteMismatch =
|
||||||
NotFound -- ^ the usual "not found" error
|
NotFound -- ^ the usual "not found" error
|
||||||
| WrongMethod -- ^ a more informative "you just got the HTTP method wrong" 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
|
| 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)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
-- |
|
-- |
|
||||||
-- @
|
-- @
|
||||||
-- > mempty = NotFound
|
-- > mempty = NotFound
|
||||||
-- >
|
-- >
|
||||||
|
-- > _ `mappend` HttpError s b = HttpError s b
|
||||||
|
-- > HttpError s b `mappend` _ = HttpError s b
|
||||||
-- > NotFound `mappend` x = x
|
-- > NotFound `mappend` x = x
|
||||||
-- > WrongMethod `mappend` InvalidBody s = InvalidBody s
|
-- > WrongMethod `mappend` InvalidBody s = InvalidBody s
|
||||||
-- > WrongMethod `mappend` _ = WrongMethod
|
-- > WrongMethod `mappend` _ = WrongMethod
|
||||||
|
@ -88,6 +93,8 @@ data RouteMismatch =
|
||||||
instance Monoid RouteMismatch where
|
instance Monoid RouteMismatch where
|
||||||
mempty = NotFound
|
mempty = NotFound
|
||||||
|
|
||||||
|
_ `mappend` HttpError s b = HttpError s b
|
||||||
|
HttpError s b `mappend` _ = HttpError s b
|
||||||
NotFound `mappend` x = x
|
NotFound `mappend` x = x
|
||||||
WrongMethod `mappend` InvalidBody s = InvalidBody s
|
WrongMethod `mappend` InvalidBody s = InvalidBody s
|
||||||
WrongMethod `mappend` _ = WrongMethod
|
WrongMethod `mappend` _ = WrongMethod
|
||||||
|
|
|
@ -11,11 +11,12 @@ module Servant.ServerSpec where
|
||||||
import Control.Monad.Trans.Either (EitherT, left)
|
import Control.Monad.Trans.Either (EitherT, left)
|
||||||
import Data.Aeson (ToJSON, FromJSON, encode, decode')
|
import Data.Aeson (ToJSON, FromJSON, encode, decode')
|
||||||
import Data.Char (toUpper)
|
import Data.Char (toUpper)
|
||||||
|
import Data.Monoid ((<>))
|
||||||
import Data.Proxy (Proxy(Proxy))
|
import Data.Proxy (Proxy(Proxy))
|
||||||
import Data.String (fromString)
|
import Data.String (fromString)
|
||||||
import Data.String.Conversions (cs)
|
import Data.String.Conversions (cs)
|
||||||
import GHC.Generics (Generic)
|
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 (Application, Request, responseLBS, pathInfo, queryString, rawQueryString)
|
||||||
import Network.Wai.Test (runSession, request, defaultRequest, simpleBody)
|
import Network.Wai.Test (runSession, request, defaultRequest, simpleBody)
|
||||||
import Test.Hspec (Spec, describe, it, shouldBe)
|
import Test.Hspec (Spec, describe, it, shouldBe)
|
||||||
|
@ -31,6 +32,7 @@ import Servant.API.Raw (Raw)
|
||||||
import Servant.API.Sub ((:>))
|
import Servant.API.Sub ((:>))
|
||||||
import Servant.API.Alternative ((:<|>)((:<|>)))
|
import Servant.API.Alternative ((:<|>)((:<|>)))
|
||||||
import Servant.Server (Server, serve)
|
import Servant.Server (Server, serve)
|
||||||
|
import Servant.Server.Internal (RouteMismatch(..))
|
||||||
|
|
||||||
|
|
||||||
-- * test data types
|
-- * test data types
|
||||||
|
@ -74,6 +76,7 @@ spec = do
|
||||||
postSpec
|
postSpec
|
||||||
rawSpec
|
rawSpec
|
||||||
unionSpec
|
unionSpec
|
||||||
|
errorsSpec
|
||||||
|
|
||||||
|
|
||||||
type CaptureApi = Capture "legs" Integer :> Get Animal
|
type CaptureApi = Capture "legs" Integer :> Get Animal
|
||||||
|
@ -364,3 +367,48 @@ unionSpec = do
|
||||||
liftIO $ do
|
liftIO $ do
|
||||||
decode' (simpleBody response_) `shouldBe`
|
decode' (simpleBody response_) `shouldBe`
|
||||||
Just jerry
|
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
|
||||||
|
|
Loading…
Add table
Reference in a new issue