6234eae · servant · git.iko.soy

git.iko.soy/servant

on master help sign in

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

6234eaeAlp Mestanogullari10 years ago

servant/servant.cabal+1−1

compare with master

unifiedsplit

@@ -111,10 +111,10 @@ test-suite spec

111 base == 4.*

112 , base-compat

113 , aeson

114+ , aeson-compat >=0.3.3 && <0.4

114 , attoparsec

115 , attoparsec

115 , bytestring

116 , bytestring

116 , hspec == 2.*

117 , hspec == 2.*

117− , http-media

118 , QuickCheck

119 , quickcheck-instances

120 , servant

servant/src/Servant/API/ContentTypes.hs+12−2

@@ -206,6 +206,16 @@ instance OVERLAPPABLE_

206--

207class Accept ctype => MimeUnrender ctype a where

208 mimeUnrender :: Proxy ctype -> ByteString -> Either String a

209+ mimeUnrender p = mimeUnrenderWithType p (contentType p)

210+

211+ -- | Variant which is given the actual 'M.MediaType' provided by the other party.

212+ --

213+ -- In the most cases you don't want to branch based on the 'M.MediaType'.

214+ -- See <https://github.com/haskell-servant/servant/pull/552 pr552> for a motivating example.

215+ mimeUnrenderWithType :: Proxy ctype -> M.MediaType -> ByteString -> Either String a

216+ mimeUnrenderWithType p _ = mimeUnrender p

217+

218+ {-# MINIMAL mimeUnrender | mimeUnrenderWithType #-}

209

219

210class AllCTUnrender (list :: [*]) a where

220class AllCTUnrender (list :: [*]) a where

211 handleCTypeH :: Proxy list

221 handleCTypeH :: Proxy list

@@ -290,10 +300,10 @@ instance ( MimeUnrender ctyp a

290 , AllMimeUnrender ctyps a

300 , AllMimeUnrender ctyps a

291 ) => AllMimeUnrender (ctyp ': ctyps) a where

301 ) => AllMimeUnrender (ctyp ': ctyps) a where

292 allMimeUnrender _ bs =

302 allMimeUnrender _ bs =

293− (map (, x) $ NE.toList $ contentTypes pctyp)

303+ (map mk $ NE.toList $ contentTypes pctyp)

294 ++ allMimeUnrender pctyps bs

304 ++ allMimeUnrender pctyps bs

295 where

305 where

296− x = mimeUnrender pctyp bs

306+ mk ct = (ct, mimeUnrenderWithType pctyp ct bs)

297 pctyp = Proxy :: Proxy ctyp

307 pctyp = Proxy :: Proxy ctyp

298 pctyps = Proxy :: Proxy ctyps

308 pctyps = Proxy :: Proxy ctyps

299

309

servant/test/Servant/API/ContentTypesSpec.hs+17−3

@@ -11,7 +11,7 @@ module Servant.API.ContentTypesSpec where

11import Prelude ()

12import Prelude.Compat

14−import Data.Aeson

14+import Data.Aeson.Compat

15import Data.ByteString.Char8 (ByteString, append, pack)

16import qualified Data.ByteString.Lazy as BSL

17import qualified Data.ByteString.Lazy.Char8 as BSL8

@@ -24,9 +24,9 @@ import Data.Proxy

24import Data.String (IsString (..))

25import Data.String.Conversions (cs)

26import qualified Data.Text as TextS

27+import qualified Data.Text.Encoding as TextSE

27import qualified Data.Text.Lazy as TextL

28import qualified Data.Text.Lazy as TextL

28import GHC.Generics

29import GHC.Generics

29−import qualified Network.HTTP.Media as M

30import Test.Hspec

31import Test.QuickCheck

32import Text.Read (readMaybe)

@@ -179,6 +179,15 @@ spec = describe "Servant.API.ContentTypes" $ do

179 handleCTypeH (Proxy :: Proxy '[JSONorText]) "image/jpeg"

180 "42" `shouldBe` (Nothing :: Maybe (Either String Int))

181

182+ it "passes content-type to mimeUnrenderWithType" $ do

183+ let val = "foobar" :: TextS.Text

184+ handleCTypeH (Proxy :: Proxy '[JSONorText]) "application/json"

185+ "\"foobar\"" `shouldBe` Just (Right val)

186+ handleCTypeH (Proxy :: Proxy '[JSONorText]) "text/plain"

187+ "foobar" `shouldBe` Just (Right val)

188+ handleCTypeH (Proxy :: Proxy '[JSONorText]) "image/jpeg"

189+ "foobar" `shouldBe` (Nothing :: Maybe (Either String Int))

190+

182#if MIN_VERSION_aeson(0,9,0)

191#if MIN_VERSION_aeson(0,9,0)

183 -- aeson >= 0.9 decodes top-level strings

192 -- aeson >= 0.9 decodes top-level strings

184 describe "eitherDecodeLenient" $ do

193 describe "eitherDecodeLenient" $ do

@@ -226,7 +235,7 @@ instance IsString AcceptHeader where

226data JSONorText

235data JSONorText

227

236

228instance Accept JSONorText where

237instance Accept JSONorText where

229− contentTypes _ = "text" M.// "plain" NE.:| [ "application" M.// "json" ]

238+ contentTypes _ = "text/plain" NE.:| [ "application/json" ]

230

239

231instance MimeRender JSONorText Int where

240instance MimeRender JSONorText Int where

232 mimeRender _ = cs . show

241 mimeRender _ = cs . show

@@ -234,6 +243,11 @@ instance MimeRender JSONorText Int where

234instance MimeUnrender JSONorText Int where

243instance MimeUnrender JSONorText Int where

235 mimeUnrender _ = maybe (Left "") Right . readMaybe . BSL8.unpack

244 mimeUnrender _ = maybe (Left "") Right . readMaybe . BSL8.unpack

236

245

246+instance MimeUnrender JSONorText TextS.Text where

247+ mimeUnrenderWithType _ mt

248+ | mt == "application/json" = maybe (Left "") Right . decode

249+ | otherwise = Right . TextSE.decodeUtf8 . BSL.toStrict

250+

237addToAccept :: Accept a => Proxy a -> ZeroToOne -> AcceptHeader -> AcceptHeader

251addToAccept :: Accept a => Proxy a -> ZeroToOne -> AcceptHeader -> AcceptHeader

238addToAccept p (ZeroToOne f) (AcceptHeader h) = AcceptHeader (cont h)

252addToAccept p (ZeroToOne f) (AcceptHeader h) = AcceptHeader (cont h)

239 where new = cs (show $ contentType p) `append` "; q=" `append` pack (show f)

253 where new = cs (show $ contentType p) `append` "; q=" `append` pack (show f)

stack-ghc-7.8.4.yaml+1

@@ -6,6 +6,7 @@ packages:

6- servant-foreign/

7- servant-server/

8extra-deps:

9+- aeson-compat-0.3.6

9- base-compat-0.9.1

10- base-compat-0.9.1

10- control-monad-omega-0.3.1

11- control-monad-omega-0.3.1

11- cryptonite-0.6

12- cryptonite-0.6