diff --git a/servant/servant.cabal b/servant/servant.cabal index 3c89171f..95350ef1 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -109,6 +109,7 @@ test-suite spec , attoparsec , bytestring , hspec == 2.* + , mtl >= 2 && < 3 , QuickCheck , quickcheck-instances , servant diff --git a/servant/src/Servant/API/ContentTypes.hs b/servant/src/Servant/API/ContentTypes.hs index f10e2ba1..f3bc9397 100644 --- a/servant/src/Servant/API/ContentTypes.hs +++ b/servant/src/Servant/API/ContentTypes.hs @@ -74,6 +74,7 @@ module Servant.API.ContentTypes import Control.Arrow (left) import Control.Monad.Compat +import Control.Monad.Except (ExceptT, MonadError(..)) import Data.Aeson (FromJSON(..), ToJSON(..), encode) import Data.Aeson.Parser (value) import Data.Aeson.Types (parseEither) @@ -183,6 +184,7 @@ instance OVERLAPPABLE_ -- -- >>> import Network.HTTP.Media hiding (Accept) -- >>> import qualified Data.ByteString.Lazy.Char8 as BSC +-- >>> import Control.Monad.Except -- >>> data MyContentType = MyContentType String -- -- >>> :{ @@ -194,19 +196,19 @@ instance OVERLAPPABLE_ --instance Read a => MimeUnrender MyContentType a where -- mimeUnrender _ bs = case BSC.take 12 bs of -- "MyContentType" -> return . read . BSC.unpack $ BSC.drop 12 bs --- _ -> Left "didn't start with the magic incantation" +-- _ -> throwError "didn't start with the magic incantation" -- :} -- -- >>> type MyAPI = "path" :> ReqBody '[MyContentType] Int :> Get '[JSON] Int -- class Accept ctype => MimeUnrender ctype a where - mimeUnrender :: Proxy ctype -> ByteString -> Either String a + mimeUnrender :: Proxy ctype -> ByteString -> ExceptT String IO a class AllCTUnrender (list :: [*]) a where handleCTypeH :: Proxy list -> ByteString -- Content-Type header -> ByteString -- Request body - -> Maybe (Either String a) + -> Maybe (ExceptT String IO a) instance ( AllMimeUnrender ctyps a ) => AllCTUnrender ctyps a where handleCTypeH _ ctypeH body = M.mapContentMedia lkup (cs ctypeH) @@ -269,7 +271,7 @@ instance OVERLAPPING_ class (AllMime list) => AllMimeUnrender (list :: [*]) a where allMimeUnrender :: Proxy list -> ByteString - -> [(M.MediaType, Either String a)] + -> [(M.MediaType, ExceptT String IO a)] instance AllMimeUnrender '[] a where allMimeUnrender _ _ = [] @@ -344,35 +346,35 @@ eitherDecodeLenient input = <* skipSpace <* (endOfInput "trailing junk after valid JSON") --- | `eitherDecode` +-- | @either throwError return . eitherDecodeLenient@ instance FromJSON a => MimeUnrender JSON a where - mimeUnrender _ = eitherDecodeLenient + mimeUnrender _ = either throwError return . eitherDecodeLenient --- | @decodeFormUrlEncoded >=> fromFormUrlEncoded@ +-- | @either throwError return . (decodeFormUrlEncoded >=> fromFormUrlEncoded)@ -- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only -- holds if every element of x is non-null (i.e., not @("", "")@) instance FromFormUrlEncoded a => MimeUnrender FormUrlEncoded a where - mimeUnrender _ = decodeFormUrlEncoded >=> fromFormUrlEncoded + mimeUnrender _ = either throwError return . (decodeFormUrlEncoded >=> fromFormUrlEncoded) --- | @left show . TextL.decodeUtf8'@ +-- | @either throwError return . left show . TextL.decodeUtf8'@ instance MimeUnrender PlainText TextL.Text where - mimeUnrender _ = left show . TextL.decodeUtf8' + mimeUnrender _ = either throwError return . left show . TextL.decodeUtf8' --- | @left show . TextS.decodeUtf8' . toStrict@ +-- | @either throwError return . left show . TextS.decodeUtf8' . toStrict@ instance MimeUnrender PlainText TextS.Text where - mimeUnrender _ = left show . TextS.decodeUtf8' . toStrict + mimeUnrender _ = either throwError return . left show . TextS.decodeUtf8' . toStrict --- | @Right . BC.unpack@ +-- | @return . BC.unpack@ instance MimeUnrender PlainText String where - mimeUnrender _ = Right . BC.unpack + mimeUnrender _ = return . BC.unpack --- | @Right . id@ +-- | @return . id@ instance MimeUnrender OctetStream ByteString where - mimeUnrender _ = Right . id + mimeUnrender _ = return --- | @Right . toStrict@ +-- | @return . toStrict@ instance MimeUnrender OctetStream BS.ByteString where - mimeUnrender _ = Right . toStrict + mimeUnrender _ = return . toStrict -------------------------------------------------------------------------- diff --git a/servant/test/Servant/API/ContentTypesSpec.hs b/servant/test/Servant/API/ContentTypesSpec.hs index 1a155b5c..fb42c14e 100644 --- a/servant/test/Servant/API/ContentTypesSpec.hs +++ b/servant/test/Servant/API/ContentTypesSpec.hs @@ -4,6 +4,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE PolyKinds #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Servant.API.ContentTypesSpec where @@ -12,6 +13,9 @@ import Prelude () import Prelude.Compat import Control.Arrow +import Control.Monad (when) +import Control.Monad.Except (runExceptT) +import Control.Monad.Trans (liftIO) import Data.Aeson import Data.ByteString.Char8 (ByteString, append, pack) import qualified Data.ByteString.Lazy as BSL @@ -28,10 +32,40 @@ import GHC.Generics import Network.URL (exportParams, importParams) import Test.Hspec import Test.QuickCheck +import Test.QuickCheck.Monadic import "quickcheck-instances" Test.QuickCheck.Instances () import Servant.API.ContentTypes +shouldUnrenderTo :: (MimeUnrender ct a, Eq a, Show a) => (Proxy ct, BSL.ByteString) -> a -> IO () +shouldUnrenderTo (p, bs) x = do + res <- runExceptT (mimeUnrender p bs) + res `shouldBe` Right x + +shouldNotUnrenderTo :: forall ct a. (MimeUnrender ct a, Show a) => + (Proxy ct, BSL.ByteString) -> Proxy a -> IO () +shouldNotUnrenderTo (p, bs) _ = do + res <- runExceptT (mimeUnrender p bs) + res `shouldSatisfy` (isLeft :: Either e a -> Bool) + +shouldHandleCTypeH :: (AllCTUnrender cts a, Eq a, Show a) => + (Proxy cts, BSL.ByteString, BSL.ByteString) -> a -> IO () +shouldHandleCTypeH (p, ct, bs) x = do + res <- traverse runExceptT (handleCTypeH p ct bs) + res `shouldBe` Just (Right x) + +shouldNotFindCTypeH :: forall cts a. (AllCTUnrender cts a, Eq a, Show a) => + (Proxy cts, BSL.ByteString, BSL.ByteString) -> Proxy a -> IO () +shouldNotFindCTypeH (p, ct, bs) _ = do + res <- traverse runExceptT (handleCTypeH p ct bs) + res `shouldBe` (Nothing :: Maybe (Either String a)) + +shouldHandleCTypeHSatisfy :: forall cts a. (AllCTUnrender cts a, Show a) => + (Proxy cts, BSL.ByteString, BSL.ByteString) -> (Maybe (Either String a) -> Bool) -> IO () +shouldHandleCTypeHSatisfy (p, ct, bs) f = do + res <- traverse runExceptT (handleCTypeH p ct bs) + res `shouldSatisfy` f + spec :: Spec spec = describe "Servant.API.ContentTypes" $ do @@ -53,31 +87,37 @@ spec = describe "Servant.API.ContentTypes" $ do let p = Proxy :: Proxy JSON it "handles whitespace at end of input" $ do - mimeUnrender p "[1] " `shouldBe` Right [1 :: Int] + (p, "[1] ") `shouldUnrenderTo` [1 :: Int] it "handles whitespace at beginning of input" $ do - mimeUnrender p " [1] " `shouldBe` Right [1 :: Int] + (p, " [1]") `shouldUnrenderTo` [1 :: Int] it "does not like junk at end of input" $ do - mimeUnrender p "[1] this probably shouldn't work" - `shouldSatisfy` (isLeft :: Either a [Int] -> Bool) + (p, "[1] this probably shouldn't work") + `shouldNotUnrenderTo` (Proxy :: Proxy [Int]) it "has mimeUnrender reverse mimeRender for valid top-level json ([Int]) " $ do - property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::[Int]) + property $ \x -> monadicIO $ do + res <- liftIO $ runExceptT (mimeUnrender p (mimeRender p x)) + assert (res == Right (x::[Int])) it "has mimeUnrender reverse mimeRender for valid top-level json " $ do - property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::SomeData) + property $ \x -> monadicIO $ do + res <- liftIO $ runExceptT (mimeUnrender p (mimeRender p x)) + assert (res == Right (x::[SomeData])) describe "The FormUrlEncoded Content-Type type" $ do let p = Proxy :: Proxy FormUrlEncoded it "has mimeUnrender reverse mimeRender" $ do - property $ \x -> mempty `notElem` x - ==> mimeUnrender p (mimeRender p x) == Right (x::[(TextS.Text,TextS.Text)]) + property $ \x -> monadicIO $ when (mempty `notElem` x) $ do + res <- liftIO . runExceptT $ mimeUnrender p (mimeRender p x) + assert (res == Right (x::[(TextS.Text,TextS.Text)])) it "has mimeUnrender reverse exportParams (Network.URL)" $ do - property $ \x -> mempty `notElem` x - ==> (mimeUnrender p . cs . exportParams . map (cs *** cs) $ x) == Right (x::[(TextS.Text,TextS.Text)]) + property $ \x -> monadicIO $ when (mempty `notElem` x) $ do + res <- liftIO . runExceptT $ mimeUnrender p . cs . exportParams . map (cs *** cs) $ x + assert (res == Right (x::[(TextS.Text,TextS.Text)])) it "has importParams (Network.URL) reverse mimeRender" $ do property $ \x -> mempty `notElem` x @@ -87,21 +127,29 @@ spec = describe "Servant.API.ContentTypes" $ do let p = Proxy :: Proxy PlainText it "has mimeUnrender reverse mimeRender (lazy Text)" $ do - property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::TextL.Text) + property $ \x -> monadicIO $ do + res <- liftIO . runExceptT $ mimeUnrender p (mimeRender p x) + assert (res == Right (x::TextL.Text)) it "has mimeUnrender reverse mimeRender (strict Text)" $ do - property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::TextS.Text) + property $ \x -> monadicIO $ do + res <- liftIO . runExceptT $ mimeUnrender p (mimeRender p x) + assert (res == Right (x::TextS.Text)) describe "The OctetStream Content-Type type" $ do let p = Proxy :: Proxy OctetStream it "is id (Lazy ByteString)" $ do - property $ \x -> mimeRender p x == (x :: BSL.ByteString) - && mimeUnrender p x == Right x + property $ \x -> monadicIO $ do + assert (mimeRender p x == (x :: BSL.ByteString)) + res <- liftIO . runExceptT $ mimeUnrender p x + assert (res == Right x) it "is fromStrict/toStrict (Strict ByteString)" $ do - property $ \x -> mimeRender p x == BSL.fromStrict (x :: ByteString) - && mimeUnrender p (BSL.fromStrict x) == Right x + property $ \x -> monadicIO $ do + assert (mimeRender p x == BSL.fromStrict (x :: ByteString)) + res <- liftIO . runExceptT $ mimeUnrender p (BSL.fromStrict x) + assert (res == Right x) describe "handleAcceptH" $ do @@ -147,33 +195,29 @@ spec = describe "Servant.API.ContentTypes" $ do describe "handleCTypeH" $ do it "returns Nothing if the 'Content-Type' header doesn't match" $ do - handleCTypeH (Proxy :: Proxy '[JSON]) "text/plain" "𝓽𝓱𝓮 𝓽𝓲𝓶𝓮 𝓱𝓪𝓼 𝓬𝓸𝓶𝓮, 𝓽𝓱𝓮 𝔀𝓪𝓵𝓻𝓾𝓼 𝓼𝓪𝓲𝓭 " - `shouldBe` (Nothing :: Maybe (Either String Value)) + (Proxy :: Proxy '[JSON], "text/plain", "𝓽𝓱𝓮 𝓽𝓲𝓶𝓮 𝓱𝓪𝓼 𝓬𝓸𝓶𝓮, 𝓽𝓱𝓮 𝔀𝓪𝓵𝓻𝓾𝓼 𝓼𝓪𝓲𝓭 ") + `shouldNotFindCTypeH` (Proxy :: Proxy Value) context "the 'Content-Type' header matches" $ do it "returns Just if the parameter matches" $ do - handleCTypeH (Proxy :: Proxy '[JSON]) "application/json" - "𝕥𝕠 𝕥𝕒𝕝𝕜 𝕠𝕗 𝕞𝕒𝕟𝕪 𝕥𝕙𝕚𝕟𝕘𝕤 " - `shouldSatisfy` (isJust :: Maybe (Either String Value) -> Bool) + (Proxy :: Proxy '[JSON], "application/json", "𝕥𝕠 𝕥𝕒𝕝𝕜 𝕠𝕗 𝕞𝕒𝕟𝕪 𝕥𝕙𝕚𝕟𝕘𝕤 ") + `shouldHandleCTypeHSatisfy` (isJust :: Maybe (Either String Value) -> Bool) it "returns Just if there is no parameter" $ do - handleCTypeH (Proxy :: Proxy '[JSON]) "application/json" - "𝕥𝕠 𝕥𝕒𝕝𝕜 𝕠𝕗 𝕞𝕒𝕟𝕪 𝕥𝕙𝕚𝕟𝕘𝕤 " - `shouldSatisfy` (isJust :: Maybe (Either String Value) -> Bool) + (Proxy :: Proxy '[JSON], "application/json", "𝕥𝕠 𝕥𝕒𝕝𝕜 𝕠𝕗 𝕞𝕒𝕟𝕪 𝕥𝕙𝕚𝕟𝕘𝕤 ") + `shouldHandleCTypeHSatisfy` (isJust :: Maybe (Either String Value) -> Bool) it "returns Just Left if the decoding fails" $ do let isJustLeft :: Maybe (Either String Value) -> Bool isJustLeft (Just (Left _)) = True isJustLeft _ = False - handleCTypeH (Proxy :: Proxy '[JSON]) "application/json" - "𝕺𝖋 𝖘𝖍𝖔𝖊𝖘--𝖆𝖓𝖉 𝖘𝖍𝖎𝖕𝖘--𝖆𝖓𝖉 𝖘𝖊𝖆𝖑𝖎𝖓𝖌-𝖜𝖆𝖝-- " - `shouldSatisfy` isJustLeft + (Proxy :: Proxy '[JSON], "application/json", "𝕺𝖋 𝖘𝖍𝖔𝖊𝖘--𝖆𝖓𝖉 𝖘𝖍𝖎𝖕𝖘--𝖆𝖓𝖉 𝖘𝖊𝖆𝖑𝖎𝖓𝖌-𝖜𝖆𝖝-- ") + `shouldHandleCTypeHSatisfy` isJustLeft it "returns Just (Right val) if the decoding succeeds" $ do let val = SomeData "Of cabbages--and kings" 12 - handleCTypeH (Proxy :: Proxy '[JSON]) "application/json" - (encode val) - `shouldBe` Just (Right val) + (Proxy :: Proxy '[JSON], "application/json", encode val) + `shouldHandleCTypeH` val #if MIN_VERSION_aeson(0,9,0) -- aeson >= 0.9 decodes top-level strings