module Heist.Common where
import Control.Applicative
import Control.Exception (SomeException)
import Control.Monad
import qualified Control.Monad.CatchIO as C
import qualified Data.Attoparsec.Text as AP
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import Data.Hashable
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as Map
import Data.List
import Data.Maybe
import Data.Monoid
import qualified Data.Text as T
import System.FilePath
import Heist.SpliceAPI
import Heist.Types
import qualified Text.XmlHtml as X
orError :: Monad m => HeistT n m b -> String -> HeistT n m b
orError silent msg = do
hs <- getHS
if _preprocessingMode hs
then error $ (maybe "" (++": ") $ _curTemplateFile hs) ++ msg
else silent
showTPath :: TPath -> String
showTPath = BC.unpack . (`BC.append` ".tpl") . tpathName
tpathName :: TPath -> ByteString
tpathName = BC.intercalate "/" . reverse
setCurTemplateFile :: Maybe FilePath -> HeistState n -> HeistState n
setCurTemplateFile Nothing ts = ts
setCurTemplateFile fp ts = ts { _curTemplateFile = fp }
setCurContext :: TPath -> HeistState n -> HeistState n
setCurContext tp ts = ts { _curContext = tp }
attParser :: AP.Parser [AttAST]
attParser = liftM ($! []) (loop id)
where
append !dl !x = dl . (x:)
loop !dl = go id
where
finish subDL = let !txt = T.concat $! subDL []
lit = Literal $! T.concat $! subDL []
in return $! if T.null txt
then dl
else append dl lit
go !subDL = (gobbleText >>= go . append subDL)
<|> (AP.endOfInput *> finish subDL)
<|> (do
idp <- identParser
dl' <- finish subDL
loop $! append dl' idp)
gobbleText = AP.takeWhile1 (AP.notInClass "$")
identParser = AP.char '$' *> (ident <|> return (Literal "$"))
ident = (AP.char '{' *> (Ident <$> AP.takeWhile (/='}')) <* AP.string "}")
splitPathWith :: Char -> ByteString -> TPath
splitPathWith s p = if BC.null p then [] else (reverse $ BC.split s path)
where
path = if BC.head p == s then BC.tail p else p
splitLocalPath :: ByteString -> TPath
splitLocalPath = splitPathWith pathSeparator
splitTemplatePath :: ByteString -> TPath
splitTemplatePath = splitPathWith '/'
lookupTemplate :: ByteString
-> HeistState n
-> (HeistState n -> HashMap TPath t)
-> Maybe (t, TPath)
lookupTemplate nameStr ts tm = f (tm ts) path name
where
(name:p) = case splitTemplatePath nameStr of
[] -> [""]
ps -> ps
ctx = if B.isPrefixOf "/" nameStr then [] else _curContext ts
path = p ++ ctx
f = if '/' `BC.elem` nameStr
then singleLookup
else traversePath
hasTemplate :: ByteString -> HeistState n -> Bool
hasTemplate nameStr ts =
isJust $ lookupTemplate nameStr ts _templateMap
singleLookup :: (Eq a, Hashable a)
=> HashMap [a] t -> [a] -> a -> Maybe (t, [a])
singleLookup tm path name = fmap (\a -> (a,path)) $ Map.lookup (name:path) tm
traversePath :: (Eq a, Hashable a)
=> HashMap [a] t -> [a] -> a -> Maybe (t, [a])
traversePath tm [] name = fmap (\a -> (a,[])) (Map.lookup [name] tm)
traversePath tm path name =
singleLookup tm path name `mplus`
traversePath tm (tail path) name
mapSplices :: (Monad m, Monoid b)
=> (a -> m b)
-> [a]
-> m b
mapSplices f vs = liftM mconcat $ mapM f vs
getContext :: Monad m => HeistT n m TPath
getContext = getsHS _curContext
getTemplateFilePath :: Monad m => HeistT n m (Maybe FilePath)
getTemplateFilePath = getsHS _curTemplateFile
loadTemplate :: String
-> String
-> IO [Either String (TPath, DocumentFile)] --TemplateMap
loadTemplate templateRoot fname = do
c <- loadTemplate' fname
return $ map (fmap (\t -> (splitLocalPath $ BC.pack tName, t))) c
where
isHTMLTemplate = ".tpl" `isSuffixOf` fname
correction = if last templateRoot == '/' then 0 else 1
extLen = if isHTMLTemplate then 4 else 5
tName = drop ((length templateRoot)+correction) $
take ((length fname) extLen) fname
loadTemplate' :: String -> IO [Either String DocumentFile]
loadTemplate' fullDiskPath
| isHTMLTemplate = liftM (:[]) $ getDoc fullDiskPath
| isXMLTemplate = liftM (:[]) $ getXMLDoc fullDiskPath
| otherwise = return []
where
isHTMLTemplate = ".tpl" `isSuffixOf` fullDiskPath
isXMLTemplate = ".xtpl" `isSuffixOf` fullDiskPath
type ParserFun = String -> ByteString -> Either String X.Document
getDocWith :: ParserFun -> String -> IO (Either String DocumentFile)
getDocWith parser f = do
bs <- C.catch (liftM Right $ B.readFile f)
(\(e::SomeException) -> return $ Left $ show e)
let eitherDoc = either Left (parser f) bs
return $ either (\s -> Left $ f ++ " " ++ s)
(\d -> Right $ DocumentFile d (Just f)) eitherDoc
getDoc :: String -> IO (Either String DocumentFile)
getDoc = getDocWith X.parseHTML
getXMLDoc :: String -> IO (Either String DocumentFile)
getXMLDoc = getDocWith X.parseXML
setTemplates :: HashMap TPath DocumentFile -> HeistState n -> HeistState n
setTemplates m ts = ts { _templateMap = m }
insertTemplate :: TPath
-> DocumentFile
-> HeistState n
-> HeistState n
insertTemplate p t st =
setTemplates (Map.insert p t (_templateMap st)) st
mimeType :: X.Document -> MIMEType
mimeType d = case d of
(X.HtmlDocument e _ _) -> "text/html;charset=" `BC.append` enc e
(X.XmlDocument e _ _) -> "text/xml;charset=" `BC.append` enc e
where
enc X.UTF8 = "utf-8"
enc X.UTF16BE = "utf-16"
enc X.UTF16LE = "utf-16"
bindAttributeSplices :: Splices (AttrSplice n)
-> HeistState n
-> HeistState n
bindAttributeSplices ss hs =
hs { _attrSpliceMap = Map.union (Map.fromList $ splicesToList ss)
(_attrSpliceMap hs) }
addDoctype :: Monad m => [X.DocType] -> HeistT n m ()
addDoctype dt = do
modifyHS (\s -> s { _doctypes = _doctypes s `mappend` dt })