module Web.Respond.Types.Response where
import Network.HTTP.Types.Header
import Network.HTTP.Types.Status
import qualified Network.HTTP.Media as Media
import Network.Wai
import Data.Maybe (fromMaybe)
import Control.Applicative ((<$>), pure)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import Data.Aeson
type Responder = Response -> IO ResponseReceived
type ResponseBody = (Media.MediaType, BSL.ByteString)
class ToResponseBody a where
toResponseBody :: a
-> BS.ByteString
-> Maybe ResponseBody
type MediaTypeMatcher a = (Media.MediaType, a -> BSL.ByteString)
prepMediaTypeMatcher :: a -> MediaTypeMatcher a -> (Media.MediaType, ResponseBody)
prepMediaTypeMatcher v (mtype, builder) = (mtype, (mtype, builder v))
matchToContentTypes :: [MediaTypeMatcher a] -> a -> BS.ByteString -> Maybe ResponseBody
matchToContentTypes matchers v = Media.mapAcceptMedia (prepMediaTypeMatcher v <$> matchers)
matchToContentTypesDefault :: MediaTypeMatcher a -> [MediaTypeMatcher a] -> a -> BS.ByteString -> ResponseBody
matchToContentTypesDefault def matchers v = fromMaybe (snd $ prepMediaTypeMatcher v def) . matchToContentTypes matchers v
charsetUtf8 :: (BS.ByteString, BS.ByteString)
charsetUtf8 = ("charset", "utf-8")
textUtf8 :: Media.MediaType -> (a -> TL.Text) -> MediaTypeMatcher a
textUtf8 mt b = (mt Media./: charsetUtf8, TL.encodeUtf8 . b)
mkResponseForBody :: Status -> ResponseHeaders -> ResponseBody -> Response
mkResponseForBody status headers (mtype, body) = responseLBS status ((hContentType, Media.renderHeader mtype):headers) body
mkResponse :: ToResponseBody a => Status -> ResponseHeaders -> a -> BS.ByteString -> Maybe Response
mkResponse status headers val accept = mkResponseForBody status headers <$> toResponseBody val accept
jsonMatcher :: ToJSON a => MediaTypeMatcher a
jsonMatcher = ("application/json" Media./: charsetUtf8, encode)
matchAcceptJson :: ToJSON a => a -> BS.ByteString -> Maybe ResponseBody
matchAcceptJson = matchToContentTypes [jsonMatcher]
instance ToResponseBody Value where
toResponseBody = matchAcceptJson
htmlMatcher :: (a -> BSL.ByteString) -> MediaTypeMatcher a
htmlMatcher = ("text/html" Media./: charsetUtf8,)
matchAcceptHtml :: (a -> BSL.ByteString) -> a -> BS.ByteString -> Maybe ResponseBody
matchAcceptHtml = matchToContentTypes . pure . htmlMatcher
textPlainMatcher :: (a -> BSL.ByteString) -> MediaTypeMatcher a
textPlainMatcher = ("text/plain" Media./: charsetUtf8,)
matchTextPlain :: (a -> BSL.ByteString) -> a -> BS.ByteString -> Maybe ResponseBody
matchTextPlain = matchToContentTypes . pure . textPlainMatcher