e8ba670 · servant · git.iko.soy

git.iko.soy/servant

Merge pull request #614 from phadej/accept-multiple

Allow multiple content-types for single Accept

commite8ba67048ab9024d7ae1c3feb0c07c08fb613999 authorAlp Mestanogullari <alpmestan@gmail.com> dateSun 1 Jan 2017, 11:31 (10 years ago) parent37ec081 da55698

5 files changed+82−19

compare with master

unifiedsplit

servant-client/src/Servant/Client.hs+1 servant-client/src/Servant/Common/Req.hs+5−4 servant/servant.cabal+10 servant/src/Servant/API/ContentTypes.hs+33−15 servant/test/Servant/API/ContentTypesSpec.hs+33

servant-client/src/Servant/Client.hs+1

@@ -407,6 +407,7 @@ instance (MimeRender ct a, HasClient api)

407407 clientWithRoute (Proxy :: Proxy api)

408408 (let ctProxy = Proxy :: Proxy ct

409409 in setRQBody (mimeRender ctProxy body)

410+ -- We use first contentType from the Accept list

410411 (contentType ctProxy)

411412 req

412413 )

servant-client/src/Servant/Common/Req.hs+5−4

@@ -13,6 +13,7 @@ import Prelude.Compat

1313import Control.Exception

1414import Control.Monad

1515import Control.Monad.Catch (MonadThrow, MonadCatch)

16+import Data.Foldable (toList)

1617

1718#if MIN_VERSION_mtl(2,2,0)

1819import Control.Monad.Except (MonadError(..))

@@ -25,7 +26,7 @@ import Control.Monad.Trans.Except

2526import GHC.Generics

2627import Control.Monad.IO.Class ()

2728import Control.Monad.Reader

28−import Data.ByteString.Lazy hiding (pack, filter, map, null, elem)

29+import Data.ByteString.Lazy hiding (pack, filter, map, null, elem, any)

2930import Data.String

3031import Data.String.Conversions

3132import Data.Proxy

@@ -215,10 +216,10 @@ performRequest reqMethod req = do

215216performRequestCT :: MimeUnrender ct result => Proxy ct -> Method -> Req

216217 -> ClientM ([HTTP.Header], result)

217218performRequestCT ct reqMethod req = do

218− let acceptCT = contentType ct

219+ let acceptCTS = contentTypes ct

219220 (_status, respBody, respCT, hdrs, _response) <-

220− performRequest reqMethod (req { reqAccept = [acceptCT] })

221− unless (matches respCT (acceptCT)) $ throwError $ UnsupportedContentType respCT respBody

221+ performRequest reqMethod (req { reqAccept = toList acceptCTS })

222+ unless (any (matches respCT) acceptCTS) $ throwError $ UnsupportedContentType respCT respBody

222223 case mimeUnrender ct respBody of

223224 Left err -> throwError $ DecodeFailure err respCT respBody

224225 Right val -> return (hdrs, val)

servant/servant.cabal+10

@@ -65,6 +65,11 @@ library

6565 , string-conversions >= 0.3 && < 0.5

6666 , network-uri >= 2.6 && < 2.7

6767 , vault >= 0.3 && < 0.4

68+

69+ if !impl(ghc >= 8.0)

70+ build-depends:

71+ semigroups >= 0.16 && < 0.19

72+

6873 hs-source-dirs: src

6974 default-language: Haskell2010

7075 other-extensions: CPP

@@ -109,6 +114,7 @@ test-suite spec

109114 , attoparsec

110115 , bytestring

111116 , hspec == 2.*

117+ , http-media

112118 , QuickCheck

113119 , quickcheck-instances

114120 , servant

@@ -116,6 +122,10 @@ test-suite spec

116122 , text

117123 , url

118124

125+ if !impl(ghc >= 8.0)

126+ build-depends:

127+ semigroups >= 0.16 && < 0.19

128+

119129test-suite doctests

120130 build-depends: base

121131 , servant

servant/src/Servant/API/ContentTypes.hs+33−15

@@ -8,6 +8,7 @@

88{-# LANGUAGE OverloadedStrings #-}

99{-# LANGUAGE PolyKinds #-}

1010{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE TupleSections #-}

1112{-# LANGUAGE TypeFamilies #-}

1213{-# LANGUAGE TypeOperators #-}

1314{-# LANGUAGE UndecidableInstances #-}

@@ -81,6 +82,7 @@ import qualified Data.ByteString as BS

8182import Data.ByteString.Lazy (ByteString, fromStrict,

8283 toStrict)

8384import qualified Data.ByteString.Lazy.Char8 as BC

85+import qualified Data.List.NonEmpty as NE

8486import Data.Maybe (isJust)

8587import Data.String.Conversions (cs)

8688import qualified Data.Text as TextS

@@ -119,6 +121,12 @@ data OctetStream deriving Typeable

119121--

120122class Accept ctype where

121123 contentType :: Proxy ctype -> M.MediaType

124+ contentType = NE.head . contentTypes

125+

126+ contentTypes :: Proxy ctype -> NE.NonEmpty M.MediaType

127+ contentTypes = (NE.:| []) . contentType

128+

129+ {-# MINIMAL contentType | contentTypes #-}

122130

123131-- | @application/json@

124132instance Accept JSON where

@@ -219,9 +227,10 @@ instance AllMime '[] where

219227 allMime _ = []

220228

221229instance (Accept ctyp, AllMime ctyps) => AllMime (ctyp ': ctyps) where

222− allMime _ = (contentType pctyp):allMime pctyps

223− where pctyp = Proxy :: Proxy ctyp

224− pctyps = Proxy :: Proxy ctyps

230+ allMime _ = NE.toList (contentTypes pctyp) ++ allMime pctyps

231+ where

232+ pctyp = Proxy :: Proxy ctyp

233+ pctyps = Proxy :: Proxy ctyps

225234

226235canHandleAcceptH :: AllMime list => Proxy list -> AcceptHeader -> Bool

227236canHandleAcceptH p (AcceptHeader h ) = isJust $ M.matchAccept (allMime p) h

@@ -235,25 +244,31 @@ class (AllMime list) => AllMimeRender (list :: [*]) a where

235244 -> [(M.MediaType, ByteString)] -- content-types/response pairs

236245

237246instance OVERLAPPABLE_ ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where

238− allMimeRender _ a = [(contentType pctyp, mimeRender pctyp a)]

239− where pctyp = Proxy :: Proxy ctyp

247+ allMimeRender _ a = map (, bs) $ NE.toList $ contentTypes pctyp

248+ where

249+ bs = mimeRender pctyp a

250+ pctyp = Proxy :: Proxy ctyp

240251

241252instance OVERLAPPABLE_

242253 ( MimeRender ctyp a

243254 , AllMimeRender (ctyp' ': ctyps) a

244255 ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where

245− allMimeRender _ a = (contentType pctyp, mimeRender pctyp a)

246− :(allMimeRender pctyps a)

247− where pctyp = Proxy :: Proxy ctyp

248− pctyps = Proxy :: Proxy (ctyp' ': ctyps)

256+ allMimeRender _ a =

257+ (map (, bs) $ NE.toList $ contentTypes pctyp)

258+ ++ allMimeRender pctyps a

259+ where

260+ bs = mimeRender pctyp a

261+ pctyp = Proxy :: Proxy ctyp

262+ pctyps = Proxy :: Proxy (ctyp' ': ctyps)

249263

250264

251265-- Ideally we would like to declare a 'MimeRender a NoContent' instance, and

252266-- then this would be taken care of. However there is no more specific instance

253267-- between that and 'MimeRender JSON a', so we do this instead

254268instance OVERLAPPING_ ( Accept ctyp ) => AllMimeRender '[ctyp] NoContent where

255− allMimeRender _ _ = [(contentType pctyp, "")]

256− where pctyp = Proxy :: Proxy ctyp

269+ allMimeRender _ _ = map (, "") $ NE.toList $ contentTypes pctyp

270+ where

271+ pctyp = Proxy :: Proxy ctyp

257272

258273instance OVERLAPPING_

259274 ( AllMime (ctyp ': ctyp' ': ctyps)

@@ -274,10 +289,13 @@ instance AllMimeUnrender '[] a where

274289instance ( MimeUnrender ctyp a

275290 , AllMimeUnrender ctyps a

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

277− allMimeUnrender _ val = (contentType pctyp, mimeUnrender pctyp val)

278− :(allMimeUnrender pctyps val)

279− where pctyp = Proxy :: Proxy ctyp

280− pctyps = Proxy :: Proxy ctyps

292+ allMimeUnrender _ bs =

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

294+ ++ allMimeUnrender pctyps bs

295+ where

296+ x = mimeUnrender pctyp bs

297+ pctyp = Proxy :: Proxy ctyp

298+ pctyps = Proxy :: Proxy ctyps

281299

282300--------------------------------------------------------------------------

283301-- * MimeRender Instances

servant/test/Servant/API/ContentTypesSpec.hs+33

@@ -14,9 +14,11 @@ import Prelude.Compat

1414import Data.Aeson

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

1616import qualified Data.ByteString.Lazy as BSL

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

1718import Data.Either

1819import Data.Function (on)

1920import Data.List (maximumBy)

21+import qualified Data.List.NonEmpty as NE

2022import Data.Maybe (fromJust, isJust, isNothing)

2123import Data.Proxy

2224import Data.String (IsString (..))

@@ -24,8 +26,10 @@ import Data.String.Conversions (cs)

2426import qualified Data.Text as TextS

2527import qualified Data.Text.Lazy as TextL

2628import GHC.Generics

29+import qualified Network.HTTP.Media as M

2730import Test.Hspec

2831import Test.QuickCheck

32+import Text.Read (readMaybe)

2933import "quickcheck-instances" Test.QuickCheck.Instances ()

3034

3135import Servant.API.ContentTypes

@@ -101,6 +105,14 @@ spec = describe "Servant.API.ContentTypes" $ do

101105 "application/octet-stream" ("content" :: ByteString)

102106 `shouldSatisfy` isJust

103107

108+ it "returns Just if the 'Accept' header matches, with multiple mime types" $ do

109+ handleAcceptH (Proxy :: Proxy '[JSONorText]) "application/json" (3 :: Int)

110+ `shouldSatisfy` isJust

111+ handleAcceptH (Proxy :: Proxy '[JSONorText]) "text/plain" (3 :: Int)

112+ `shouldSatisfy` isJust

113+ handleAcceptH (Proxy :: Proxy '[JSONorText]) "image/jpeg" (3 :: Int)

114+ `shouldBe` Nothing

115+

104116 it "returns the Content-Type as the first element of the tuple" $ do

105117 handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (3 :: Int)

106118 `shouldSatisfy` ((== "application/json") . fst . fromJust)

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

158170 (encode val)

159171 `shouldBe` Just (Right val)

160172

173+ it "returns Just (Right val) if the decoding succeeds for either of multiple mime-types" $ do

174+ let val = 42 :: Int

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

176+ "42" `shouldBe` Just (Right val)

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

178+ "42" `shouldBe` Just (Right val)

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

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

181+

161182#if MIN_VERSION_aeson(0,9,0)

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

163184 describe "eitherDecodeLenient" $ do

@@ -201,6 +222,18 @@ instance ToJSON ByteString where

201222instance IsString AcceptHeader where

202223 fromString = AcceptHeader . fromString

203224

225+-- To test multiple content types

226+data JSONorText

227+

228+instance Accept JSONorText where

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

230+

231+instance MimeRender JSONorText Int where

232+ mimeRender _ = cs . show

233+

234+instance MimeUnrender JSONorText Int where

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

236+

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

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

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