Merge pull request #615 from phadej/mime-unrender-multiple

Mime unrender multiple

Author: alpmestan

servant/servant.cabal

@@ -111,10 +111,10 @@ test-suite spec
       base == 4.*
     , base-compat
     , aeson
+    , aeson-compat >=0.3.3 && <0.4
     , attoparsec
     , bytestring
     , hspec == 2.*
-    , http-media
     , QuickCheck
     , quickcheck-instances
     , servant

servant/src/Servant/API/ContentTypes.hs

@@ -206,6 +206,16 @@ instance OVERLAPPABLE_
 --
 class Accept ctype => MimeUnrender ctype a where
     mimeUnrender :: Proxy ctype -> ByteString -> Either String a
+    mimeUnrender p = mimeUnrenderWithType p (contentType p)
+
+    -- | Variant which is given the actual 'M.MediaType' provided by the other party.
+    --
+    -- In the most cases you don't want to branch based on the 'M.MediaType'.
+    -- See <https://github.com/haskell-servant/servant/pull/552 pr552> for a motivating example.
+    mimeUnrenderWithType :: Proxy ctype -> M.MediaType -> ByteString -> Either String a
+    mimeUnrenderWithType p _ = mimeUnrender p
+
+    {-# MINIMAL mimeUnrender | mimeUnrenderWithType #-}
 
 class AllCTUnrender (list :: [*]) a where
     handleCTypeH :: Proxy list
@@ -290,10 +300,10 @@ instance ( MimeUnrender ctyp a
          , AllMimeUnrender ctyps a
          ) => AllMimeUnrender (ctyp ': ctyps) a where
     allMimeUnrender _ bs =
-        (map (, x) $ NE.toList $ contentTypes pctyp)
+        (map mk $ NE.toList $ contentTypes pctyp)
         ++ allMimeUnrender pctyps bs
       where
-        x      = mimeUnrender pctyp bs
+        mk ct   = (ct, mimeUnrenderWithType pctyp ct bs)
         pctyp  = Proxy :: Proxy ctyp
         pctyps = Proxy :: Proxy ctyps
 

servant/test/Servant/API/ContentTypesSpec.hs

@@ -11,7 +11,7 @@ module Servant.API.ContentTypesSpec where
 import           Prelude ()
 import           Prelude.Compat
 
-import           Data.Aeson
+import           Data.Aeson.Compat
 import           Data.ByteString.Char8     (ByteString, append, pack)
 import qualified Data.ByteString.Lazy      as BSL
 import qualified Data.ByteString.Lazy.Char8 as BSL8
@@ -24,9 +24,9 @@ import           Data.Proxy
 import           Data.String               (IsString (..))
 import           Data.String.Conversions   (cs)
 import qualified Data.Text                 as TextS
+import qualified Data.Text.Encoding        as TextSE
 import qualified Data.Text.Lazy            as TextL
 import           GHC.Generics
-import qualified Network.HTTP.Media        as M
 import           Test.Hspec
 import           Test.QuickCheck
 import           Text.Read                 (readMaybe)
@@ -179,6 +179,15 @@ spec = describe "Servant.API.ContentTypes" $ do
                 handleCTypeH (Proxy :: Proxy '[JSONorText]) "image/jpeg"
                     "42" `shouldBe` (Nothing :: Maybe (Either String Int))
 
+            it "passes content-type to mimeUnrenderWithType" $ do
+                let val = "foobar" :: TextS.Text
+                handleCTypeH (Proxy :: Proxy '[JSONorText]) "application/json"
+                    "\"foobar\"" `shouldBe` Just (Right val)
+                handleCTypeH (Proxy :: Proxy '[JSONorText]) "text/plain"
+                    "foobar" `shouldBe` Just (Right val)
+                handleCTypeH (Proxy :: Proxy '[JSONorText]) "image/jpeg"
+                    "foobar" `shouldBe` (Nothing :: Maybe (Either String Int))
+
 #if MIN_VERSION_aeson(0,9,0)
     -- aeson >= 0.9 decodes top-level strings
     describe "eitherDecodeLenient" $ do
@@ -226,14 +235,19 @@ instance IsString AcceptHeader where
 data JSONorText
 
 instance Accept JSONorText where
-    contentTypes _ = "text" M.// "plain" NE.:| [ "application" M.// "json" ]
+    contentTypes _ = "text/plain" NE.:| [ "application/json" ]
 
 instance MimeRender JSONorText Int  where
     mimeRender _ = cs . show
 
 instance MimeUnrender JSONorText Int where
     mimeUnrender _ = maybe (Left "") Right . readMaybe . BSL8.unpack
 
+instance MimeUnrender JSONorText TextS.Text where
+    mimeUnrenderWithType _ mt
+        | mt == "application/json" = maybe (Left "") Right . decode
+        | otherwise                = Right . TextSE.decodeUtf8 . BSL.toStrict
+
 addToAccept :: Accept a => Proxy a -> ZeroToOne -> AcceptHeader -> AcceptHeader
 addToAccept p (ZeroToOne f) (AcceptHeader h) = AcceptHeader (cont h)
     where new = cs (show $ contentType p) `append` "; q=" `append` pack (show f)

stack-ghc-7.8.4.yaml

@@ -6,6 +6,7 @@ packages:
 - servant-foreign/
 - servant-server/
 extra-deps:
+- aeson-compat-0.3.6
 - base-compat-0.9.1
 - control-monad-omega-0.3.1
 - cryptonite-0.6