Allow IO when unrendering content types

servant/servant.cabal

@@ -109,6 +109,7 @@ test-suite spec
     , attoparsec
     , bytestring
     , hspec == 2.*
+    , mtl >= 2 && < 3
     , QuickCheck
     , quickcheck-instances
     , servant

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
 
 
 --------------------------------------------------------------------------

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"
+            (p, "[1] this probably shouldn't work")
-              `shouldSatisfy` (isLeft :: Either a [Int] -> Bool)
+              `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
+            property $ \x -> monadicIO $ when (mempty `notElem` x) $ do
-                ==> mimeUnrender p (mimeRender p x) == Right (x::[(TextS.Text,TextS.Text)])
+              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
+            property $ \x -> monadicIO $ when (mempty `notElem` x) $ do
-                ==> (mimeUnrender p . cs . exportParams . map (cs *** cs) $ x) == Right (x::[(TextS.Text,TextS.Text)])
+              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)
+            property $ \x -> monadicIO $ do
-                && mimeUnrender p x == Right x
+              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)
+            property $ \x -> monadicIO $ do
-                && mimeUnrender p (BSL.fromStrict x) == Right x
+              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" "𝓽𝓱𝓮 𝓽𝓲𝓶𝓮 𝓱𝓪𝓼 𝓬𝓸𝓶𝓮, 𝓽𝓱𝓮 𝔀𝓪𝓵𝓻𝓾𝓼 𝓼𝓪𝓲𝓭 "
+            (Proxy :: Proxy '[JSON], "text/plain", "𝓽𝓱𝓮 𝓽𝓲𝓶𝓮 𝓱𝓪𝓼 𝓬𝓸𝓶𝓮, 𝓽𝓱𝓮 𝔀𝓪𝓵𝓻𝓾𝓼 𝓼𝓪𝓲𝓭 ")
-                `shouldBe` (Nothing :: Maybe (Either String Value))
+              `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"
+                (Proxy :: Proxy '[JSON], "application/json", "𝕥𝕠 𝕥𝕒𝕝𝕜 𝕠𝕗 𝕞𝕒𝕟𝕪 𝕥𝕙𝕚𝕟𝕘𝕤 ")
-                    "𝕥𝕠 𝕥𝕒𝕝𝕜 𝕠𝕗 𝕞𝕒𝕟𝕪 𝕥𝕙𝕚𝕟𝕘𝕤 "
+                  `shouldHandleCTypeHSatisfy` (isJust :: Maybe (Either String Value) -> Bool)
-                    `shouldSatisfy` (isJust :: Maybe (Either String Value) -> Bool)
 
             it "returns Just if there is no parameter" $ do
-                handleCTypeH (Proxy :: Proxy '[JSON]) "application/json"
+                (Proxy :: Proxy '[JSON], "application/json", "𝕥𝕠 𝕥𝕒𝕝𝕜 𝕠𝕗 𝕞𝕒𝕟𝕪 𝕥𝕙𝕚𝕟𝕘𝕤 ")
-                    "𝕥𝕠 𝕥𝕒𝕝𝕜 𝕠𝕗 𝕞𝕒𝕟𝕪 𝕥𝕙𝕚𝕟𝕘𝕤 "
+                  `shouldHandleCTypeHSatisfy` (isJust :: Maybe (Either String Value) -> Bool)
-                    `shouldSatisfy` (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"
+                (Proxy :: Proxy '[JSON], "application/json", "𝕺𝖋 𝖘𝖍𝖔𝖊𝖘--𝖆𝖓𝖉 𝖘𝖍𝖎𝖕𝖘--𝖆𝖓𝖉 𝖘𝖊𝖆𝖑𝖎𝖓𝖌-𝖜𝖆𝖝-- ")
-                    "𝕺𝖋 𝖘𝖍𝖔𝖊𝖘--𝖆𝖓𝖉 𝖘𝖍𝖎𝖕𝖘--𝖆𝖓𝖉 𝖘𝖊𝖆𝖑𝖎𝖓𝖌-𝖜𝖆𝖝-- "
+                  `shouldHandleCTypeHSatisfy` isJustLeft
-                    `shouldSatisfy` 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"
+                (Proxy :: Proxy '[JSON], "application/json", encode val)
-                    (encode val)
+                  `shouldHandleCTypeH` val
-                    `shouldBe` Just (Right val)
 
 #if MIN_VERSION_aeson(0,9,0)
     -- aeson >= 0.9 decodes top-level strings