From bf66b2b1ff7ee2a96feeb19caa6fa5ee065e1b82 Mon Sep 17 00:00:00 2001
From: Oleg Grenrus <oleg.grenrus@iki.fi>
Date: Tue, 11 Oct 2016 08:04:59 +0300
Subject: [PATCH] Allow multiple content-types for single Accept

---
 servant/servant.cabal                   |  1 +
 servant/src/Servant/API/ContentTypes.hs | 44 ++++++++++++++++---------
 2 files changed, 30 insertions(+), 15 deletions(-)

diff --git a/servant/servant.cabal b/servant/servant.cabal
index 02d366ea..8b2afc00 100644
--- a/servant/servant.cabal
+++ b/servant/servant.cabal
@@ -60,6 +60,7 @@ library
     , http-types            >= 0.8  && < 0.10
     , mtl                   >= 2.0  && < 2.3
     , mmorph                >= 1    && < 1.1
+    , semigroups            >= 0.16 && < 0.19
     , text                  >= 1    && < 1.3
     , string-conversions    >= 0.3  && < 0.5
     , network-uri           >= 2.6  && < 2.7
diff --git a/servant/src/Servant/API/ContentTypes.hs b/servant/src/Servant/API/ContentTypes.hs
index 044f1c59..69be4813 100644
--- a/servant/src/Servant/API/ContentTypes.hs
+++ b/servant/src/Servant/API/ContentTypes.hs
@@ -81,6 +81,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
@@ -120,6 +121,9 @@ data OctetStream deriving Typeable
 class Accept ctype where
     contentType   :: Proxy ctype -> M.MediaType
 
+    contentTypes  :: Proxy ctype -> NE.NonEmpty M.MediaType
+    contentTypes  =  (NE.:| []) . contentType
+
 -- | @application/json@
 instance Accept JSON where
     contentType _ = "application" M.// "json"
@@ -219,9 +223,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 +240,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 = [ (ct, bs) | ct <- 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 =
+        [ (ct, bs) | ct <- 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 _ _ = [ (ct, "") | ct <- NE.toList $ contentTypes pctyp ]
+      where
+        pctyp = Proxy :: Proxy ctyp
 
 instance OVERLAPPING_
          ( AllMime (ctyp ': ctyp' ': ctyps)
@@ -274,10 +285,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 =
+        [ (ct, x) | ct <- NE.toList $ contentTypes pctyp ]
+        ++ allMimeUnrender pctyps bs
+      where
+        x      = mimeUnrender pctyp bs
+        pctyp  = Proxy :: Proxy ctyp
+        pctyps = Proxy :: Proxy ctyps
 
 --------------------------------------------------------------------------
 -- * MimeRender Instances