Move more content-type logic from servant-server
This commit is contained in:
parent
d7e1f1230e
commit
a75c723226
2 changed files with 184 additions and 14 deletions
|
@ -46,6 +46,7 @@ library
|
||||||
build-depends:
|
build-depends:
|
||||||
base >=4.7 && <5
|
base >=4.7 && <5
|
||||||
, bytestring == 0.10.*
|
, bytestring == 0.10.*
|
||||||
|
, http-media >= 0.4 && < 0.5
|
||||||
, http-types == 0.8.*
|
, http-types == 0.8.*
|
||||||
, text >= 1 && < 2
|
, text >= 1 && < 2
|
||||||
, template-haskell >= 2.7 && < 2.10
|
, template-haskell >= 2.7 && < 2.10
|
||||||
|
@ -54,19 +55,19 @@ library
|
||||||
, network-uri >= 2.6
|
, network-uri >= 2.6
|
||||||
hs-source-dirs: src
|
hs-source-dirs: src
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
extensions: DataKinds
|
other-extensions: DataKinds
|
||||||
, DeriveDataTypeable
|
, DeriveDataTypeable
|
||||||
, FunctionalDependencies
|
, FunctionalDependencies
|
||||||
, KindSignatures
|
, KindSignatures
|
||||||
, MultiParamTypeClasses
|
, MultiParamTypeClasses
|
||||||
, PolyKinds
|
, PolyKinds
|
||||||
, QuasiQuotes
|
, QuasiQuotes
|
||||||
, ScopedTypeVariables
|
, ScopedTypeVariables
|
||||||
, TemplateHaskell
|
, TemplateHaskell
|
||||||
, TypeFamilies
|
, TypeFamilies
|
||||||
, TypeOperators
|
, TypeOperators
|
||||||
, UndecidableInstances
|
, UndecidableInstances
|
||||||
, FlexibleInstances
|
, FlexibleInstances
|
||||||
ghc-options: -Wall
|
ghc-options: -Wall
|
||||||
|
|
||||||
test-suite spec
|
test-suite spec
|
||||||
|
|
|
@ -1,9 +1,26 @@
|
||||||
{-# LANGUAGE DeriveDataTypeable #-}
|
{-# LANGUAGE DeriveDataTypeable #-}
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE ConstraintKinds #-}
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE PolyKinds #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
module Servant.API.ContentTypes where
|
module Servant.API.ContentTypes where
|
||||||
|
|
||||||
import Data.Typeable
|
import Data.Typeable
|
||||||
|
|
||||||
|
import Control.Monad (join)
|
||||||
|
import qualified Data.ByteString as BS
|
||||||
|
import Data.ByteString.Lazy (ByteString)
|
||||||
|
import Data.String.Conversions (cs)
|
||||||
|
import GHC.Exts (Constraint)
|
||||||
|
import qualified Network.HTTP.Media as M
|
||||||
|
|
||||||
|
-- * Provided content types
|
||||||
data XML deriving Typeable
|
data XML deriving Typeable
|
||||||
data HTML deriving Typeable
|
data HTML deriving Typeable
|
||||||
data JSON deriving Typeable
|
data JSON deriving Typeable
|
||||||
|
@ -11,3 +28,155 @@ data JavaScript deriving Typeable
|
||||||
data CSS deriving Typeable
|
data CSS deriving Typeable
|
||||||
data PlainText deriving Typeable
|
data PlainText deriving Typeable
|
||||||
data OctetStream deriving Typeable
|
data OctetStream deriving Typeable
|
||||||
|
|
||||||
|
-- * Accept class
|
||||||
|
|
||||||
|
-- | Instances of 'Accept' represent mimetypes. They are used for matching
|
||||||
|
-- against the @Accept@ HTTP header of the request, and for setting the
|
||||||
|
-- @Content-Type@ header of the response
|
||||||
|
--
|
||||||
|
-- Example:
|
||||||
|
--
|
||||||
|
-- > instance Accept HTML where
|
||||||
|
-- > contentType _ = "text" // "html"
|
||||||
|
--
|
||||||
|
class Accept ctype where
|
||||||
|
contentType :: Proxy ctype -> M.MediaType
|
||||||
|
|
||||||
|
-- | @text/html;charset=utf-8@
|
||||||
|
instance Accept HTML where
|
||||||
|
contentType _ = "text" M.// "html" M./: ("charset", "utf-8")
|
||||||
|
|
||||||
|
-- | @application/json;charset=utf-8@
|
||||||
|
instance Accept JSON where
|
||||||
|
contentType _ = "application" M.// "json" M./: ("charset", "utf-8")
|
||||||
|
|
||||||
|
-- | @application/xml;charset=utf-8@
|
||||||
|
instance Accept XML where
|
||||||
|
contentType _ = "application" M.// "xml" M./: ("charset", "utf-8")
|
||||||
|
|
||||||
|
-- | @application/javascript;charset=utf-8@
|
||||||
|
instance Accept JavaScript where
|
||||||
|
contentType _ = "application" M.// "javascript" M./: ("charset", "utf-8")
|
||||||
|
|
||||||
|
-- | @text/css;charset=utf-8@
|
||||||
|
instance Accept CSS where
|
||||||
|
contentType _ = "text" M.// "css" M./: ("charset", "utf-8")
|
||||||
|
|
||||||
|
-- | @text/plain;charset=utf-8@
|
||||||
|
instance Accept PlainText where
|
||||||
|
contentType _ = "text" M.// "plain" M./: ("charset", "utf-8")
|
||||||
|
|
||||||
|
-- | @application/octet-stream@
|
||||||
|
instance Accept OctetStream where
|
||||||
|
contentType _ = "application" M.// "octet-stream"
|
||||||
|
|
||||||
|
newtype AcceptHeader = AcceptHeader BS.ByteString
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
-- * Render (serializing)
|
||||||
|
|
||||||
|
-- | Instantiate this class to register a way of serializing a type based
|
||||||
|
-- on the @Accept@ header.
|
||||||
|
--
|
||||||
|
-- Example:
|
||||||
|
--
|
||||||
|
-- > data MyContentType
|
||||||
|
-- >
|
||||||
|
-- > instance Accept MyContentType where
|
||||||
|
-- > contentType _ = "example" // "prs.me.mine" /: ("charset", "utf-8")
|
||||||
|
-- >
|
||||||
|
-- > instance Show a => MimeRender MyContentType where
|
||||||
|
-- > toByteString _ val = pack ("This is MINE! " ++ show val)
|
||||||
|
-- >
|
||||||
|
-- > type MyAPI = "path" :> Get '[MyContentType] Int
|
||||||
|
class Accept ctype => MimeRender ctype a where
|
||||||
|
toByteString :: Proxy ctype -> a -> ByteString
|
||||||
|
|
||||||
|
class AllCTRender list a where
|
||||||
|
-- If the Accept header can be matched, returns (Just) a tuple of the
|
||||||
|
-- Content-Type and response (serialization of @a@ into the appropriate
|
||||||
|
-- mimetype).
|
||||||
|
handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
|
||||||
|
|
||||||
|
instance ( AllMimeRender ctyps a, IsNonEmpty ctyps
|
||||||
|
) => AllCTRender ctyps a where
|
||||||
|
handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept
|
||||||
|
where pctyps = Proxy :: Proxy ctyps
|
||||||
|
amrs = amr pctyps val
|
||||||
|
lkup = zip (map fst amrs) $ map (\(a,b) -> (cs $ show a, b)) amrs
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------
|
||||||
|
-- * Unrender
|
||||||
|
class Accept ctype => MimeUnrender ctype a where
|
||||||
|
fromByteString :: Proxy ctype -> ByteString -> Maybe a
|
||||||
|
|
||||||
|
class AllCTUnrender list a where
|
||||||
|
handleCTypeH :: Proxy list
|
||||||
|
-> ByteString -- Content-Type header
|
||||||
|
-> ByteString -- Request body
|
||||||
|
-> Maybe a
|
||||||
|
|
||||||
|
instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps
|
||||||
|
) => AllCTUnrender ctyps a where
|
||||||
|
handleCTypeH _ ctypeH body = join $ M.mapContentMedia lkup (cs ctypeH)
|
||||||
|
where lkup = amu (Proxy :: Proxy ctyps) body
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------
|
||||||
|
-- * Utils (Internal)
|
||||||
|
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------
|
||||||
|
-- Check that all elements of list are instances of MimeRender
|
||||||
|
--------------------------------------------------------------------------
|
||||||
|
class AllMimeRender ls a where
|
||||||
|
amr :: Proxy ls
|
||||||
|
-> a -- value to serialize
|
||||||
|
-> [(M.MediaType, ByteString)] -- content-types/response pairs
|
||||||
|
|
||||||
|
instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where
|
||||||
|
amr _ a = [(contentType pctyp, toByteString pctyp a)]
|
||||||
|
where pctyp = Proxy :: Proxy ctyp
|
||||||
|
|
||||||
|
instance ( MimeRender ctyp a
|
||||||
|
, MimeRender ctyp' a -- at least two elems to avoid overlap
|
||||||
|
, AllMimeRender ctyps a
|
||||||
|
) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where
|
||||||
|
amr _ a = (contentType pctyp, toByteString pctyp a)
|
||||||
|
:(contentType pctyp', toByteString pctyp' a)
|
||||||
|
:(amr pctyps a)
|
||||||
|
where pctyp = Proxy :: Proxy ctyp
|
||||||
|
pctyps = Proxy :: Proxy ctyps
|
||||||
|
pctyp' = Proxy :: Proxy ctyp'
|
||||||
|
|
||||||
|
|
||||||
|
instance AllMimeRender '[] a where
|
||||||
|
amr _ _ = []
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------
|
||||||
|
-- Check that all elements of list are instances of MimeUnrender
|
||||||
|
--------------------------------------------------------------------------
|
||||||
|
class AllMimeUnrender ls a where
|
||||||
|
amu :: Proxy ls -> ByteString -> [(M.MediaType, Maybe a)]
|
||||||
|
|
||||||
|
instance ( MimeUnrender ctyp a ) => AllMimeUnrender '[ctyp] a where
|
||||||
|
amu _ val = [(contentType pctyp, fromByteString pctyp val)]
|
||||||
|
where pctyp = Proxy :: Proxy ctyp
|
||||||
|
|
||||||
|
instance ( MimeUnrender ctyp a
|
||||||
|
, MimeUnrender ctyp' a
|
||||||
|
, AllMimeUnrender ctyps a
|
||||||
|
) => AllMimeUnrender (ctyp ': ctyp' ': ctyps) a where
|
||||||
|
amu _ val = (contentType pctyp, fromByteString pctyp val)
|
||||||
|
:(contentType pctyp', fromByteString pctyp' val)
|
||||||
|
:(amu pctyps val)
|
||||||
|
where pctyp = Proxy :: Proxy ctyp
|
||||||
|
pctyps = Proxy :: Proxy ctyps
|
||||||
|
pctyp' = Proxy :: Proxy ctyp'
|
||||||
|
|
||||||
|
type family IsNonEmpty (ls::[*]) :: Constraint where
|
||||||
|
IsNonEmpty '[] = 'False ~ 'True
|
||||||
|
IsNonEmpty x = ()
|
||||||
|
|
Loading…
Reference in a new issue