diff --git a/servant/servant.cabal b/servant/servant.cabal index e93e1cf7..35ef1ef9 100644 --- a/servant/servant.cabal +++ b/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 diff --git a/servant/src/Servant/API/ContentTypes.hs b/servant/src/Servant/API/ContentTypes.hs index 92a50d69..504fd397 100644 --- a/servant/src/Servant/API/ContentTypes.hs +++ b/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 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 diff --git a/servant/test/Servant/API/ContentTypesSpec.hs b/servant/test/Servant/API/ContentTypesSpec.hs index 560569c9..07fb5438 100644 --- a/servant/test/Servant/API/ContentTypesSpec.hs +++ b/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,7 +235,7 @@ 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 @@ -234,6 +243,11 @@ instance MimeRender JSONorText Int where 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) diff --git a/stack-ghc-7.8.4.yaml b/stack-ghc-7.8.4.yaml index eb20cfbe..54177bc5 100644 --- a/stack-ghc-7.8.4.yaml +++ b/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