b6a6505 · servant · git.iko.soy

git.iko.soy/servant

on master help sign in

Merge pull request #22 from anchor/arbitrary-routemismatch

b6a6505Julian Arni12 years ago

src/Servant/Server/Internal.hs+8−1

compare with master

unifiedsplit

@@ -14,7 +14,7 @@ import qualified Data.ByteString as B

14import qualified Data.ByteString.Lazy as BL

15import Data.IORef (newIORef, readIORef, writeIORef)

16import Data.List (unfoldr)

17−import Data.Maybe (catMaybes)

17+import Data.Maybe (catMaybes, fromMaybe)

18import Data.Monoid (Monoid, mempty, mappend)

19import Data.Proxy (Proxy(Proxy))

20import Data.String (fromString)

@@ -66,6 +66,8 @@ toApplication ra request respond = do

66 respond $ responseLBS methodNotAllowed405 [] "method not allowed"

67 routingRespond (Left (InvalidBody err)) =

68 respond $ responseLBS badRequest400 [] $ fromString $ "Invalid JSON in request body: " ++ err

69+ routingRespond (Left (HttpError status body)) =

70+ respond $ responseLBS status [] $ fromMaybe (BL.fromStrict $ statusMessage status) body

69 routingRespond (Right response) =

71 routingRespond (Right response) =

70 respond response

72 respond response

@@ -74,12 +76,15 @@ data RouteMismatch =

74 NotFound -- ^ the usual "not found" error

76 NotFound -- ^ the usual "not found" error

75 | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error

77 | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error

76 | InvalidBody String -- ^ an even more informative "your json request body wasn't valid" error

78 | InvalidBody String -- ^ an even more informative "your json request body wasn't valid" error

79+ | HttpError Status (Maybe BL.ByteString) -- ^ an even even more informative arbitrary HTTP response code error.

77 deriving (Eq, Show)

80 deriving (Eq, Show)

79-- |

82-- |

80-- @

83-- @

81-- > mempty = NotFound

84-- > mempty = NotFound

82-- >

85-- >

86+-- > _ `mappend` HttpError s b = HttpError s b

87+-- > HttpError s b `mappend` _ = HttpError s b

83-- > NotFound `mappend` x = x

88-- > NotFound `mappend` x = x

84-- > WrongMethod `mappend` InvalidBody s = InvalidBody s

89-- > WrongMethod `mappend` InvalidBody s = InvalidBody s

85-- > WrongMethod `mappend` _ = WrongMethod

90-- > WrongMethod `mappend` _ = WrongMethod

@@ -88,6 +93,8 @@ data RouteMismatch =

88instance Monoid RouteMismatch where

93instance Monoid RouteMismatch where

89 mempty = NotFound

94 mempty = NotFound

96+ _ `mappend` HttpError s b = HttpError s b

97+ HttpError s b `mappend` _ = HttpError s b

91 NotFound `mappend` x = x

98 NotFound `mappend` x = x

92 WrongMethod `mappend` InvalidBody s = InvalidBody s

99 WrongMethod `mappend` InvalidBody s = InvalidBody s

93 WrongMethod `mappend` _ = WrongMethod

100 WrongMethod `mappend` _ = WrongMethod

test/Servant/ServerSpec.hs+49−1

@@ -11,11 +11,12 @@ module Servant.ServerSpec where

11import Control.Monad.Trans.Either (EitherT, left)

12import Data.Aeson (ToJSON, FromJSON, encode, decode')

13import Data.Char (toUpper)

14+import Data.Monoid ((<>))

14import Data.Proxy (Proxy(Proxy))

15import Data.Proxy (Proxy(Proxy))

15import Data.String (fromString)

16import Data.String (fromString)

16import Data.String.Conversions (cs)

17import Data.String.Conversions (cs)

17import GHC.Generics (Generic)

18import GHC.Generics (Generic)

18−import Network.HTTP.Types (parseQuery, ok200)

19+import Network.HTTP.Types (parseQuery, ok200, status409)

19import Network.Wai (Application, Request, responseLBS, pathInfo, queryString, rawQueryString)

20import Network.Wai (Application, Request, responseLBS, pathInfo, queryString, rawQueryString)

20import Network.Wai.Test (runSession, request, defaultRequest, simpleBody)

21import Network.Wai.Test (runSession, request, defaultRequest, simpleBody)

21import Test.Hspec (Spec, describe, it, shouldBe)

22import Test.Hspec (Spec, describe, it, shouldBe)

@@ -31,6 +32,7 @@ import Servant.API.Raw (Raw)

31import Servant.API.Sub ((:>))

32import Servant.API.Sub ((:>))

32import Servant.API.Alternative ((:<|>)((:<|>)))

33import Servant.API.Alternative ((:<|>)((:<|>)))

33import Servant.Server (Server, serve)

34import Servant.Server (Server, serve)

35+import Servant.Server.Internal (RouteMismatch(..))

36-- * test data types

38-- * test data types

@@ -74,6 +76,7 @@ spec = do

74 postSpec

76 postSpec

75 rawSpec

77 rawSpec

76 unionSpec

78 unionSpec

79+ errorsSpec

79type CaptureApi = Capture "legs" Integer :> Get Animal

82type CaptureApi = Capture "legs" Integer :> Get Animal

@@ -364,3 +367,48 @@ unionSpec = do

364 liftIO $ do

367 liftIO $ do

365 decode' (simpleBody response_) `shouldBe`

368 decode' (simpleBody response_) `shouldBe`

366 Just jerry

369 Just jerry

370+

371+-- | Test server error functionality.

372+errorsSpec :: Spec

373+errorsSpec = do

374+ let he = HttpError status409 (Just "A custom error")

375+ let ib = InvalidBody "The body is invalid"

376+ let wm = WrongMethod

377+ let nf = NotFound

378+

379+ describe "Servant.Server.Internal.RouteMismatch" $ do

380+ it "HttpError > *" $ do

381+ ib <> he `shouldBe` he

382+ wm <> he `shouldBe` he

383+ nf <> he `shouldBe` he

384+

385+ he <> ib `shouldBe` he

386+ he <> wm `shouldBe` he

387+ he <> nf `shouldBe` he

388+

389+ it "HE > InvalidBody > (WM,NF)" $ do

390+ he <> ib `shouldBe` he

391+ wm <> ib `shouldBe` ib

392+ nf <> ib `shouldBe` ib

393+

394+ ib <> he `shouldBe` he

395+ ib <> wm `shouldBe` ib

396+ ib <> nf `shouldBe` ib

397+

398+ it "HE > IB > WrongMethod > NF" $ do

399+ he <> wm `shouldBe` he

400+ ib <> wm `shouldBe` ib

401+ nf <> wm `shouldBe` wm

402+

403+ wm <> he `shouldBe` he

404+ wm <> ib `shouldBe` ib

405+ wm <> nf `shouldBe` wm

406+

407+ it "* > NotFound" $ do

408+ he <> nf `shouldBe` he

409+ ib <> nf `shouldBe` ib

410+ wm <> nf `shouldBe` wm

411+

412+ nf <> he `shouldBe` he

413+ nf <> ib `shouldBe` ib

414+ nf <> wm `shouldBe` wm