e8ba670 · typeable/servant

git.iko.soy/typeable/servant

on master help sign in

Merge pull request #614 from phadej/accept-multiple

e8ba670Alp Mestanogullari10 years ago

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

compare with master

unifiedsplit

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

407 clientWithRoute (Proxy :: Proxy api)

408 (let ctProxy = Proxy :: Proxy ct

409 in setRQBody (mimeRender ctProxy body)

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

410 (contentType ctProxy)

411 (contentType ctProxy)

411 req

412 req

412 )

413 )

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

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

13import Control.Exception

14import Control.Monad

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

16+import Data.Foldable (toList)

17#if MIN_VERSION_mtl(2,2,0)

18#if MIN_VERSION_mtl(2,2,0)

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

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

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

25import GHC.Generics

26import GHC.Generics

26import Control.Monad.IO.Class ()

27import Control.Monad.IO.Class ()

27import Control.Monad.Reader

28import 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)

29import Data.String

30import Data.String

30import Data.String.Conversions

31import Data.String.Conversions

31import Data.Proxy

32import Data.Proxy

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

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

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

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

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

217performRequestCT ct reqMethod req = do

218performRequestCT ct reqMethod req = do

218− let acceptCT = contentType ct

219+ let acceptCTS = contentTypes ct

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

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

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

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

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

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

222 case mimeUnrender ct respBody of

223 case mimeUnrender ct respBody of

223 Left err -> throwError $ DecodeFailure err respCT respBody

224 Left err -> throwError $ DecodeFailure err respCT respBody

224 Right val -> return (hdrs, val)

225 Right val -> return (hdrs, val)

servant/servant.cabal+10

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

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

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

67 , vault >= 0.3 && < 0.4

68+

69+ if !impl(ghc >= 8.0)

70+ build-depends:

71+ semigroups >= 0.16 && < 0.19

72+

68 hs-source-dirs: src

73 hs-source-dirs: src

69 default-language: Haskell2010

74 default-language: Haskell2010

70 other-extensions: CPP

75 other-extensions: CPP

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

109 , attoparsec

114 , attoparsec

110 , bytestring

115 , bytestring

111 , hspec == 2.*

116 , hspec == 2.*

117+ , http-media

112 , QuickCheck

118 , QuickCheck

113 , quickcheck-instances

119 , quickcheck-instances

114 , servant

120 , servant

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

116 , text

122 , text

117 , url

123 , url

118

124

125+ if !impl(ghc >= 8.0)

126+ build-depends:

127+ semigroups >= 0.16 && < 0.19

128+

119test-suite doctests

129test-suite doctests

120 build-depends: base

130 build-depends: base

121 , servant

131 , servant

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

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

8{-# LANGUAGE OverloadedStrings #-}

9{-# LANGUAGE PolyKinds #-}

10{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE TupleSections #-}

11{-# LANGUAGE TypeFamilies #-}

12{-# LANGUAGE TypeFamilies #-}

12{-# LANGUAGE TypeOperators #-}

13{-# LANGUAGE TypeOperators #-}

13{-# LANGUAGE UndecidableInstances #-}

14{-# LANGUAGE UndecidableInstances #-}

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

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

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

82 toStrict)

83 toStrict)

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

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

85+import qualified Data.List.NonEmpty as NE

84import Data.Maybe (isJust)

86import Data.Maybe (isJust)

85import Data.String.Conversions (cs)

87import Data.String.Conversions (cs)

86import qualified Data.Text as TextS

88import qualified Data.Text as TextS

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

119--

121--

120class Accept ctype where

122class Accept ctype where

121 contentType :: Proxy ctype -> M.MediaType

123 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 #-}

122

130

123-- | @application/json@

131-- | @application/json@

124instance Accept JSON where

132instance Accept JSON where

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

219 allMime _ = []

227 allMime _ = []

220

228

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

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

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

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

231+ where

223− where pctyp = Proxy :: Proxy ctyp

232+ pctyp = Proxy :: Proxy ctyp

224− pctyps = Proxy :: Proxy ctyps

233+ pctyps = Proxy :: Proxy ctyps

225

234

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

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

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

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

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

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

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

236

245

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

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

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

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

248+ where

249+ bs = mimeRender pctyp a

239− where pctyp = Proxy :: Proxy ctyp

250+ pctyp = Proxy :: Proxy ctyp

240

251

241instance OVERLAPPABLE_

252instance OVERLAPPABLE_

242 ( MimeRender ctyp a

253 ( MimeRender ctyp a

243 , AllMimeRender (ctyp' ': ctyps) a

254 , AllMimeRender (ctyp' ': ctyps) a

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

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

256+ allMimeRender _ a =

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

258+ ++ allMimeRender pctyps a

259+ where

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

260+ bs = mimeRender pctyp a

246− :(allMimeRender pctyps a)

247− where pctyp = Proxy :: Proxy ctyp

261+ pctyp = Proxy :: Proxy ctyp

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

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

249

263

250

264

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

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

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

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

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

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

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

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

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

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

270+ where

256− where pctyp = Proxy :: Proxy ctyp

271+ pctyp = Proxy :: Proxy ctyp

257

272

258instance OVERLAPPING_

273instance OVERLAPPING_

259 ( AllMime (ctyp ': ctyp' ': ctyps)

274 ( AllMime (ctyp ': ctyp' ': ctyps)

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

274instance ( MimeUnrender ctyp a

289instance ( MimeUnrender ctyp a

275 , AllMimeUnrender ctyps a

290 , AllMimeUnrender ctyps a

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

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

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

292+ allMimeUnrender _ bs =

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

278− :(allMimeUnrender pctyps val)

294+ ++ allMimeUnrender pctyps bs

295+ where

296+ x = mimeUnrender pctyp bs

279− where pctyp = Proxy :: Proxy ctyp

297+ pctyp = Proxy :: Proxy ctyp

280− pctyps = Proxy :: Proxy ctyps

298+ pctyps = Proxy :: Proxy ctyps

281

299

282--------------------------------------------------------------------------

300--------------------------------------------------------------------------

283-- * MimeRender Instances

301-- * MimeRender Instances

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

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

14import Data.Aeson

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

16import qualified Data.ByteString.Lazy as BSL

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

17import Data.Either

18import Data.Either

18import Data.Function (on)

19import Data.Function (on)

19import Data.List (maximumBy)

20import Data.List (maximumBy)

21+import qualified Data.List.NonEmpty as NE

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

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

21import Data.Proxy

23import Data.Proxy

22import Data.String (IsString (..))

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

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

24import qualified Data.Text as TextS

26import qualified Data.Text as TextS

25import qualified Data.Text.Lazy as TextL

27import qualified Data.Text.Lazy as TextL

26import GHC.Generics

28import GHC.Generics

29+import qualified Network.HTTP.Media as M

27import Test.Hspec

30import Test.Hspec

28import Test.QuickCheck

31import Test.QuickCheck

32+import Text.Read (readMaybe)

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

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

31import Servant.API.ContentTypes

35import Servant.API.ContentTypes

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

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

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

102 `shouldSatisfy` isJust

106 `shouldSatisfy` isJust

103

107

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+

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

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

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

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

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

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

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

158 (encode val)

170 (encode val)

159 `shouldBe` Just (Right val)

171 `shouldBe` Just (Right val)

160

172

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+

161#if MIN_VERSION_aeson(0,9,0)

182#if MIN_VERSION_aeson(0,9,0)

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

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

163 describe "eitherDecodeLenient" $ do

184 describe "eitherDecodeLenient" $ do

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

201instance IsString AcceptHeader where

222instance IsString AcceptHeader where

202 fromString = AcceptHeader . fromString

223 fromString = AcceptHeader . fromString

203

224

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+

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

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

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

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

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

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