Merge pull request #22 from anchor/arbitrary-routemismatch

Add RouteMismatch constructor for arbitrary HTTP response code

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

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