{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE OverloadedStrings #-}
module Yesod.Core.Content
(
Content (..)
, emptyContent
, ToContent (..)
, ToFlushBuilder (..)
, ContentType
, typeHtml
, typePlain
, typeJson
, typeXml
, typeAtom
, typeRss
, typeJpeg
, typePng
, typeGif
, typeSvg
, typeJavascript
, typeCss
, typeFlv
, typeOgv
, typeOctet
, simpleContentType
, contentTypeTypes
, DontFullyEvaluate (..)
, TypedContent (..)
, ToTypedContent (..)
, HasContentType (..)
, RepHtml
, RepJson (..)
, RepPlain (..)
, RepXml (..)
, repJson
, repPlain
, repXml
) where
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import Data.Text.Lazy (Text, pack)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8Builder)
import qualified Data.Text.Lazy as TL
import Data.ByteString.Builder (Builder, byteString, lazyByteString, stringUtf8)
import Text.Hamlet (Html)
import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)
import Data.Conduit (Flush (Chunk), SealedConduitT, mapOutput)
import Control.Monad (liftM)
import Control.Monad.Trans.Resource (ResourceT)
import qualified Data.Conduit.Internal as CI
import qualified Data.Aeson as J
import Data.Text.Lazy.Builder (toLazyText)
import Data.Void (Void, absurd)
import Yesod.Core.Types
import Text.Lucius (Css, renderCss)
import Text.Julius (Javascript, unJavascript)
import Data.Word8 (_semicolon, _slash)
import Control.Arrow (second)
emptyContent :: Content
emptyContent :: Content
emptyContent = Builder -> Maybe Int -> Content
ContentBuilder forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Int
0
class ToContent a where
toContent :: a -> Content
instance ToContent Content where
toContent :: Content -> Content
toContent = forall a. a -> a
id
instance ToContent Builder where
toContent :: Builder -> Content
toContent = forall a b c. (a -> b -> c) -> b -> a -> c
flip Builder -> Maybe Int -> Content
ContentBuilder forall a. Maybe a
Nothing
instance ToContent B.ByteString where
toContent :: ContentType -> Content
toContent ContentType
bs = Builder -> Maybe Int -> Content
ContentBuilder (ContentType -> Builder
byteString ContentType
bs) forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ContentType -> Int
B.length ContentType
bs
instance ToContent L.ByteString where
toContent :: ByteString -> Content
toContent = forall a b c. (a -> b -> c) -> b -> a -> c
flip Builder -> Maybe Int -> Content
ContentBuilder forall a. Maybe a
Nothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
lazyByteString
instance ToContent T.Text where
toContent :: Text -> Content
toContent = forall a. ToContent a => a -> Content
toContent forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Builder
encodeUtf8Builder
instance ToContent Text where
toContent :: Text -> Content
toContent = forall a. ToContent a => a -> Content
toContent forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Text -> Builder
encodeUtf8Builder forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
TL.toChunks
instance ToContent String where
toContent :: String -> Content
toContent = forall a. ToContent a => a -> Content
toContent forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Builder
stringUtf8
instance ToContent Html where
toContent :: Html -> Content
toContent Html
bs = Builder -> Maybe Int -> Content
ContentBuilder (Html -> Builder
renderHtmlBuilder Html
bs) forall a. Maybe a
Nothing
instance ToContent () where
toContent :: () -> Content
toContent () = forall a. ToContent a => a -> Content
toContent ContentType
B.empty
instance ToContent Void where
toContent :: Void -> Content
toContent = forall a. Void -> a
absurd
instance ToContent (ContentType, Content) where
toContent :: (ContentType, Content) -> Content
toContent = forall a b. (a, b) -> b
snd
instance ToContent TypedContent where
toContent :: TypedContent -> Content
toContent (TypedContent ContentType
_ Content
c) = Content
c
instance ToContent (JSONResponse a) where
toContent :: JSONResponse a -> Content
toContent (JSONResponse a
a) = forall a. ToContent a => a -> Content
toContent forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Encoding
J.toEncoding a
a
instance ToContent Css where
toContent :: Css -> Content
toContent = forall a. ToContent a => a -> Content
toContent forall b c a. (b -> c) -> (a -> b) -> a -> c
. Css -> Text
renderCss
instance ToContent Javascript where
toContent :: Javascript -> Content
toContent = forall a. ToContent a => a -> Content
toContent forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
toLazyText forall b c a. (b -> c) -> (a -> b) -> a -> c
. Javascript -> Builder
unJavascript
instance ToFlushBuilder builder => ToContent (CI.Pipe () () builder () (ResourceT IO) ()) where
toContent :: Pipe () () builder () (ResourceT IO) () -> Content
toContent Pipe () () builder () (ResourceT IO) ()
src = ConduitT () (Flush Builder) (ResourceT IO) () -> Content
ContentSource forall a b. (a -> b) -> a -> b
$ forall i o (m :: * -> *) r.
(forall b. (r -> Pipe i i o () m b) -> Pipe i i o () m b)
-> ConduitT i o m r
CI.ConduitT (forall (m :: * -> *) o1 o2 l i u r.
Monad m =>
(o1 -> o2) -> Pipe l i o1 u m r -> Pipe l i o2 u m r
CI.mapOutput forall a. ToFlushBuilder a => a -> Flush Builder
toFlushBuilder Pipe () () builder () (ResourceT IO) ()
src forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=)
instance ToFlushBuilder builder => ToContent (CI.ConduitT () builder (ResourceT IO) ()) where
toContent :: ConduitT () builder (ResourceT IO) () -> Content
toContent ConduitT () builder (ResourceT IO) ()
src = ConduitT () (Flush Builder) (ResourceT IO) () -> Content
ContentSource forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) o1 o2 i r.
Monad m =>
(o1 -> o2) -> ConduitT i o1 m r -> ConduitT i o2 m r
mapOutput forall a. ToFlushBuilder a => a -> Flush Builder
toFlushBuilder ConduitT () builder (ResourceT IO) ()
src
instance ToFlushBuilder builder => ToContent (SealedConduitT () builder (ResourceT IO) ()) where
toContent :: SealedConduitT () builder (ResourceT IO) () -> Content
toContent (CI.SealedConduitT Pipe () () builder () (ResourceT IO) ()
src) = forall a. ToContent a => a -> Content
toContent Pipe () () builder () (ResourceT IO) ()
src
class ToFlushBuilder a where toFlushBuilder :: a -> Flush Builder
instance ToFlushBuilder (Flush Builder) where toFlushBuilder :: Flush Builder -> Flush Builder
toFlushBuilder = forall a. a -> a
id
instance ToFlushBuilder Builder where toFlushBuilder :: Builder -> Flush Builder
toFlushBuilder = forall a. a -> Flush a
Chunk
instance ToFlushBuilder (Flush B.ByteString) where toFlushBuilder :: Flush ContentType -> Flush Builder
toFlushBuilder = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ContentType -> Builder
byteString
instance ToFlushBuilder B.ByteString where toFlushBuilder :: ContentType -> Flush Builder
toFlushBuilder = forall a. a -> Flush a
Chunk forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContentType -> Builder
byteString
instance ToFlushBuilder (Flush L.ByteString) where toFlushBuilder :: Flush ByteString -> Flush Builder
toFlushBuilder = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Builder
lazyByteString
instance ToFlushBuilder L.ByteString where toFlushBuilder :: ByteString -> Flush Builder
toFlushBuilder = forall a. a -> Flush a
Chunk forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
lazyByteString
instance ToFlushBuilder (Flush Text) where toFlushBuilder :: Flush Text -> Flush Builder
toFlushBuilder = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Text -> Builder
encodeUtf8Builder forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
TL.toChunks)
instance ToFlushBuilder Text where toFlushBuilder :: Text -> Flush Builder
toFlushBuilder = forall a. a -> Flush a
Chunk forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Text -> Builder
encodeUtf8Builder forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
TL.toChunks
instance ToFlushBuilder (Flush T.Text) where toFlushBuilder :: Flush Text -> Flush Builder
toFlushBuilder = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Builder
encodeUtf8Builder
instance ToFlushBuilder T.Text where toFlushBuilder :: Text -> Flush Builder
toFlushBuilder = forall a. a -> Flush a
Chunk forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Builder
encodeUtf8Builder
instance ToFlushBuilder (Flush String) where toFlushBuilder :: Flush String -> Flush Builder
toFlushBuilder = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Builder
stringUtf8
instance ToFlushBuilder String where toFlushBuilder :: String -> Flush Builder
toFlushBuilder = forall a. a -> Flush a
Chunk forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Builder
stringUtf8
instance ToFlushBuilder (Flush Html) where toFlushBuilder :: Flush Html -> Flush Builder
toFlushBuilder = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Html -> Builder
renderHtmlBuilder
instance ToFlushBuilder Html where toFlushBuilder :: Html -> Flush Builder
toFlushBuilder = forall a. a -> Flush a
Chunk forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> Builder
renderHtmlBuilder
repJson :: ToContent a => a -> RepJson
repJson :: forall a. ToContent a => a -> RepJson
repJson = Content -> RepJson
RepJson forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToContent a => a -> Content
toContent
repPlain :: ToContent a => a -> RepPlain
repPlain :: forall a. ToContent a => a -> RepPlain
repPlain = Content -> RepPlain
RepPlain forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToContent a => a -> Content
toContent
repXml :: ToContent a => a -> RepXml
repXml :: forall a. ToContent a => a -> RepXml
repXml = Content -> RepXml
RepXml forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToContent a => a -> Content
toContent
class ToTypedContent a => HasContentType a where
getContentType :: Monad m => m a -> ContentType
instance HasContentType RepJson where
getContentType :: forall (m :: * -> *). Monad m => m RepJson -> ContentType
getContentType m RepJson
_ = ContentType
typeJson
deriving instance ToContent RepJson
instance HasContentType RepPlain where
getContentType :: forall (m :: * -> *). Monad m => m RepPlain -> ContentType
getContentType m RepPlain
_ = ContentType
typePlain
deriving instance ToContent RepPlain
instance HasContentType (JSONResponse a) where
getContentType :: forall (m :: * -> *). Monad m => m (JSONResponse a) -> ContentType
getContentType m (JSONResponse a)
_ = ContentType
typeJson
instance HasContentType RepXml where
getContentType :: forall (m :: * -> *). Monad m => m RepXml -> ContentType
getContentType m RepXml
_ = ContentType
typeXml
deriving instance ToContent RepXml
typeHtml :: ContentType
typeHtml :: ContentType
typeHtml = ContentType
"text/html; charset=utf-8"
typePlain :: ContentType
typePlain :: ContentType
typePlain = ContentType
"text/plain; charset=utf-8"
typeJson :: ContentType
typeJson :: ContentType
typeJson = ContentType
"application/json; charset=utf-8"
typeXml :: ContentType
typeXml :: ContentType
typeXml = ContentType
"text/xml"
typeAtom :: ContentType
typeAtom :: ContentType
typeAtom = ContentType
"application/atom+xml"
typeRss :: ContentType
= ContentType
"application/rss+xml"
typeJpeg :: ContentType
typeJpeg :: ContentType
typeJpeg = ContentType
"image/jpeg"
typePng :: ContentType
typePng :: ContentType
typePng = ContentType
"image/png"
typeGif :: ContentType
typeGif :: ContentType
typeGif = ContentType
"image/gif"
typeSvg :: ContentType
typeSvg :: ContentType
typeSvg = ContentType
"image/svg+xml"
typeJavascript :: ContentType
typeJavascript :: ContentType
typeJavascript = ContentType
"text/javascript; charset=utf-8"
typeCss :: ContentType
typeCss :: ContentType
typeCss = ContentType
"text/css; charset=utf-8"
typeFlv :: ContentType
typeFlv :: ContentType
typeFlv = ContentType
"video/x-flv"
typeOgv :: ContentType
typeOgv :: ContentType
typeOgv = ContentType
"video/ogg"
typeOctet :: ContentType
typeOctet :: ContentType
typeOctet = ContentType
"application/octet-stream"
simpleContentType :: ContentType -> ContentType
simpleContentType :: ContentType -> ContentType
simpleContentType = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Bool) -> ContentType -> (ContentType, ContentType)
B.break (forall a. Eq a => a -> a -> Bool
== Word8
_semicolon)
contentTypeTypes :: ContentType -> (B.ByteString, B.ByteString)
contentTypeTypes :: ContentType -> (ContentType, ContentType)
contentTypeTypes = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ContentType -> ContentType
tailEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Bool) -> ContentType -> (ContentType, ContentType)
B.break (forall a. Eq a => a -> a -> Bool
== Word8
_slash) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContentType -> ContentType
simpleContentType
where
tailEmpty :: ContentType -> ContentType
tailEmpty ContentType
x = if ContentType -> Bool
B.null ContentType
x then ContentType
"" else HasCallStack => ContentType -> ContentType
B.tail ContentType
x
instance HasContentType a => HasContentType (DontFullyEvaluate a) where
getContentType :: forall (m :: * -> *).
Monad m =>
m (DontFullyEvaluate a) -> ContentType
getContentType = forall a (m :: * -> *).
(HasContentType a, Monad m) =>
m a -> ContentType
getContentType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. DontFullyEvaluate a -> a
unDontFullyEvaluate
instance ToContent a => ToContent (DontFullyEvaluate a) where
toContent :: DontFullyEvaluate a -> Content
toContent (DontFullyEvaluate a
a) = Content -> Content
ContentDontEvaluate forall a b. (a -> b) -> a -> b
$ forall a. ToContent a => a -> Content
toContent a
a
instance ToContent J.Value where
toContent :: Value -> Content
toContent = forall a b c. (a -> b -> c) -> b -> a -> c
flip Builder -> Maybe Int -> Content
ContentBuilder forall a. Maybe a
Nothing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall tag. Encoding' tag -> Builder
J.fromEncoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> Encoding
J.toEncoding
instance ToContent J.Encoding where
toContent :: Encoding -> Content
toContent = forall a b c. (a -> b -> c) -> b -> a -> c
flip Builder -> Maybe Int -> Content
ContentBuilder forall a. Maybe a
Nothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall tag. Encoding' tag -> Builder
J.fromEncoding
instance HasContentType J.Value where
getContentType :: forall (m :: * -> *). Monad m => m Value -> ContentType
getContentType m Value
_ = ContentType
typeJson
instance HasContentType J.Encoding where
getContentType :: forall (m :: * -> *). Monad m => m Encoding -> ContentType
getContentType m Encoding
_ = ContentType
typeJson
instance HasContentType Html where
getContentType :: forall (m :: * -> *). Monad m => m Html -> ContentType
getContentType m Html
_ = ContentType
typeHtml
instance HasContentType Text where
getContentType :: forall (m :: * -> *). Monad m => m Text -> ContentType
getContentType m Text
_ = ContentType
typePlain
instance HasContentType T.Text where
getContentType :: forall (m :: * -> *). Monad m => m Text -> ContentType
getContentType m Text
_ = ContentType
typePlain
instance HasContentType Css where
getContentType :: forall (m :: * -> *). Monad m => m Css -> ContentType
getContentType m Css
_ = ContentType
typeCss
instance HasContentType Javascript where
getContentType :: forall (m :: * -> *). Monad m => m Javascript -> ContentType
getContentType m Javascript
_ = ContentType
typeJavascript
class ToContent a => ToTypedContent a where
toTypedContent :: a -> TypedContent
instance ToTypedContent TypedContent where
toTypedContent :: TypedContent -> TypedContent
toTypedContent = forall a. a -> a
id
instance ToTypedContent () where
toTypedContent :: () -> TypedContent
toTypedContent () = ContentType -> Content -> TypedContent
TypedContent ContentType
typePlain (forall a. ToContent a => a -> Content
toContent ())
instance ToTypedContent Void where
toTypedContent :: Void -> TypedContent
toTypedContent = forall a. Void -> a
absurd
instance ToTypedContent (ContentType, Content) where
toTypedContent :: (ContentType, Content) -> TypedContent
toTypedContent (ContentType
ct, Content
content) = ContentType -> Content -> TypedContent
TypedContent ContentType
ct Content
content
instance ToTypedContent RepJson where
toTypedContent :: RepJson -> TypedContent
toTypedContent (RepJson Content
c) = ContentType -> Content -> TypedContent
TypedContent ContentType
typeJson Content
c
instance ToTypedContent RepPlain where
toTypedContent :: RepPlain -> TypedContent
toTypedContent (RepPlain Content
c) = ContentType -> Content -> TypedContent
TypedContent ContentType
typePlain Content
c
instance ToTypedContent RepXml where
toTypedContent :: RepXml -> TypedContent
toTypedContent (RepXml Content
c) = ContentType -> Content -> TypedContent
TypedContent ContentType
typeXml Content
c
instance ToTypedContent J.Value where
toTypedContent :: Value -> TypedContent
toTypedContent Value
v = ContentType -> Content -> TypedContent
TypedContent ContentType
typeJson (forall a. ToContent a => a -> Content
toContent Value
v)
instance ToTypedContent J.Encoding where
toTypedContent :: Encoding -> TypedContent
toTypedContent Encoding
e = ContentType -> Content -> TypedContent
TypedContent ContentType
typeJson (forall a. ToContent a => a -> Content
toContent Encoding
e)
instance ToTypedContent Html where
toTypedContent :: Html -> TypedContent
toTypedContent Html
h = ContentType -> Content -> TypedContent
TypedContent ContentType
typeHtml (forall a. ToContent a => a -> Content
toContent Html
h)
instance ToTypedContent T.Text where
toTypedContent :: Text -> TypedContent
toTypedContent Text
t = ContentType -> Content -> TypedContent
TypedContent ContentType
typePlain (forall a. ToContent a => a -> Content
toContent Text
t)
instance ToTypedContent [Char] where
toTypedContent :: String -> TypedContent
toTypedContent = forall a. ToTypedContent a => a -> TypedContent
toTypedContent forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack
instance ToTypedContent Text where
toTypedContent :: Text -> TypedContent
toTypedContent Text
t = ContentType -> Content -> TypedContent
TypedContent ContentType
typePlain (forall a. ToContent a => a -> Content
toContent Text
t)
instance ToTypedContent (JSONResponse a) where
toTypedContent :: JSONResponse a -> TypedContent
toTypedContent JSONResponse a
c = ContentType -> Content -> TypedContent
TypedContent ContentType
typeJson (forall a. ToContent a => a -> Content
toContent JSONResponse a
c)
instance ToTypedContent a => ToTypedContent (DontFullyEvaluate a) where
toTypedContent :: DontFullyEvaluate a -> TypedContent
toTypedContent (DontFullyEvaluate a
a) =
let TypedContent ContentType
ct Content
c = forall a. ToTypedContent a => a -> TypedContent
toTypedContent a
a
in ContentType -> Content -> TypedContent
TypedContent ContentType
ct (Content -> Content
ContentDontEvaluate Content
c)
instance ToTypedContent Css where
toTypedContent :: Css -> TypedContent
toTypedContent = ContentType -> Content -> TypedContent
TypedContent ContentType
typeCss forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToContent a => a -> Content
toContent
instance ToTypedContent Javascript where
toTypedContent :: Javascript -> TypedContent
toTypedContent = ContentType -> Content -> TypedContent
TypedContent ContentType
typeJavascript forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToContent a => a -> Content
toContent