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

Allow multiple content-types for single Accept

Browse source
This commit is contained in:
Oleg Grenrus 2016-10-11 08:04:59 +03:00
parent 4fd31a60fb
commit bf66b2b1ff
2 changed files with 30 additions and 15 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
servant/servant.cabal
View file

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

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

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