module Text.Templating.Heist.Internal where
import Control.Applicative
import Control.Exception (SomeException)
import Control.Monad.CatchIO
import "monads-fd" Control.Monad.RWS.Strict
import qualified Data.Attoparsec.Char8 as AP
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as L
import Data.Either
import qualified Data.Foldable as F
import Data.List
import qualified Data.Map as Map
import Data.Maybe
import Prelude hiding (catch)
import System.Directory.Tree hiding (name)
import System.FilePath
import Text.XML.Expat.Format
import qualified Text.XML.Expat.Tree as X
import Text.Templating.Heist.Constants
import Text.Templating.Heist.Types
restoreState :: Monad m => TemplateState m -> TemplateMonad m ()
restoreState ts1 =
modifyTS (\ts2 -> ts2
{ _recursionDepth = _recursionDepth ts1
, _curContext = _curContext ts1
, _spliceMap = _spliceMap ts1
})
addDoctype :: Monad m => [ByteString] -> TemplateMonad m ()
addDoctype dt = do
modifyTS (\s -> s { _doctypes = _doctypes s `mappend` dt })
addOnLoadHook :: (Monad m) =>
(Template -> IO Template)
-> TemplateState m
-> TemplateState m
addOnLoadHook hook ts = ts { _onLoadHook = _onLoadHook ts >=> hook }
addPreRunHook :: (Monad m) =>
(Template -> m Template)
-> TemplateState m
-> TemplateState m
addPreRunHook hook ts = ts { _preRunHook = _preRunHook ts >=> hook }
addPostRunHook :: (Monad m) =>
(Template -> m Template)
-> TemplateState m
-> TemplateState m
addPostRunHook hook ts = ts { _postRunHook = _postRunHook ts >=> hook }
bindSplice :: Monad m =>
ByteString
-> Splice m
-> TemplateState m
-> TemplateState m
bindSplice n v ts = ts {_spliceMap = Map.insert n v (_spliceMap ts)}
lookupSplice :: Monad m =>
ByteString
-> TemplateState m
-> Maybe (Splice m)
lookupSplice nm ts = Map.lookup nm $ _spliceMap ts
splitPathWith :: Char -> ByteString -> TPath
splitPathWith s p = if B.null p then [] else (reverse $ B.split s path)
where
path = if B.head p == s then B.tail p else p
splitLocalPath :: ByteString -> TPath
splitLocalPath = splitPathWith pathSeparator
splitTemplatePath :: ByteString -> TPath
splitTemplatePath = splitPathWith '/'
singleLookup :: TemplateMap
-> TPath
-> ByteString
-> Maybe (InternalTemplate, TPath)
singleLookup tm path name = fmap (\a -> (a,path)) $ Map.lookup (name:path) tm
traversePath :: TemplateMap
-> TPath
-> ByteString
-> Maybe (InternalTemplate, TPath)
traversePath tm [] name = fmap (\a -> (a,[])) (Map.lookup [name] tm)
traversePath tm path name =
singleLookup tm path name `mplus`
traversePath tm (tail path) name
lookupTemplate :: Monad m =>
ByteString
-> TemplateState m
-> Maybe (InternalTemplate, TPath)
lookupTemplate nameStr ts =
f (_templateMap ts) path name
where (name:p) = case splitTemplatePath nameStr of
[] -> [""]
ps -> ps
path = p ++ (_curContext ts)
f = if '/' `B.elem` nameStr
then singleLookup
else traversePath
setTemplates :: Monad m => TemplateMap -> TemplateState m -> TemplateState m
setTemplates m ts = ts { _templateMap = m }
insertTemplate :: Monad m =>
TPath
-> InternalTemplate
-> TemplateState m
-> TemplateState m
insertTemplate p t st =
setTemplates (Map.insert p t (_templateMap st)) st
addTemplate :: Monad m =>
ByteString
-> InternalTemplate
-> TemplateState m
-> TemplateState m
addTemplate n t st = insertTemplate (splitTemplatePath n) t st
stopRecursion :: Monad m => TemplateMonad m ()
stopRecursion = modifyTS (\st -> st { _recurse = False })
setContext :: Monad m => TPath -> TemplateMonad m ()
setContext c = modifyTS (\st -> st { _curContext = c })
getContext :: Monad m => TemplateMonad m TPath
getContext = getsTS _curContext
runNode :: Monad m => Node -> Splice m
runNode n@(X.Text _) = return [n]
runNode n@(X.Element nm at ch) = do
s <- liftM (lookupSplice nm) getTS
maybe runChildren (recurseSplice n) s
where
runChildren = do
newKids <- runNodeList ch
newAtts <- mapM attSubst at
return [X.Element nm newAtts newKids]
attSubst :: (Monad m) => (t, ByteString) -> TemplateMonad m (t, ByteString)
attSubst (n,v) = do
v' <- parseAtt v
return (n,v')
parseAtt :: (Monad m) => ByteString -> TemplateMonad m ByteString
parseAtt bs = do
let ast = case AP.feed (AP.parse attParser bs) "" of
(AP.Fail _ _ _) -> []
(AP.Done _ res) -> res
(AP.Partial _) -> []
chunks <- mapM cvt ast
return $ B.concat chunks
where
cvt (Literal x) = return x
cvt (Ident x) = getAttributeSplice x
data AttAST = Literal ByteString |
Ident ByteString
deriving (Show)
attParser :: AP.Parser [AttAST]
attParser = AP.many1 (identParser <|> litParser)
where
escChar = (AP.char '\\' *> AP.anyChar) <|>
AP.satisfy (AP.notInClass "\\$")
litParser = Literal <$> (B.pack <$> AP.many1 escChar)
identParser = AP.string "$(" *>
(Ident <$> AP.takeWhile (/=')')) <* AP.string ")"
getAttributeSplice :: Monad m => ByteString -> TemplateMonad m ByteString
getAttributeSplice name = do
s <- liftM (lookupSplice name) getTS
nodes <- maybe (return []) id s
return $ B.concat $ map X.textContent nodes
runNodeList :: Monad m => [Node] -> Splice m
runNodeList nodes = liftM concat $ sequence (map runNode nodes)
mAX_RECURSION_DEPTH :: Int
mAX_RECURSION_DEPTH = 50
recurseSplice :: Monad m => Node -> Splice m -> Splice m
recurseSplice node splice = do
result <- localParamNode (const node) splice
ts' <- getTS
if _recurse ts' && _recursionDepth ts' < mAX_RECURSION_DEPTH
then do modRecursionDepth (+1)
res <- runNodeList result
restoreState ts'
return res
else return result
where
modRecursionDepth :: Monad m => (Int -> Int) -> TemplateMonad m ()
modRecursionDepth f =
modifyTS (\st -> st { _recursionDepth = f (_recursionDepth st) })
lookupAndRun :: Monad m
=> ByteString
-> ((InternalTemplate, TPath) -> TemplateMonad m (Maybe a))
-> TemplateMonad m (Maybe a)
lookupAndRun name k = do
ts <- getTS
maybe (return Nothing) k
(lookupTemplate name ts)
evalTemplate :: Monad m
=> ByteString
-> TemplateMonad m (Maybe Template)
evalTemplate name = lookupAndRun name
(\(t,ctx) -> do
ts <- getTS
putTS (ts {_curContext = ctx})
res <- runNodeList $ _itNodes t
restoreState ts
return $ Just res)
evalWithHooks :: Monad m
=> ByteString
-> TemplateMonad m (Maybe Template)
evalWithHooks name = lookupAndRun name
(\(t,ctx) -> do
addDoctype $ maybeToList $ _itDoctype t
ts <- getTS
nodes <- lift $ _preRunHook ts $ _itNodes t
putTS (ts {_curContext = ctx})
res <- runNodeList nodes
restoreState ts
return . Just =<< lift (_postRunHook ts res))
bindStrings :: Monad m
=> [(ByteString, ByteString)]
-> TemplateState m
-> TemplateState m
bindStrings pairs ts = foldr add ts pairs
where
add (n,v) = bindSplice n (return [X.Text v])
callTemplate :: Monad m
=> ByteString
-> [(ByteString, ByteString)]
-> TemplateMonad m (Maybe Template)
callTemplate name params = do
modifyTS $ bindStrings params
evalTemplate name
toInternalTemplate :: Monad m => Template -> TemplateMonad m InternalTemplate
toInternalTemplate t = do
dts <- getsTS _doctypes
return $ InternalTemplate {
_itDoctype = listToMaybe dts,
_itNodes = t
}
renderInternal :: Monad m => InternalTemplate -> TemplateMonad m ByteString
renderInternal (InternalTemplate dt nodes) =
return $ maybe bs (flip B.append bs) dt
where
bs = formatList' nodes
renderTemplate :: Monad m
=> TemplateState m
-> ByteString
-> m (Maybe ByteString)
renderTemplate ts name = do
evalTemplateMonad
(do mt <- evalWithHooks name
maybe (return Nothing)
(\t -> liftM Just $ renderInternal =<< toInternalTemplate t)
mt
) (X.Text "") ts
parseDoc :: ByteString -> IO (Either String (Maybe ByteString,[Node]))
parseDoc bs = do
let (doctype,rest) = extractDoctype bs
let wrap b = B.concat ["<snap:root>\n", b, "\n</snap:root>"]
return $
mapRight (\n -> (doctype,X.getChildren n)) $
mapLeft genErrorMsg $
X.parse' heistExpatOptions (wrap rest)
where
genErrorMsg (X.XMLParseError str loc) = locMsg loc ++ ": " ++ translate str
locMsg (X.XMLParseLocation line col _ _) =
"(line " ++ show (line1) ++ ", col " ++ show col ++ ")"
translate "junk after document element" = "document must have a single root element"
translate s = s
getDoc :: String -> IO (Either String InternalTemplate)
getDoc f = do
bs <- catch (liftM Right $ B.readFile f)
(\(e::SomeException) -> return $ Left $ show e)
d' <- either (return . Left)
parseDoc
bs
let d = mapLeft (\s -> f ++ " " ++ s) d'
return $ either Left
(\(doctype, nodes) -> Right $ InternalTemplate {
_itDoctype = doctype,
_itNodes = nodes
})
d
hasDoctype :: ByteString -> Bool
hasDoctype bs = "<!DOCTYPE" `B.isPrefixOf` bs
extractDoctype :: ByteString -> (Maybe ByteString, ByteString)
extractDoctype bs =
if hasDoctype bs
then (Just $ B.snoc (B.takeWhile p bs) '>',B.tail $ B.dropWhile p bs)
else (Nothing, bs)
where
p = (/='>')
mapLeft :: (a -> b) -> Either a c -> Either b c
mapLeft g = either (Left . g) Right
mapRight :: (b -> c) -> Either a b -> Either a c
mapRight g = either Left (Right . g)
loadTemplate :: String
-> String
-> IO [Either String (TPath, InternalTemplate)] --TemplateMap
loadTemplate templateRoot fname
| ".tpl" `isSuffixOf` fname = do
c <- getDoc fname
return [fmap (\t -> (splitLocalPath $ B.pack tName, t)) c]
| otherwise = return []
where
correction = if last templateRoot == '/' then 0 else 1
tName = drop ((length templateRoot)+correction) $
take ((length fname) 4) fname
loadTemplates :: Monad m => FilePath -> TemplateState m -> IO (Either String (TemplateState m))
loadTemplates dir ts = do
d <- readDirectoryWith (loadTemplate dir) dir
let tlist = F.fold (free d)
errs = lefts tlist
case errs of
[] -> liftM Right $ foldM loadHook ts $ rights tlist
_ -> return $ Left $ unlines errs
runHookInternal :: Monad m => (Template -> m Template)
-> InternalTemplate
-> m InternalTemplate
runHookInternal f t = do
n <- f $ _itNodes t
return $ t { _itNodes = n }
loadHook :: Monad m => TemplateState m -> (TPath, InternalTemplate) -> IO (TemplateState m)
loadHook ts (tp, t) = do
t' <- runHookInternal (_onLoadHook ts) t
return $ insertTemplate tp t' ts
formatList :: (X.GenericXMLString tag, X.GenericXMLString text) =>
[X.Node tag text]
-> L.ByteString
formatList nodes = foldl L.append L.empty $ map formatNode nodes
formatList' :: (X.GenericXMLString tag, X.GenericXMLString text) =>
[X.Node tag text]
-> B.ByteString
formatList' = B.concat . L.toChunks . formatList