2015-01-08 16:24:19 +01:00
|
|
|
{-# LANGUAGE DeriveDataTypeable #-}
|
2015-02-18 10:00:34 +01:00
|
|
|
{-# LANGUAGE DataKinds #-}
|
|
|
|
{-# LANGUAGE ConstraintKinds #-}
|
|
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
{-# LANGUAGE PolyKinds #-}
|
|
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
|
|
{-# LANGUAGE TypeOperators #-}
|
|
|
|
{-# LANGUAGE UndecidableInstances #-}
|
2015-01-08 16:24:19 +01:00
|
|
|
module Servant.API.ContentTypes where
|
|
|
|
|
2015-02-18 10:00:34 +01:00
|
|
|
import qualified Data.ByteString as BS
|
|
|
|
import Data.ByteString.Lazy (ByteString)
|
|
|
|
import Data.String.Conversions (cs)
|
2015-02-18 11:24:56 +01:00
|
|
|
import Data.Typeable
|
2015-02-18 10:00:34 +01:00
|
|
|
import GHC.Exts (Constraint)
|
|
|
|
import qualified Network.HTTP.Media as M
|
2015-01-08 16:24:19 +01:00
|
|
|
|
2015-02-18 10:00:34 +01:00
|
|
|
-- * Provided content types
|
2015-01-08 16:24:19 +01:00
|
|
|
data XML deriving Typeable
|
|
|
|
data HTML deriving Typeable
|
|
|
|
data JSON deriving Typeable
|
2015-01-12 15:09:19 +01:00
|
|
|
data JavaScript deriving Typeable
|
|
|
|
data CSS deriving Typeable
|
|
|
|
data PlainText deriving Typeable
|
2015-01-13 20:38:34 +01:00
|
|
|
data OctetStream deriving Typeable
|
2015-02-18 10:00:34 +01:00
|
|
|
|
|
|
|
-- * 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
|
2015-02-19 10:29:19 +01:00
|
|
|
amrs = allMimeRender pctyps val
|
|
|
|
lkup = fmap (\(a,b) -> (a, (cs $ show a, b))) amrs
|
2015-02-18 10:00:34 +01:00
|
|
|
|
|
|
|
|
|
|
|
--------------------------------------------------------------------------
|
|
|
|
-- * Unrender
|
|
|
|
class Accept ctype => MimeUnrender ctype a where
|
2015-02-19 10:29:19 +01:00
|
|
|
fromByteString :: Proxy ctype -> ByteString -> Either String a
|
2015-02-18 10:00:34 +01:00
|
|
|
|
2015-02-19 19:18:08 +01:00
|
|
|
class (IsNonEmpty list) => AllCTUnrender list a where
|
2015-02-18 10:00:34 +01:00
|
|
|
handleCTypeH :: Proxy list
|
|
|
|
-> ByteString -- Content-Type header
|
|
|
|
-> ByteString -- Request body
|
2015-02-19 10:29:19 +01:00
|
|
|
-> Maybe (Either String a)
|
2015-02-18 10:00:34 +01:00
|
|
|
|
|
|
|
instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps
|
|
|
|
) => AllCTUnrender ctyps a where
|
2015-02-19 10:29:19 +01:00
|
|
|
handleCTypeH _ ctypeH body = M.mapContentMedia lkup (cs ctypeH)
|
|
|
|
where lkup = allMimeUnrender (Proxy :: Proxy ctyps) body
|
2015-02-18 10:00:34 +01:00
|
|
|
|
|
|
|
--------------------------------------------------------------------------
|
|
|
|
-- * Utils (Internal)
|
|
|
|
|
|
|
|
|
|
|
|
--------------------------------------------------------------------------
|
|
|
|
-- Check that all elements of list are instances of MimeRender
|
|
|
|
--------------------------------------------------------------------------
|
|
|
|
class AllMimeRender ls a where
|
2015-02-19 10:29:19 +01:00
|
|
|
allMimeRender :: Proxy ls
|
|
|
|
-> a -- value to serialize
|
|
|
|
-> [(M.MediaType, ByteString)] -- content-types/response pairs
|
2015-02-18 10:00:34 +01:00
|
|
|
|
|
|
|
instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where
|
2015-02-19 10:29:19 +01:00
|
|
|
allMimeRender _ a = [(contentType pctyp, toByteString pctyp a)]
|
2015-02-18 10:00:34 +01:00
|
|
|
where pctyp = Proxy :: Proxy ctyp
|
|
|
|
|
|
|
|
instance ( MimeRender ctyp a
|
2015-02-19 10:29:19 +01:00
|
|
|
, AllMimeRender (ctyp' ': ctyps) a
|
2015-02-18 10:00:34 +01:00
|
|
|
) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where
|
2015-02-19 10:29:19 +01:00
|
|
|
allMimeRender _ a = (contentType pctyp, toByteString pctyp a)
|
|
|
|
:(allMimeRender pctyps a)
|
2015-02-18 10:00:34 +01:00
|
|
|
where pctyp = Proxy :: Proxy ctyp
|
2015-02-19 10:29:19 +01:00
|
|
|
pctyps = Proxy :: Proxy (ctyp' ': ctyps)
|
2015-02-18 10:00:34 +01:00
|
|
|
|
|
|
|
|
|
|
|
instance AllMimeRender '[] a where
|
2015-02-19 10:29:19 +01:00
|
|
|
allMimeRender _ _ = []
|
2015-02-18 10:00:34 +01:00
|
|
|
|
|
|
|
--------------------------------------------------------------------------
|
|
|
|
-- Check that all elements of list are instances of MimeUnrender
|
|
|
|
--------------------------------------------------------------------------
|
|
|
|
class AllMimeUnrender ls a where
|
2015-02-19 10:29:19 +01:00
|
|
|
allMimeUnrender :: Proxy ls -> ByteString -> [(M.MediaType, Either String a)]
|
2015-02-18 10:00:34 +01:00
|
|
|
|
2015-02-19 10:29:19 +01:00
|
|
|
instance AllMimeUnrender '[] a where
|
|
|
|
allMimeUnrender _ _ = []
|
2015-02-18 10:00:34 +01:00
|
|
|
|
|
|
|
instance ( MimeUnrender ctyp a
|
|
|
|
, AllMimeUnrender ctyps a
|
2015-02-19 10:29:19 +01:00
|
|
|
) => AllMimeUnrender (ctyp ': ctyps) a where
|
|
|
|
allMimeUnrender _ val = (contentType pctyp, fromByteString pctyp val)
|
|
|
|
:(allMimeUnrender pctyps val)
|
2015-02-18 10:00:34 +01:00
|
|
|
where pctyp = Proxy :: Proxy ctyp
|
|
|
|
pctyps = Proxy :: Proxy ctyps
|
|
|
|
|
|
|
|
type family IsNonEmpty (ls::[*]) :: Constraint where
|
2015-02-19 10:29:19 +01:00
|
|
|
IsNonEmpty (x ': xs) = ()
|