From 153de01a629077e2e668078b3fa4dfaca4079ae0 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Wed, 9 Sep 2015 14:17:17 -0700 Subject: [PATCH] Error retry tests Mime[Un]Render instances for PlainText String pragmas and formatting --- .../test/Servant/Server/ErrorSpec.hs | 147 +++++++++++++----- servant/CHANGELOG.md | 1 + servant/src/Servant/API/ContentTypes.hs | 9 ++ 3 files changed, 121 insertions(+), 36 deletions(-) diff --git a/servant-server/test/Servant/Server/ErrorSpec.hs b/servant-server/test/Servant/Server/ErrorSpec.hs index eaefe761..008642b7 100644 --- a/servant-server/test/Servant/Server/ErrorSpec.hs +++ b/servant-server/test/Servant/Server/ErrorSpec.hs @@ -1,15 +1,19 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# 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 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 +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") - badAccept = ("Accept", "text/plain") - badMethod = methodGet - badUrl = "home/nonexistent" - badBody = "nonsense" - goodContentType = ("Content-Type", "application/json") - goodAccept = ("Accept", "application/json") - goodMethod = methodPost - goodUrl = "home/5" - goodBody = encode (5 :: Int) + let badContentType = ("Content-Type", "text/plain") + badAccept = ("Accept", "text/plain") + badMethod = methodGet + badUrl = "home/nonexistent" + badBody = "nonsense" + goodContentType = ("Content-Type", "application/json") + goodAccept = ("Accept", "application/json") + goodMethod = methodPost + goodUrl = "home/5" + goodBody = encode (5 :: Int) - it "has 404 as its highest priority error" $ do - request badMethod badUrl [badContentType, badAccept] badBody - `shouldRespondWith` 404 + it "has 404 as its highest priority error" $ do + request badMethod badUrl [badContentType, badAccept] badBody + `shouldRespondWith` 404 - it "has 405 as its second highest priority error" $ do - request badMethod goodUrl [badContentType, badAccept] badBody - `shouldRespondWith` 405 + it "has 405 as its second highest priority error" $ do + request badMethod goodUrl [badContentType, badAccept] badBody + `shouldRespondWith` 405 - it "has 415 as its third highest priority error" $ do - request goodMethod goodUrl [badContentType, badAccept] badBody - `shouldRespondWith` 415 + it "has 415 as its third highest priority error" $ do + request goodMethod goodUrl [badContentType, badAccept] badBody + `shouldRespondWith` 415 - it "has 400 as its fourth highest priority error" $ do - request goodMethod goodUrl [goodContentType, badAccept] badBody - `shouldRespondWith` 400 + it "has 400 as its fourth highest priority error" $ do + request goodMethod goodUrl [goodContentType, badAccept] badBody + `shouldRespondWith` 400 - it "has 406 as its fifth highest priority error" $ do - request goodMethod goodUrl [goodContentType, badAccept] goodBody - `shouldRespondWith` 406 + it "has 406 as its fifth highest priority error" $ do + 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 +-- }}} diff --git a/servant/CHANGELOG.md b/servant/CHANGELOG.md index 012866f6..ddbe1a90 100644 --- a/servant/CHANGELOG.md +++ b/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 ----- diff --git a/servant/src/Servant/API/ContentTypes.hs b/servant/src/Servant/API/ContentTypes.hs index cf882dfc..db8eb61e 100644 --- a/servant/src/Servant/API/ContentTypes.hs +++ b/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