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 , http-types >= 0.8 && < 0.10
, mtl >= 2.0 && < 2.3 , mtl >= 2.0 && < 2.3
, mmorph >= 1 && < 1.1 , mmorph >= 1 && < 1.1
, semigroups >= 0.16 && < 0.19
, text >= 1 && < 1.3 , text >= 1 && < 1.3
, string-conversions >= 0.3 && < 0.5 , string-conversions >= 0.3 && < 0.5
, network-uri >= 2.6 && < 2.7 , 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, import Data.ByteString.Lazy (ByteString, fromStrict,
toStrict) toStrict)
import qualified Data.ByteString.Lazy.Char8 as BC import qualified Data.ByteString.Lazy.Char8 as BC
import qualified Data.List.NonEmpty as NE
import Data.Maybe (isJust) import Data.Maybe (isJust)
import Data.String.Conversions (cs) import Data.String.Conversions (cs)
import qualified Data.Text as TextS import qualified Data.Text as TextS
@ -120,6 +121,9 @@ data OctetStream deriving Typeable
class Accept ctype where class Accept ctype where
contentType :: Proxy ctype -> M.MediaType contentType :: Proxy ctype -> M.MediaType
contentTypes :: Proxy ctype -> NE.NonEmpty M.MediaType
contentTypes = (NE.:| []) . contentType
-- | @application/json@ -- | @application/json@
instance Accept JSON where instance Accept JSON where
contentType _ = "application" M.// "json" contentType _ = "application" M.// "json"
@ -219,9 +223,10 @@ instance AllMime '[] where
allMime _ = [] allMime _ = []
instance (Accept ctyp, AllMime ctyps) => AllMime (ctyp ': ctyps) where 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 :: AllMime list => Proxy list -> AcceptHeader -> Bool
canHandleAcceptH p (AcceptHeader h ) = isJust $ M.matchAccept (allMime p) h 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 -> [(M.MediaType, ByteString)] -- content-types/response pairs
instance OVERLAPPABLE_ ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where instance OVERLAPPABLE_ ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where
allMimeRender _ a = [(contentType pctyp, mimeRender pctyp a)] allMimeRender _ a = [ (ct, bs) | ct <- NE.toList $ contentTypes pctyp ]
where pctyp = Proxy :: Proxy ctyp where
bs = mimeRender pctyp a
pctyp = Proxy :: Proxy ctyp
instance OVERLAPPABLE_ instance OVERLAPPABLE_
( MimeRender ctyp a ( MimeRender ctyp a
, AllMimeRender (ctyp' ': ctyps) a , AllMimeRender (ctyp' ': ctyps) a
) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where
allMimeRender _ a = (contentType pctyp, mimeRender pctyp a) allMimeRender _ a =
:(allMimeRender pctyps a) [ (ct, bs) | ct <- 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 -- 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 -- 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 -- between that and 'MimeRender JSON a', so we do this instead
instance OVERLAPPING_ ( Accept ctyp ) => AllMimeRender '[ctyp] NoContent where instance OVERLAPPING_ ( Accept ctyp ) => AllMimeRender '[ctyp] NoContent where
allMimeRender _ _ = [(contentType pctyp, "")] allMimeRender _ _ = [ (ct, "") | ct <- NE.toList $ contentTypes pctyp ]
where pctyp = Proxy :: Proxy ctyp where
pctyp = Proxy :: Proxy ctyp
instance OVERLAPPING_ instance OVERLAPPING_
( AllMime (ctyp ': ctyp' ': ctyps) ( AllMime (ctyp ': ctyp' ': ctyps)
@ -274,10 +285,13 @@ instance AllMimeUnrender '[] a where
instance ( MimeUnrender ctyp a instance ( MimeUnrender ctyp a
, AllMimeUnrender ctyps a , AllMimeUnrender ctyps a
) => AllMimeUnrender (ctyp ': ctyps) a where ) => AllMimeUnrender (ctyp ': ctyps) a where
allMimeUnrender _ val = (contentType pctyp, mimeUnrender pctyp val) allMimeUnrender _ bs =
:(allMimeUnrender pctyps val) [ (ct, x) | ct <- 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 -- * MimeRender Instances