6b55bf5 · servant · git.iko.soy

git.iko.soy/servant

Add RouteMismatch constructor for arbitrary HTTP response code

commit6b55bf583d1fce3495dafc598cab9c96489988d9 authorThomas Sutton <me@thomas-sutton.id.au> dateFri 30 Jan 2015, 11:36 (12 years ago) parent0bb35b8

2 files changed+57−2

compare with master

unifiedsplit

src/Servant/Server/Internal.hs+8−1 test/Servant/ServerSpec.hs+49−1

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

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

1414import qualified Data.ByteString.Lazy as BL

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

1616import Data.List (unfoldr)

17−import Data.Maybe (catMaybes)

17+import Data.Maybe (catMaybes, fromMaybe)

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

1919import Data.Proxy (Proxy(Proxy))

2020import Data.String (fromString)

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

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

6767 routingRespond (Left (InvalidBody err)) =

6868 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

6971 routingRespond (Right response) =

7072 respond response

7173

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

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

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

7678 | 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.

7780 deriving (Eq, Show)

7881

7982-- |

8083-- @

8184-- > mempty = NotFound

8285-- >

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

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

8388-- > NotFound `mappend` x = x

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

8590-- > WrongMethod `mappend` _ = WrongMethod

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

8893instance Monoid RouteMismatch where

8994 mempty = NotFound

9095

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

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

9198 NotFound `mappend` x = x

9299 WrongMethod `mappend` InvalidBody s = InvalidBody s

93100 WrongMethod `mappend` _ = WrongMethod

test/Servant/ServerSpec.hs+49−1

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

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

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

1313import Data.Char (toUpper)

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

1415import Data.Proxy (Proxy(Proxy))

1516import Data.String (fromString)

1617import Data.String.Conversions (cs)

1718import GHC.Generics (Generic)

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

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

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

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

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

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

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

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

3334import Servant.Server (Server, serve)

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

3436

3537

3638-- * test data types

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

7476 postSpec

7577 rawSpec

7678 unionSpec

79+ errorsSpec

7780

7881

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

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

364367 liftIO $ do

365368 decode' (simpleBody response_) `shouldBe`

366369 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