eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Merge pull request #614 from phadej/accept-multiple

Browse source 
Allow multiple content-types for single Accept
This commit is contained in:
Alp Mestanogullari 2017-01-01 11:31:00 +01:00 committed by GitHub
commit e8ba67048a
5 changed files with 82 additions and 19 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
servant-client/src/Servant/Client.hs
View file

@ -407,6 +407,7 @@ instance (MimeRender ct a, HasClient api)
clientWithRoute (Proxy :: Proxy api)
(let ctProxy = Proxy :: Proxy ct
in setRQBody (mimeRender ctProxy body)
-- We use first contentType from the Accept list
(contentType ctProxy)
req
)

9
servant-client/src/Servant/Common/Req.hs
View file

@ -13,6 +13,7 @@ import Prelude.Compat
import Control.Exception
import Control.Monad
import Control.Monad.Catch (MonadThrow, MonadCatch)
import Data.Foldable (toList)
#if MIN_VERSION_mtl(2,2,0)
import Control.Monad.Except (MonadError(..))
@ -25,7 +26,7 @@ import Control.Monad.Trans.Except
import GHC.Generics
import Control.Monad.IO.Class ()
import Control.Monad.Reader
import Data.ByteString.Lazy hiding (pack, filter, map, null, elem)
import Data.ByteString.Lazy hiding (pack, filter, map, null, elem, any)
import Data.String
import Data.String.Conversions
import Data.Proxy
@ -215,10 +216,10 @@ performRequest reqMethod req = do
performRequestCT :: MimeUnrender ct result => Proxy ct -> Method -> Req
-> ClientM ([HTTP.Header], result)
performRequestCT ct reqMethod req = do
let acceptCT = contentType ct
let acceptCTS = contentTypes ct
(_status, respBody, respCT, hdrs, _response) <-
performRequest reqMethod (req { reqAccept = [acceptCT] })
unless (matches respCT (acceptCT)) $ throwError $ UnsupportedContentType respCT respBody
performRequest reqMethod (req { reqAccept = toList acceptCTS })
unless (any (matches respCT) acceptCTS) $ throwError $ UnsupportedContentType respCT respBody
case mimeUnrender ct respBody of
Left err -> throwError $ DecodeFailure err respCT respBody
Right val -> return (hdrs, val)

10
servant/servant.cabal
View file

@ -65,6 +65,11 @@ library
, string-conversions >= 0.3 && < 0.5
, network-uri >= 2.6 && < 2.7
, vault >= 0.3 && < 0.4
if !impl(ghc >= 8.0)
build-depends:
semigroups >= 0.16 && < 0.19
hs-source-dirs: src
default-language: Haskell2010
other-extensions: CPP
@ -109,6 +114,7 @@ test-suite spec
, attoparsec
, bytestring
, hspec == 2.*
, http-media
, QuickCheck
, quickcheck-instances
, servant
@ -116,6 +122,10 @@ test-suite spec
, text
, url
if !impl(ghc >= 8.0)
build-depends:
semigroups >= 0.16 && < 0.19
test-suite doctests
build-depends: base
, servant

42
servant/src/Servant/API/ContentTypes.hs
View file

@ -8,6 +8,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
@ -81,6 +82,7 @@ import qualified Data.ByteString as BS
import Data.ByteString.Lazy (ByteString, fromStrict,
toStrict)
import qualified Data.ByteString.Lazy.Char8 as BC
import qualified Data.List.NonEmpty as NE
import Data.Maybe (isJust)
import Data.String.Conversions (cs)
import qualified Data.Text as TextS
@ -119,6 +121,12 @@ data OctetStream deriving Typeable
--
class Accept ctype where
contentType :: Proxy ctype -> M.MediaType
contentType = NE.head . contentTypes
contentTypes :: Proxy ctype -> NE.NonEmpty M.MediaType
contentTypes = (NE.:| []) . contentType
{-# MINIMAL contentType | contentTypes #-}
-- | @application/json@
instance Accept JSON where
@ -219,8 +227,9 @@ instance AllMime '[] where
allMime _ = []
instance (Accept ctyp, AllMime ctyps) => AllMime (ctyp ': ctyps) where
allMime _ = (contentType pctyp):allMime pctyps
where pctyp = Proxy :: Proxy ctyp
allMime _ = NE.toList (contentTypes pctyp) ++ allMime pctyps
where
pctyp = Proxy :: Proxy ctyp
pctyps = Proxy :: Proxy ctyps
canHandleAcceptH :: AllMime list => Proxy list -> AcceptHeader -> Bool
@ -235,16 +244,21 @@ class (AllMime list) => AllMimeRender (list :: [*]) a where
-> [(M.MediaType, ByteString)] -- content-types/response pairs
instance OVERLAPPABLE_ ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where
allMimeRender _ a = [(contentType pctyp, mimeRender pctyp a)]
where pctyp = Proxy :: Proxy ctyp
allMimeRender _ a = map (, bs) $ NE.toList $ contentTypes pctyp
where
bs = mimeRender pctyp a
pctyp = Proxy :: Proxy ctyp
instance OVERLAPPABLE_
( MimeRender ctyp a
, AllMimeRender (ctyp' ': ctyps) a
) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where
allMimeRender _ a = (contentType pctyp, mimeRender pctyp a)
:(allMimeRender pctyps a)
where pctyp = Proxy :: Proxy ctyp
allMimeRender _ a =
(map (, bs) $ NE.toList $ contentTypes pctyp)
++ allMimeRender pctyps a
where
bs = mimeRender pctyp a
pctyp = Proxy :: Proxy ctyp
pctyps = Proxy :: Proxy (ctyp' ': ctyps)
@ -252,8 +266,9 @@ instance OVERLAPPABLE_
-- then this would be taken care of. However there is no more specific instance
-- between that and 'MimeRender JSON a', so we do this instead
instance OVERLAPPING_ ( Accept ctyp ) => AllMimeRender '[ctyp] NoContent where
allMimeRender _ _ = [(contentType pctyp, "")]
where pctyp = Proxy :: Proxy ctyp
allMimeRender _ _ = map (, "") $ NE.toList $ contentTypes pctyp
where
pctyp = Proxy :: Proxy ctyp
instance OVERLAPPING_
( AllMime (ctyp ': ctyp' ': ctyps)
@ -274,9 +289,12 @@ instance AllMimeUnrender '[] a where
instance ( MimeUnrender ctyp a
, AllMimeUnrender ctyps a
) => AllMimeUnrender (ctyp ': ctyps) a where
allMimeUnrender _ val = (contentType pctyp, mimeUnrender pctyp val)
:(allMimeUnrender pctyps val)
where pctyp = Proxy :: Proxy ctyp
allMimeUnrender _ bs =
(map (, x) $ NE.toList $ contentTypes pctyp)
++ allMimeUnrender pctyps bs
where
x = mimeUnrender pctyp bs
pctyp = Proxy :: Proxy ctyp
pctyps = Proxy :: Proxy ctyps
--------------------------------------------------------------------------

33
servant/test/Servant/API/ContentTypesSpec.hs
View file

@ -14,9 +14,11 @@ import Prelude.Compat
import Data.Aeson
import Data.ByteString.Char8 (ByteString, append, pack)
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Lazy.Char8 as BSL8
import Data.Either
import Data.Function (on)
import Data.List (maximumBy)
import qualified Data.List.NonEmpty as NE
import Data.Maybe (fromJust, isJust, isNothing)
import Data.Proxy
import Data.String (IsString (..))
@ -24,8 +26,10 @@ import Data.String.Conversions (cs)
import qualified Data.Text as TextS
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)
import "quickcheck-instances" Test.QuickCheck.Instances ()
import Servant.API.ContentTypes
@ -101,6 +105,14 @@ spec = describe "Servant.API.ContentTypes" $ do
"application/octet-stream" ("content" :: ByteString)
`shouldSatisfy` isJust
it "returns Just if the 'Accept' header matches, with multiple mime types" $ do
handleAcceptH (Proxy :: Proxy '[JSONorText]) "application/json" (3 :: Int)
`shouldSatisfy` isJust
handleAcceptH (Proxy :: Proxy '[JSONorText]) "text/plain" (3 :: Int)
`shouldSatisfy` isJust
handleAcceptH (Proxy :: Proxy '[JSONorText]) "image/jpeg" (3 :: Int)
`shouldBe` Nothing
it "returns the Content-Type as the first element of the tuple" $ do
handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (3 :: Int)
`shouldSatisfy` ((== "application/json") . fst . fromJust)
@ -158,6 +170,15 @@ spec = describe "Servant.API.ContentTypes" $ do
(encode val)
`shouldBe` Just (Right val)
it "returns Just (Right val) if the decoding succeeds for either of multiple mime-types" $ do
let val = 42 :: Int
handleCTypeH (Proxy :: Proxy '[JSONorText]) "application/json"
"42" `shouldBe` Just (Right val)
handleCTypeH (Proxy :: Proxy '[JSONorText]) "text/plain"
"42" `shouldBe` Just (Right val)
handleCTypeH (Proxy :: Proxy '[JSONorText]) "image/jpeg"
"42" `shouldBe` (Nothing :: Maybe (Either String Int))
#if MIN_VERSION_aeson(0,9,0)
-- aeson >= 0.9 decodes top-level strings
describe "eitherDecodeLenient" $ do
@ -201,6 +222,18 @@ instance ToJSON ByteString where
instance IsString AcceptHeader where
fromString = AcceptHeader . fromString
-- To test multiple content types
data JSONorText
instance Accept JSONorText where
contentTypes _ = "text" M.// "plain" NE.:| [ "application" M.// "json" ]
instance MimeRender JSONorText Int where
mimeRender _ = cs . show
instance MimeUnrender JSONorText Int where
mimeUnrender _ = maybe (Left "") Right . readMaybe . BSL8.unpack
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)