Merge pull request #614 from phadej/accept-multiple

Allow multiple content-types for single Accept

servant-client/src/Servant/Client.hs

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

servant-client/src/Servant/Common/Req.hs

@@ -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] })
+    performRequest reqMethod (req { reqAccept = toList acceptCTS })
-  unless (matches respCT (acceptCT)) $ throwError $ UnsupportedContentType respCT respBody
+  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)

servant/servant.cabal

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

servant/src/Servant/API/ContentTypes.hs

@@ -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,9 +227,10 @@ instance AllMime '[] where
     allMime _ = []
 
 instance (Accept ctyp, AllMime ctyps) => AllMime (ctyp ': ctyps) where
-    allMime _ = (contentType pctyp):allMime pctyps
+    allMime _ = NE.toList (contentTypes pctyp) ++ allMime pctyps
-      where pctyp  = Proxy :: Proxy ctyp
+      where
-            pctyps = Proxy :: Proxy ctyps
+        pctyp  = Proxy :: Proxy ctyp
+        pctyps = Proxy :: Proxy ctyps
 
 canHandleAcceptH :: AllMime list => Proxy list -> AcceptHeader -> Bool
 canHandleAcceptH p (AcceptHeader h ) = isJust $ M.matchAccept (allMime p) h
@@ -235,25 +244,31 @@ 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)]
+    allMimeRender _ a = map (, bs) $ NE.toList $ contentTypes pctyp
-        where pctyp = Proxy :: Proxy ctyp
+      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 _ a =
-                       :(allMimeRender pctyps a)
+        (map (, bs) $ NE.toList $ contentTypes pctyp)
-        where pctyp = Proxy :: Proxy ctyp
+        ++ allMimeRender pctyps a
-              pctyps = Proxy :: Proxy (ctyp' ': ctyps)
+      where
+        bs     = mimeRender pctyp a
+        pctyp  = Proxy :: Proxy ctyp
+        pctyps = Proxy :: Proxy (ctyp' ': ctyps)
 
 
 -- Ideally we would like to declare a 'MimeRender a NoContent' instance, and
 -- 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, "")]
+    allMimeRender _ _ = map (, "") $ NE.toList $ contentTypes pctyp
-      where pctyp = Proxy :: Proxy ctyp
+      where
+        pctyp = Proxy :: Proxy ctyp
 
 instance OVERLAPPING_
          ( AllMime (ctyp ': ctyp' ': ctyps)
@@ -274,10 +289,13 @@ instance AllMimeUnrender '[] a where
 instance ( MimeUnrender ctyp a
          , AllMimeUnrender ctyps a
          ) => AllMimeUnrender (ctyp ': ctyps) a where
-    allMimeUnrender _ val = (contentType pctyp, mimeUnrender pctyp val)
+    allMimeUnrender _ bs =
-                           :(allMimeUnrender pctyps val)
+        (map (, x) $ NE.toList $ contentTypes pctyp)
-        where pctyp = Proxy :: Proxy ctyp
+        ++ allMimeUnrender pctyps bs
-              pctyps = Proxy :: Proxy ctyps
+      where
+        x      = mimeUnrender pctyp bs
+        pctyp  = Proxy :: Proxy ctyp
+        pctyps = Proxy :: Proxy ctyps
 
 --------------------------------------------------------------------------
 -- * MimeRender Instances

servant/test/Servant/API/ContentTypesSpec.hs

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