heist-0.14.0: src/Heist/Splices/Json.hs
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Heist.Splices.Json (
bindJson
) where
------------------------------------------------------------------------------
import Control.Monad.Reader
import Data.Aeson
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.HashMap.Strict as Map
import Data.Map.Syntax
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Vector as V
import Text.Blaze.Html5 ((!))
import qualified Text.Blaze.Html5 as B
import Text.Blaze.Renderer.XmlHtml
import Text.XmlHtml
------------------------------------------------------------------------------
import Heist.Interpreted.Internal
import Heist.Internal.Types.HeistState
------------------------------------------------------------------------------
------------
-- public --
------------
------------------------------------------------------------------------------
-- | This splice binds convenience tags for the given JSON (or
-- JSON-convertible) value and runs the tag's child nodes using the new
-- bindings.
--
-- /Tags bound when you pass in an object/
--
-- Tags bound for an object looking like this:
--
-- > { "k_1": v_1, ..., "k_N": v_N }
--
-- @\<value:{k_i}\>@ -- treats v_i as text
-- @\<snippet:{k_i}\>@ -- treats v_i as HTML
-- @\<with:{k_i}\>@ -- explodes v_i and runs its children
--
-- @\<value var=\"foo.bar.baz\"\/>@ -- walks the JSON tree to find
-- \"foo.bar.baz\", and interprets it as a string
-- @\<snippet var=\"foo.bar.baz\"\/\>@
-- @\<with var=\"foo.bar.baz\"\>...\<with\>@
--
-- /Tags bound when you pass in anything else/
--
-- @\<value\/\>@ -- the given JSON value, as a string
-- @\<snippet\/\>@ -- the given JSON value, parsed and spliced in as HTML
--
bindJson :: (ToJSON a, Monad n) => a -> Splice n
bindJson = runReaderT explodeTag . toJSON
-------------
-- private --
-------------
------------------------------------------------------------------------------
errorMessage :: String -> [Node]
errorMessage s = renderHtmlNodes $
B.strong ! B.customAttribute "class" "error" $
B.toHtml s
------------------------------------------------------------------------------
type JsonMonad n m a = ReaderT Value (HeistT n m) a
------------------------------------------------------------------------------
withValue :: (Monad m) => Value -> JsonMonad n m a -> HeistT n m a
withValue = flip runReaderT
------------------------------------------------------------------------------
boolToText :: Bool -> Text
boolToText b = if b then "true" else "false"
------------------------------------------------------------------------------
numToText :: ToJSON a => a -> Text
numToText = T.decodeUtf8 . S.concat . L.toChunks . encode
------------------------------------------------------------------------------
findExpr :: Text -> Value -> Maybe Value
findExpr t = go (T.split (=='.') t)
where
go [] !value = Just value
go (x:xs) !value = findIn value >>= go xs
where
findIn (Object obj) = Map.lookup x obj
findIn _ = Nothing
------------------------------------------------------------------------------
asHtml :: Monad m => Text -> m [Node]
asHtml t =
case (parseHTML "" $ T.encodeUtf8 t) of
Left e -> return $ errorMessage $
"Template error turning JSON into HTML: " ++ e
Right d -> return $! docContent d
------------------------------------------------------------------------------
snippetTag :: Monad m => JsonMonad n m [Node]
snippetTag = ask >>= snip
where
txt t = lift $ asHtml t
snip Null = txt ""
snip (Bool b) = txt $ boolToText b
snip (Number n) = txt $ numToText n
snip (String t) = txt t
snip _ = lift $ do
node <- getParamNode
return $ errorMessage $ concat [
"error processing tag <"
, T.unpack $ fromMaybe "???" $ tagName node
, ">: can't interpret JSON arrays or objects as HTML."
]
------------------------------------------------------------------------------
valueTag :: Monad m => JsonMonad n m [Node]
valueTag = ask >>= go
where
go Null = txt ""
go (Bool b) = txt $ boolToText b
go (Number n) = txt $ numToText n
go (String t) = txt t
go _ = lift $ do
node <- getParamNode
return $ errorMessage $ concat [
"error processing tag <"
, T.unpack $ fromMaybe "???" $ tagName node
, ">: can't interpret JSON arrays or objects as text."
]
txt t = return [TextNode t]
------------------------------------------------------------------------------
explodeTag :: (Monad n) => JsonMonad n n [Node]
explodeTag = ask >>= go
where
--------------------------------------------------------------------------
go Null = goText ""
go (Bool b) = goText $ boolToText b
go (Number n) = goText $ numToText n
go (String t) = goText t
go (Array a) = goArray a
go (Object o) = goObject o
--------------------------------------------------------------------------
goText t = lift $ runChildrenWith $ do
"value" ## return [TextNode t]
"snippet" ## asHtml t
--------------------------------------------------------------------------
goArray :: (Monad n) => V.Vector Value -> JsonMonad n n [Node]
goArray a = do
lift stopRecursion
dl <- V.foldM f id a
return $! dl []
where
f dl jsonValue = do
tags <- go jsonValue
return $! dl . (tags ++)
--------------------------------------------------------------------------
-- search the param node for attribute \"var=expr\", search the given JSON
-- object for the expression, and if it's found run the JsonMonad action m
-- using the restricted JSON object.
varAttrTag :: (Monad m) => Value -> (JsonMonad m m [Node]) -> Splice m
varAttrTag v m = do
node <- getParamNode
maybe (noVar node) (hasVar node) $ getAttribute "var" node
where
noVar node = return $ errorMessage $
concat [ "expression error: no var attribute in <"
, T.unpack $ fromMaybe "???" $ tagName node
, "> tag"
]
hasVar node expr = maybe (return $ errorMessage $
concat [
"expression error: can't find \""
, T.unpack expr
, "\" in JSON object (<"
, T.unpack $ fromMaybe "???" $ tagName node
, "> tag)"
])
(runReaderT m)
(findExpr expr v)
--------------------------------------------------------------------------
genericBindings :: Monad n => JsonMonad n n (Splices (Splice n))
genericBindings = ask >>= \v -> return $ do
"with" ## varAttrTag v explodeTag
"snippet" ## varAttrTag v snippetTag
"value" ## varAttrTag v valueTag
--------------------------------------------------------------------------
goObject obj = do
start <- genericBindings
let bindings = Map.foldlWithKey' bindKvp start obj
lift $ runChildrenWith bindings
--------------------------------------------------------------------------
bindKvp bindings k v =
let newBindings = do
T.append "with:" k ## withValue v explodeTag
T.append "snippet:" k ## withValue v snippetTag
T.append "value:" k ## withValue v valueTag
in bindings >> newBindings