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

Mime unrender multiple
This commit is contained in:
Alp Mestanogullari 2017-01-01 22:17:50 +01:00 committed by GitHub
commit 6234eae2ac
4 changed files with 31 additions and 6 deletions

View file

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

View file

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

View file

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

View file

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