index.tpl

<apply template="layout">
  <bind tag="bodycontent">
    <div class="posts">
      <collection name="posts" template="/posts/_post"/>
    </div>
  </bind>
</apply>

MongoDB.hs

{-# LANGUAGE OverloadedStrings #-}
module Splices.MongoDB where

import           Prelude
import qualified Prelude as P

import           Control.Monad
import           Control.Monad.Trans
import           Data.Maybe (fromJust)

import           Data.UString (u)
import qualified Data.UString as U
import           Database.MongoDB
import qualified Database.MongoDB as Mongo
import           Snap.Extension.MongoDB

import           Text.Templating.Heist
import           Snap.Extension.Heist
import qualified Text.XML.Expat.Tree as X

import           Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B

localTS :: (Monad m)
        => (TemplateState m -> TemplateState m)
        -> TemplateMonad m a
        -> TemplateMonad m a
localTS fn action = do
  ts <- getTS
  putTS (fn ts)
  result <- action
  putTS ts
  return result

getParamAttr :: (Monad m) => ByteString -> TemplateMonad m (Maybe ByteString)
getParamAttr k = do
  node <- getParamNode
  return $ X.getAttribute node k

getRequiredAttribute :: (Monad m) => ByteString -> TemplateMonad m ByteString
getRequiredAttribute name = fromJust `liftM` getParamAttr name

stringValue :: (Monad m) => Document -> Splice m
stringValue doc = do
  fieldName  <- getRequiredAttribute "name"
  fieldValue <- B.pack `liftM` Mongo.lookup (U.pack $ B.unpack fieldName) doc
  return [X.Text fieldValue]

ifNothing :: (Monad m) => Document -> Splice m
ifNothing doc = do
  node      <- getParamNode
  fieldName <- getRequiredAttribute "name"
  let children = X.eChildren node
  let value    = Mongo.look (U.pack $ B.unpack fieldName) doc :: Maybe Value
  return $ maybe children (const []) value

ifPresent :: (Monad m) => Document -> Splice m
ifPresent doc = do
  node      <- getParamNode
  fieldName <- getRequiredAttribute "name"
  let children = X.eChildren node
  let value    = Mongo.look (U.pack $ B.unpack fieldName) doc :: Maybe Value
  return $ maybe [] (const children) value

collectionSplice :: (MonadHeist n m, MonadMongoDB m) => Splice m
collectionSplice = do
  collectionName <- getRequiredAttribute "name"
  templateName   <- getRequiredAttribute "template"
  let uCollectionName = U.pack $ B.unpack collectionName
  result <- lift $ withDB (find (select [] uCollectionName) >>= rest)
  case result of
    Left  e          -> return $ [X.Text (B.pack $ show e)]
    Right collection -> do
      templates <- forM collection $ \doc -> do
        let splices = [ ("ifNothing", ifNothing doc)
                      , ("ifPresent", ifPresent doc)
                      , ("stringValue", stringValue doc)]
        localTS (bindSplices splices) (fromJust `liftM` callTemplate templateName [])
      return $ concat templates

post.tpl

<div class="post">
  <p class="title"><stringValue name="title"/></p>
  <div class="content">
    <stringValue name="content"/>
  </div>
  <div class="meta">
    <ifNothing name="createdAt">
      This text is here because there is no createdAt
    </ifNothing>
    <ifPresent name="createdAt">
      This text is here because there is a createdAt
    </ifPresent>
  </div>
</div>