module WebWire.Render
(
Renderable(..),
render,
respondOutput,
addWidget,
renderDef
)
where
import qualified Data.ByteString.Char8 as BC
import Blaze.ByteString.Builder
import Blaze.ByteString.Builder.Char.Utf8
import Control.Arrow
import Control.Monad.Trans.State
import Data.ByteString (ByteString)
import Data.Monoid
import Data.Text (Text)
import FRP.NetWire
import Network.HTTP.Types
import Network.Wai
import Text.Blaze
import Text.Blaze.Renderer.Utf8
import Text.Cassius
import Text.Julius
import WebWire.Tools
import WebWire.Types
import WebWire.Widget
class Renderable src where
toWebOutput :: WebWire site src WebOutput
toWebOutput =
toWebOutputHtml <+>
toWebOutputPlain <+>
toWebOutputGen
toWebOutputGen :: WebWire site src WebOutput
toWebOutputGen = notFound
toWebOutputHtml :: WebWire site src WebOutput
toWebOutputHtml = notFound
toWebOutputPlain :: WebWire site src WebOutput
toWebOutputPlain = notFound
instance Renderable ByteString where
toWebOutputPlain = arr (TextOutput True . fromByteString)
instance Renderable Css where
toWebOutputGen = arr (GenOutput False "text/css" . fromLazyText . renderCss)
instance Renderable Html where
toWebOutputHtml = arr (HtmlOutput False)
instance Renderable Javascript where
toWebOutputGen = arr (GenOutput False "text/javascript" . fromLazyText . renderJavascript)
instance Renderable String where
toWebOutputPlain = arr (TextOutput False . fromString)
instance Renderable Text where
toWebOutputPlain = arr (TextOutput True . fromText)
instance Renderable Widget where
toWebOutputHtml = arr (HtmlOutput False . toHtml)
addWidget :: WebWire site Widget ()
addWidget =
proc w ->
execute -< modify $ \cfg ->
let w' = wcWidget cfg
in cfg { wcWidget = mappend w' w }
render :: Renderable src => WebWire site src Response
render = toWebOutput >>> respondOutput
renderDef :: WebWire site a Response
renderDef =
proc _ -> do
wg <- execute -< gets wcWidget
render -< wg
respondOutput :: WebWire site WebOutput Response
respondOutput =
proc outp ->
case outp of
GenOutput withLen ctype ob ->
identity -< builder withLen ctype ob
HtmlOutput withLen html ->
let ctype = "text/html; charset=UTF-8" in
identity -< builder withLen ctype (renderHtmlBuilder html)
TextOutput withLen ob ->
let ctype = "text/plain; charset=UTF-8" in
identity -< builder withLen ctype ob
where
builder :: Bool -> Ascii -> Builder -> Response
builder False ctype ob =
let hs = [headerContentType ctype] in
ResponseBuilder statusOK hs ob
builder True ctype ob =
let ostr = toByteString ob
olen = BC.length ostr
hs =
headerContentType ctype :
headerContentLength (BC.pack (show olen)) : []
in ResponseBuilder statusOK hs (fromByteString ostr)