Merge pull request #614 from phadej/accept-multiple

Allow multiple content-types for single Accept

Author: alpmestan

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] })
-  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)

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,13 +114,18 @@ test-suite spec
     , attoparsec
     , bytestring
     , hspec == 2.*
+    , http-media
     , QuickCheck
     , quickcheck-instances
     , servant
     , string-conversions
     , 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
-      where pctyp  = Proxy :: Proxy ctyp
-            pctyps = Proxy :: Proxy ctyps
+    allMime _ = NE.toList (contentTypes pctyp) ++ allMime pctyps
+      where
+        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)]
-        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
-              pctyps = Proxy :: Proxy (ctyp' ': ctyps)
+    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)
 
 
 -- 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, "")]
-      where pctyp = Proxy :: Proxy ctyp
+    allMimeRender _ _ = map (, "") $ NE.toList $ contentTypes pctyp
+      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 pctyps val)
-        where pctyp = Proxy :: Proxy ctyp
-              pctyps = Proxy :: Proxy ctyps
+    allMimeUnrender _ bs =
+        (map (, x) $ NE.toList $ contentTypes pctyp)
+        ++ allMimeUnrender pctyps bs
+      where
+        x      = mimeUnrender pctyp bs
+        pctyp  = Proxy :: Proxy ctyp
+        pctyps = Proxy :: Proxy ctyps
 
 --------------------------------------------------------------------------
 -- * MimeRender Instances

servant/test/Servant/API/ContentTypesSpec.hs

@@ -14,18 +14,22 @@ 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 (..))
 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)