Error retry tests

Mime[Un]Render instances for PlainText String
        pragmas and formatting

servant-server/test/Servant/Server/ErrorSpec.hs

@@ -1,13 +1,17 @@
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE TypeOperators         #-}
-{-# LANGUAGE DataKinds #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 module Servant.Server.ErrorSpec (spec) where
 
-import Test.Hspec
-import Data.Proxy
-import Test.Hspec.Wai (request, with, shouldRespondWith)
-import Network.HTTP.Types (methodGet, methodPost)
 import           Data.Aeson                 (encode)
+import qualified Data.ByteString.Lazy.Char8 as BC
+import           Control.Monad.Trans.Either (left)
+import           Data.Proxy
+import           Network.HTTP.Types         (methodGet, methodPost)
+import           Test.Hspec
+import           Test.Hspec.Wai
 
 import           Servant
 
@@ -26,9 +30,12 @@ import Servant
 -- 9) Call the handler. Whatever it returns, we return.
 
 spec :: Spec
-spec = do
+spec = describe "HTTP Errors" $ do
     errorOrder
+    errorRetry
 
+------------------------------------------------------------------------------
+-- * Error Order {{{
 
 type ErrorOrderApi = "home"
                   :> ReqBody '[JSON] Int
@@ -39,7 +46,7 @@ errorOrderApi :: Proxy ErrorOrderApi
 errorOrderApi = Proxy
 
 errorOrderServer :: Server ErrorOrderApi
-errorOrderServer = \_ _ -> return 10
+errorOrderServer = \_ _ -> left err402
 
 errorOrder :: Spec
 errorOrder = describe "HTTP error order"
@@ -75,4 +82,72 @@ errorOrder = describe "HTTP error order"
     request goodMethod goodUrl [goodContentType, badAccept] goodBody
       `shouldRespondWith` 406
 
+  it "returns handler errors as its lower priority errors" $ do
+    request goodMethod goodUrl [goodContentType, goodAccept] goodBody
+      `shouldRespondWith` 402
 
+-- }}}
+------------------------------------------------------------------------------
+-- * Error Retry {{{
+
+type ErrorRetryApi
+     = "a" :> ReqBody '[JSON] Int      :> Post '[JSON] Int                -- 0
+  :<|> "a" :> ReqBody '[PlainText] Int :> Post '[JSON] Int                -- 1
+  :<|> "a" :> ReqBody '[JSON] Int      :> Post '[PlainText] Int           -- 2
+  :<|> "a" :> ReqBody '[JSON] String   :> Post '[JSON] Int                -- 3
+  :<|> "a" :> ReqBody '[JSON] Int      :> Get  '[PlainText] Int           -- 4
+  :<|>        ReqBody '[JSON] Int      :> Get  '[JSON] Int                -- 5
+  :<|>        ReqBody '[JSON] Int      :> Get  '[JSON] Int                -- 6
+
+errorRetryApi :: Proxy ErrorRetryApi
+errorRetryApi = Proxy
+
+errorRetryServer :: Server ErrorRetryApi
+errorRetryServer
+     = (\_ -> return 0)
+  :<|> (\_ -> return 1)
+  :<|> (\_ -> return 2)
+  :<|> (\_ -> return 3)
+  :<|> (\_ -> return 4)
+  :<|> (\_ -> return 5)
+  :<|> (\_ -> return 6)
+
+errorRetry :: Spec
+errorRetry = describe "Handler search"
+           $ with (return $ serve errorRetryApi errorRetryServer) $ do
+  let plainCT     = ("Content-Type", "text/plain")
+      plainAccept = ("Accept", "text/plain")
+      jsonCT      = ("Content-Type", "application/json")
+      jsonAccept  = ("Accept", "application/json")
+      jsonBody    = encode (1797 :: Int)
+
+  it "should continue when URLs don't match" $ do
+    request methodPost "" [jsonCT, jsonAccept] jsonBody
+     `shouldRespondWith` 201 { matchBody = Just $ encode (5 :: Int) }
+
+  it "should continue when methods don't match" $ do
+    request methodGet "a" [jsonCT, jsonAccept] jsonBody
+     `shouldRespondWith` 200 { matchBody = Just $ encode (4 :: Int) }
+
+  it "should not continue when Content-Types don't match" $ do
+    request methodPost "a" [plainCT, jsonAccept] jsonBody
+     `shouldRespondWith` 415
+
+  it "should not continue when body can't be deserialized" $ do
+    request methodPost "a" [jsonCT, jsonAccept] (encode ("nonsense" :: String))
+     `shouldRespondWith` 400
+
+  it "should not continue when Accepts don't match" $ do
+    request methodPost "a" [jsonCT, plainAccept] jsonBody
+     `shouldRespondWith` 406
+
+-- }}}
+------------------------------------------------------------------------------
+-- * Instances {{{
+
+instance MimeUnrender PlainText Int where
+    mimeUnrender _ = Right . read . BC.unpack
+
+instance MimeRender PlainText Int where
+    mimeRender _ = BC.pack . show
+-- }}}

servant/CHANGELOG.md

@@ -6,6 +6,7 @@ HEAD
 * Add more instances for (:<|>)
 * Use `http-api-data` instead of `Servant.Common.Text`
 * Remove matrix params.
+* Add PlainText String MimeRender and MimeUnrender instances.
 
 0.4.2
 -----

servant/src/Servant/API/ContentTypes.hs

@@ -80,6 +80,7 @@ import qualified Data.ByteString                  as BS
 import           Data.ByteString.Lazy             (ByteString, fromStrict,
                                                    toStrict)
 import qualified Data.ByteString.Lazy             as B
+import qualified Data.ByteString.Lazy.Char8       as BC
 import           Data.Monoid
 import           Data.String.Conversions          (cs)
 import qualified Data.Text                        as TextS
@@ -279,6 +280,10 @@ instance MimeRender PlainText TextL.Text where
 instance MimeRender PlainText TextS.Text where
     mimeRender _ = fromStrict . TextS.encodeUtf8
 
+-- | @BC.pack@
+instance MimeRender PlainText String where
+    mimeRender _ = BC.pack
+
 -- | @id@
 instance MimeRender OctetStream ByteString where
     mimeRender _ = id
@@ -328,6 +333,10 @@ instance MimeUnrender PlainText TextL.Text where
 instance MimeUnrender PlainText TextS.Text where
     mimeUnrender _ = left show . TextS.decodeUtf8' . toStrict
 
+-- | @Right . BC.unpack@
+instance MimeUnrender PlainText String where
+    mimeUnrender _ = Right . BC.unpack
+
 -- | @Right . id@
 instance MimeUnrender OctetStream ByteString where
     mimeUnrender _ = Right . id