webwire-0.1.0: WebWire/Render.hs

-- |
-- Module:     WebWire.Render
-- Copyright:  (c) 2011 Ertugrul Soeylemez
-- License:    BSD3
-- Maintainer: Ertugrul Soeylemez <es@ertes.de>
--
-- Rendering module.

module WebWire.Render
    ( -- * Renderable types
      Renderable(..),
      render,
      respondOutput,

      -- * Default widget
      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


-- | This class represents renderable types.  Each renderable type can
-- support rendering to several target representations like HTML, JSON,
-- XML, etc.
--
-- For simple applications the predefined instances should suffice.

class Renderable src where
    -- | Render the input value as the most appropriate output type.
    toWebOutput :: WebWire site src WebOutput
    toWebOutput =
        toWebOutputHtml <+>
        toWebOutputPlain <+>
        toWebOutputGen

    -- | Render the input value as some appropriate output type.
    toWebOutputGen :: WebWire site src WebOutput
    toWebOutputGen = notFound

    -- | Render the input value as HTML.
    toWebOutputHtml :: WebWire site src WebOutput
    toWebOutputHtml = notFound

    -- | Render the input value as plain text.
    toWebOutputPlain :: WebWire site src WebOutput
    toWebOutputPlain = notFound


-- | 'ByteString' strings render to fixed length plain text.  Note that
-- UTF-8 encoding is assumed.

instance Renderable ByteString where
    toWebOutputPlain = arr (TextOutput True . fromByteString)


-- | 'Css' values render to a CSS stylesheet.

instance Renderable Css where
    toWebOutputGen = arr (GenOutput False "text/css" . fromLazyText . renderCss)


-- | HTML is rendered as text/html with an assumed character set of
-- UTF-8.

instance Renderable Html where
    toWebOutputHtml = arr (HtmlOutput False)


-- | 'Javascript' values render to a JavaScript resource.

instance Renderable Javascript where
    toWebOutputGen = arr (GenOutput False "text/javascript" . fromLazyText . renderJavascript)


-- | Strings render to variable length plain text.

instance Renderable String where
    toWebOutputPlain = arr (TextOutput False . fromString)


-- | 'Text' strings render to fixed length plain text.

instance Renderable Text where
    toWebOutputPlain = arr (TextOutput True . fromText)


-- | Widgets render to HTML in the way specified in "WebWire.Widget".

instance Renderable Widget where
    toWebOutputHtml = arr (HtmlOutput False . toHtml)


-- | Add the input widget to the current default widget.

addWidget :: WebWire site Widget ()
addWidget =
    proc w ->
        execute -< modify $ \cfg ->
            let w' = wcWidget cfg
            in cfg { wcWidget = mappend w' w }


-- | Render the given renderable value as a response to the user.

render :: Renderable src => WebWire site src Response
render = toWebOutput >>> respondOutput


-- | Render the default widget.

renderDef :: WebWire site a Response
renderDef =
    proc _ -> do
        wg <- execute -< gets wcWidget
        render -< wg


-- | Render the given output as a response to the user.

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)