Error retry tests

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

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

@@ -1,15 +1,19 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds             #-}
-{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE TypeOperators         #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 module Servant.Server.ErrorSpec (spec) where
 
-import Test.Hspec
+import           Data.Aeson                 (encode)
-import Data.Proxy
+import qualified Data.ByteString.Lazy.Char8 as BC
-import Test.Hspec.Wai (request, with, shouldRespondWith)
+import           Control.Monad.Trans.Either (left)
-import Network.HTTP.Types (methodGet, methodPost)
+import           Data.Proxy
-import Data.Aeson (encode)
+import           Network.HTTP.Types         (methodGet, methodPost)
+import           Test.Hspec
+import           Test.Hspec.Wai
 
-import Servant
+import           Servant
 
 
 -- 1) Check whether one or more endpoints have the right path. Otherwise return 404.
@@ -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,40 +46,108 @@ errorOrderApi :: Proxy ErrorOrderApi
 errorOrderApi = Proxy
 
 errorOrderServer :: Server ErrorOrderApi
-errorOrderServer = \_ _ -> return 10
+errorOrderServer = \_ _ -> left err402
 
 errorOrder :: Spec
 errorOrder = describe "HTTP error order"
            $ with (return $ serve errorOrderApi errorOrderServer) $ do
-    let badContentType  = ("Content-Type", "text/plain")
+  let badContentType  = ("Content-Type", "text/plain")
-        badAccept       = ("Accept", "text/plain")
+      badAccept       = ("Accept", "text/plain")
-        badMethod       = methodGet
+      badMethod       = methodGet
-        badUrl          = "home/nonexistent"
+      badUrl          = "home/nonexistent"
-        badBody         = "nonsense"
+      badBody         = "nonsense"
-        goodContentType = ("Content-Type", "application/json")
+      goodContentType = ("Content-Type", "application/json")
-        goodAccept      = ("Accept", "application/json")
+      goodAccept      = ("Accept", "application/json")
-        goodMethod      = methodPost
+      goodMethod      = methodPost
-        goodUrl         = "home/5"
+      goodUrl         = "home/5"
-        goodBody        = encode (5 :: Int)
+      goodBody        = encode (5 :: Int)
 
-    it "has 404 as its highest priority error" $ do
+  it "has 404 as its highest priority error" $ do
-        request badMethod badUrl [badContentType, badAccept] badBody
+    request badMethod badUrl [badContentType, badAccept] badBody
-            `shouldRespondWith` 404
+      `shouldRespondWith` 404
 
-    it "has 405 as its second highest priority error" $ do
+  it "has 405 as its second highest priority error" $ do
-        request badMethod goodUrl [badContentType, badAccept] badBody
+    request badMethod goodUrl [badContentType, badAccept] badBody
-            `shouldRespondWith` 405
+      `shouldRespondWith` 405
 
-    it "has 415 as its third highest priority error" $ do
+  it "has 415 as its third highest priority error" $ do
-        request goodMethod goodUrl [badContentType, badAccept] badBody
+    request goodMethod goodUrl [badContentType, badAccept] badBody
-            `shouldRespondWith` 415
+      `shouldRespondWith` 415
 
-    it "has 400 as its fourth highest priority error" $ do
+  it "has 400 as its fourth highest priority error" $ do
-        request goodMethod goodUrl [goodContentType, badAccept] badBody
+    request goodMethod goodUrl [goodContentType, badAccept] badBody
-            `shouldRespondWith` 400
+      `shouldRespondWith` 400
 
-    it "has 406 as its fifth highest priority error" $ do
+  it "has 406 as its fifth highest priority error" $ do
-        request goodMethod goodUrl [goodContentType, badAccept] goodBody
+    request goodMethod goodUrl [goodContentType, badAccept] goodBody
-            `shouldRespondWith` 406
+      `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