diff --git a/heist.cabal b/heist.cabal --- a/heist.cabal +++ b/heist.cabal @@ -1,7 +1,27 @@ name: heist -version: 0.8.2 -synopsis: An (x)html templating system -description: An (x)html templating system +version: 0.10.0 +synopsis: An Haskell template system supporting both HTML5 and XML. +description: + Heist is a powerful template system that supports both HTML5 and XML. + Some of Heist's features are: + . + * Designer-friendly HTML5 (or XML) syntax + . + * Templates can be reloaded to make changes visible without recompiling + your Haskell code + . + * Enforces near-perfect separation of business logic and view + . + * Powerful abstraction primitives allowing you to eliminate repetition + . + * Easy creation of domain-specific markup languages + . + * Built-in support for including JSON and Markdown content in templates + . + * Simple mechanism for designer-specified template caching + . + * Optional merging of multiple \ tags defined anywhere in the + document license: BSD3 license-file: LICENSE author: Doug Beardsley, Gregory Collins @@ -36,30 +56,57 @@ test/heist-testsuite.cabal, test/README, test/runTestsAndCoverage.sh, + test/suite/Benchmark.hs, + test/suite/Heist/Compiled/Tests.hs, + test/suite/Heist/Interpreted/Tests.hs, + test/suite/Heist/TestCommon.hs, + test/suite/Heist/Tests.hs, + test/suite/Heist/Tutorial/AttributeSplices.lhs, + test/suite/Heist/Tutorial/CompiledSplices.lhs, + test/suite/Heist/Tutorial/Imports.hs, test/suite/TestSuite.hs, - test/suite/Text/Templating/Heist/Tests.hs, test/templates/a.tpl, + test/templates/attr_splice.tpl, test/templates/attrs.tpl, + test/templates/attrsubtest1.tpl, + test/templates/attrsubtest2.tpl, test/templates/bar/a.tpl, test/templates/bar/index.tpl, + test/templates/bind-apply-interaction/_outer.tpl, + test/templates/bind-apply-interaction/caller.tpl, test/templates/bind-attrs.tpl, - test/templates/etc.tpl, + test/templates/bind_param.tpl, + test/templates/cache.tpl, + test/templates/div_expansion.tpl, test/templates/foo/a.tpl, test/templates/foo/b.tpl, + test/templates/foo/markdown-chdir.tpl, + test/templates/foo/markdown-origdir.tpl, + test/templates/foo/test2.md, + test/templates/head_merge/index.tpl, + test/templates/head_merge/nav.tpl, + test/templates/head_merge/wrap.tpl, test/templates/index.tpl, test/templates/ioc.tpl, test/templates/json.tpl, test/templates/json_object.tpl, test/templates/json_snippet.tpl, test/templates/markdown.tpl, - test/templates/noroot.tpl, test/templates/page.tpl, + test/templates/people.tpl, + test/templates/post.tpl, test/templates/readme.txt, test/templates/test.md, + test/templates/textarea_expansion.tpl, + test/templates/title_expansion.tpl, test/templates/user/admin/main.tpl, test/templates/user/admin/menu.tpl, test/templates/user/main.tpl, test/templates/user/menu.tpl, + test/templates-bad/apply-missing-attr.tpl, + test/templates-bad/apply-template-not-found.tpl, + test/templates-bad/bind-infinite-loop.tpl, + test/templates-bad/bind-missing-attr.tpl, TODO @@ -67,41 +114,50 @@ hs-source-dirs: src exposed-modules: - Text.Templating.Heist, - Text.Templating.Heist.Splices, - Text.Templating.Heist.Splices.Apply, - Text.Templating.Heist.Splices.Bind, - Text.Templating.Heist.Splices.BindStrict, - Text.Templating.Heist.Splices.Cache, - Text.Templating.Heist.Splices.Html, - Text.Templating.Heist.Splices.Ignore, - Text.Templating.Heist.Splices.Json, - Text.Templating.Heist.Splices.Markdown, - Text.Templating.Heist.TemplateDirectory + Heist, + Heist.Compiled, + Heist.Interpreted, + Heist.Splices, + Heist.Splices.Apply, + Heist.Splices.Bind, + Heist.Splices.BindStrict, + Heist.Splices.Cache, + Heist.Splices.Html, + Heist.Splices.Ignore, + Heist.Splices.Json, + Heist.Splices.Markdown, + Heist.TemplateDirectory other-modules: - Text.Templating.Heist.Internal, - Text.Templating.Heist.Types + Data.HeterogeneousEnvironment, + Heist.Common, + Heist.Compiled.Internal, + Heist.Interpreted.Internal, + Heist.Types build-depends: - aeson >= 0.6 && < 0.7, - attoparsec >= 0.10 && < 0.11, - base >= 4 && < 5, - blaze-builder >= 0.2 && < 0.4, - blaze-html >= 0.4 && < 0.6, - bytestring, - directory, - directory-tree, - filepath, - MonadCatchIO-transformers >= 0.2.1 && < 0.4, - mtl >= 2.0 && < 2.2, - process, - random, - text >= 0.10 && < 0.12, - time >= 1.1 && < 1.5, - xmlhtml >= 0.1.6 && < 0.3, - unordered-containers >= 0.1.4 && < 0.3, - vector >= 0.9 && < 0.11 + MonadCatchIO-transformers >= 0.2.1 && < 0.4, + aeson >= 0.6 && < 0.7, + attoparsec >= 0.10 && < 0.11, + base >= 4 && < 5, + blaze-builder >= 0.2 && < 0.4, + blaze-html >= 0.4 && < 0.6, + bytestring >= 0.9 && < 0.11, + containers >= 0.2 && < 0.6, + directory >= 1.1 && < 1.3, + directory-tree >= 0.10 && < 0.12, + dlist >= 0.5 && < 0.6, + errors >= 1.3 && < 1.4, + filepath >= 1.3 && < 1.4, + hashable >= 1.1 && < 1.2, + mtl >= 2.0 && < 2.2, + process >= 1.1 && < 1.2, + random >= 1.0.1.0 && < 1.1, + text >= 0.10 && < 0.12, + time >= 1.1 && < 1.5, + unordered-containers >= 0.1.4 && < 0.3, + vector >= 0.9 && < 0.11, + xmlhtml >= 0.1.6 && < 0.3 if impl(ghc >= 6.12.0) ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 @@ -126,4 +182,5 @@ source-repository head type: git - location: http://git.snapframework.com/heist.git + location: https://github.com/snapframework/heist.git + diff --git a/src/Data/HeterogeneousEnvironment.hs b/src/Data/HeterogeneousEnvironment.hs new file mode 100644 --- /dev/null +++ b/src/Data/HeterogeneousEnvironment.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RankNTypes #-} + +------------------------------------------------------------------------------ +module Data.HeterogeneousEnvironment + ( KeyGen + , HeterogeneousEnvironment + , Key + , newKeyGen + , empty + , makeKey + , lookup + , insert + , delete + , adjust + , getKeyId + ) where + +------------------------------------------------------------------------------ +import Control.Monad +import Data.IntMap (IntMap) +import qualified Data.IntMap as IM +import Data.IORef +import GHC.Exts +import Prelude hiding (lookup) +import Unsafe.Coerce + +------------------------------------------------------------------------------ +data HeterogeneousEnvironment = HeterogeneousEnvironment (IntMap Any) +newtype Key a = Key Int +newtype KeyGen = KeyGen (IORef Int) + + +------------------------------------------------------------------------------ +-- | If you use two different KeyGens to work with the same map, you deserve +-- what you get. +newKeyGen :: IO KeyGen +newKeyGen = liftM KeyGen $ newIORef 0 + + +------------------------------------------------------------------------------ +getKeyId :: Key a -> Int +getKeyId (Key x) = x + + +------------------------------------------------------------------------------ +empty :: HeterogeneousEnvironment +empty = HeterogeneousEnvironment $ IM.empty + + +------------------------------------------------------------------------------ +makeKey :: KeyGen -> IO (Key a) +makeKey (KeyGen gen) = do + k <- atomicModifyIORef gen nextKey + return $ Key k + where + nextKey !x = if x >= maxBound-1 + then error "too many keys generated" + else let !x' = x+1 in (x',x) + + +------------------------------------------------------------------------------ +lookup :: Key a -> HeterogeneousEnvironment -> Maybe a +lookup (Key k) (HeterogeneousEnvironment m) = fmap unsafeCoerce $ IM.lookup k m + + +------------------------------------------------------------------------------ +insert :: Key a -> a -> HeterogeneousEnvironment -> HeterogeneousEnvironment +insert (Key k) v (HeterogeneousEnvironment m) = HeterogeneousEnvironment $ + IM.insert k (unsafeCoerce v) m + + +------------------------------------------------------------------------------ +delete :: Key a -> HeterogeneousEnvironment -> HeterogeneousEnvironment +delete (Key k) (HeterogeneousEnvironment m) = HeterogeneousEnvironment $ + IM.delete k m + + +------------------------------------------------------------------------------ +adjust :: (a -> a) -> Key a -> HeterogeneousEnvironment -> HeterogeneousEnvironment +adjust f (Key k) (HeterogeneousEnvironment m) = HeterogeneousEnvironment $ + IM.adjust f' k m + where + f' = unsafeCoerce . f . unsafeCoerce diff --git a/src/Heist.hs b/src/Heist.hs new file mode 100644 --- /dev/null +++ b/src/Heist.hs @@ -0,0 +1,227 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| + +This module defines the core data types used by Heist. In practice you will +also want to import one or both of "Heist.Compiled" or "Heist.Interpreted" to +get functions needed for writing splices. + +The Heist template system allows you to build custom HTML and XML based markup +languages. With Heist you can define your own domain-specific tags +implemented with Haskell and use them in your templates. + +-} + +module Heist + ( + -- * Primary Heist initialization functions + loadTemplates + , addTemplatePathPrefix + , initHeist + , initHeistWithCacheTag + , defaultLoadTimeSplices + + -- * Core Heist data types + , Template + , TPath + , HeistConfig(..) + , MIMEType + , DocumentFile(..) + , AttrSplice + , RuntimeSplice + , Chunk + , HeistState(..) + , templateNames + , compiledTemplateNames + , hasTemplate + , spliceNames + , HeistT + , evalHeistT + , getParamNode + , getContext + , getTemplateFilePath + , localParamNode + , getsHS + , getHS + , putHS + , modifyHS + , restoreHS + , localHS + , getDoc + , getXMLDoc + , orError + ) where + +import Control.Error +import Control.Exception (SomeException) +import Control.Monad.CatchIO +import Control.Monad.Trans +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.Foldable as F +import qualified Data.HeterogeneousEnvironment as HE +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as Map +import Data.Monoid +import Data.Text (Text) +import System.Directory.Tree +import qualified Text.XmlHtml as X + +import Heist.Common +import qualified Heist.Compiled.Internal as C +import qualified Heist.Interpreted.Internal as I +import Heist.Splices +import Heist.Types + + +data HeistConfig m = HeistConfig + { hcInterpretedSplices :: [(Text, I.Splice m)] + -- ^ Interpreted splices are the splices that Heist has always had. They + -- return a list of nodes and are processed at runtime. + , hcLoadTimeSplices :: [(Text, I.Splice IO)] + -- ^ Load time splices are like interpreted splices because they return a + -- list of nodes. But they are like compiled splices because they are + -- processed once at load time. All of Heist's built-in splices should be + -- used as load time splices. + , hcCompiledSplices :: [(Text, C.Splice m)] + -- ^ Compiled splices return a DList of Chunks and are processed at load + -- time to generate a runtime monad action that will be used to render the + -- template. + , hcAttributeSplices :: [(Text, AttrSplice m)] + -- ^ Attribute splices are bound to attribute names and return a list of + -- attributes. + , hcTemplates :: HashMap TPath DocumentFile + -- ^ Templates returned from the 'loadTemplates' function. + } + + +instance Monoid (HeistConfig m) where + mempty = HeistConfig [] [] [] [] Map.empty + mappend (HeistConfig a b c d e) (HeistConfig a' b' c' d' e') = + HeistConfig (a `mappend` a') + (b `mappend` b') + (c `mappend` c') + (d `mappend` d') + (e `mappend` e') + + +------------------------------------------------------------------------------ +-- | The built-in set of static splices. All the splices that used to be +-- enabled by default are included here. To get the normal Heist behavior you +-- should include these in the hcLoadTimeSplices list in your HeistConfig. +defaultLoadTimeSplices :: MonadIO m => [(Text, (I.Splice m))] +defaultLoadTimeSplices = + [ (applyTag, applyImpl) + , (bindTag, bindImpl) + , (ignoreTag, ignoreImpl) + , (markdownTag, markdownSplice) + , ("content", deprecatedContentCheck) -- To be removed in later versions + ] + + +------------------------------------------------------------------------------ +-- | Loads templates from disk. This function returns just a template map so +-- you can load multiple directories and combine the maps before initializing +-- your HeistState. +loadTemplates :: FilePath -> EitherT [String] IO (HashMap TPath DocumentFile) +loadTemplates dir = do + d <- lift $ readDirectoryWith (loadTemplate dir) dir + let tlist = F.fold (free d) + errs = lefts tlist + case errs of + [] -> right $ Map.fromList $ rights tlist + _ -> left errs + + +------------------------------------------------------------------------------ +-- | Adds a path prefix to a templates in a map returned by loadTemplates. If +-- you want to add multiple levels of directories, separate them with slashes +-- as in "foo/bar". Using an empty string as a path prefix will leave the +-- map unchanged. +addTemplatePathPrefix :: ByteString + -> HashMap TPath DocumentFile + -> HashMap TPath DocumentFile +addTemplatePathPrefix dir ts + | B.null dir = ts + | otherwise = Map.fromList $ + map (\(x,y) -> (f x, y)) $ + Map.toList ts + where + f ps = ps++splitTemplatePath dir + + +------------------------------------------------------------------------------ +-- | This is the main Heist initialization function. You pass in a map of all +-- templates and all of your splices and it constructs and returns a +-- HeistState. +-- +-- We don't provide functions to add either type of loadtime splices to your +-- HeistState after initHeist because it doesn't make any sense unless you +-- re-initialize all templates with the new splices. If you add any old-style +-- runtime heist splices after calling this function, they will still work +-- fine if you use Heist.Interpreted.renderTemplate. If you add any templates +-- later, then those templates will be available for interpreted rendering, +-- but not for compiled rendering. +-- +-- In the past you could add templates to your HeistState after initialization +-- using its Monoid instance. Due to implementation details, this is no +-- longer possible. All of your templates must be known when you call this +-- function. +initHeist :: Monad n + => HeistConfig n + -> EitherT [String] IO (HeistState n) +initHeist (HeistConfig i lt c a rawTemplates) = do + keyGen <- lift HE.newKeyGen + let empty = HeistState Map.empty Map.empty Map.empty Map.empty + Map.empty True [] 0 [] Nothing keyGen False + hs0 = empty { _spliceMap = Map.fromList lt + , _templateMap = rawTemplates + , _preprocessingMode = True } + tPairs <- lift $ evalHeistT + (mapM preprocess $ Map.toList rawTemplates) (X.TextNode "") hs0 + let bad = lefts tPairs + tmap = Map.fromList $ rights tPairs + hs1 = empty { _spliceMap = Map.fromList i + , _templateMap = tmap + , _compiledSpliceMap = Map.fromList c + , _attrSpliceMap = Map.fromList a + } + if not (null bad) + then left bad + else lift $ C.compileTemplates hs1 + + +------------------------------------------------------------------------------ +-- | +preprocess :: (TPath, DocumentFile) + -> HeistT IO IO (Either String (TPath, DocumentFile)) +preprocess (tpath, docFile) = do + let tname = tpathName tpath + !emdoc <- try $ I.evalWithDoctypes tname + :: HeistT IO IO (Either SomeException (Maybe X.Document)) + let f !doc = (tpath, docFile { dfDoc = doc }) + return $! either (Left . show) (Right . maybe die f) emdoc + where + die = error "Preprocess didn't succeed! This should never happen." + + +------------------------------------------------------------------------------ +-- | Wrapper around initHeist that also sets up a cache tag. It sets up both +-- compiled and interpreted versions of the cache tag splices. If you need to +-- do configure the cache tag differently than how this function does it, you +-- will still probably want to pattern your approach after this function's +-- implementation. +initHeistWithCacheTag :: MonadIO n + => HeistConfig n + -> EitherT [String] IO (HeistState n, CacheTagState) +initHeistWithCacheTag (HeistConfig i lt c a rawTemplates) = do + (ss, cts) <- liftIO mkCacheTag + let tag = "cache" + hc' = HeistConfig ((tag, cacheImpl cts) : i) + ((tag, ss) : lt) + ((tag, cacheImplCompiled cts) : c) + a rawTemplates + hs <- initHeist hc' + return (hs, cts) + diff --git a/src/Heist/Common.hs b/src/Heist/Common.hs new file mode 100644 --- /dev/null +++ b/src/Heist/Common.hs @@ -0,0 +1,288 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Heist.Common where + +import Control.Applicative +import Control.Exception (SomeException) +import Control.Monad +import Control.Monad.CatchIO +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.Either +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 Prelude hiding (catch) +import System.FilePath +import Heist.Types +import qualified Text.XmlHtml as X + + +------------------------------------------------------------------------------ +-- | If Heist is running in fail fast mode, then this function will throw an +-- exception with the second argument as the error message. Otherwise, the +-- first argument will be executed to represent silent failure. +-- +-- This behavior allows us to fail quickly if an error crops up during +-- load-time splice processing or degrade more gracefully if the error occurs +-- while a user request is being processed. +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 + + +------------------------------------------------------------------------------ +-- | Function for showing a TPath. +showTPath :: TPath -> String +showTPath = BC.unpack . (`BC.append` ".tpl") . tpathName + +tpathName :: TPath -> ByteString +tpathName = BC.intercalate "/" . reverse + + +------------------------------------------------------------------------------ +-- | Sets the current template file. +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 } + + +------------------------------------------------------------------------------ +-- | Parser for attribute variable substitution. +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 + res <- escSequence + dl' <- finish subDL + loop $! append dl' res) + <|> (do + idp <- identParser + dl' <- finish subDL + loop $! append dl' idp) + + gobbleText = AP.takeWhile1 (AP.notInClass "\\$") + + escSequence = AP.char '\\' *> (Escaped <$> AP.anyChar) + + identParser = AP.char '$' *> (ident <|> return (Literal "$")) + ident = (AP.char '{' *> (Ident <$> AP.takeWhile (/='}')) <* AP.string "}") + + +------------------------------------------------------------------------------ +-- | Converts a path into an array of the elements in reverse order. If the +-- path is absolute, we need to remove the leading slash so the split doesn't +-- leave @\"\"@ as the last element of the TPath. +-- +-- FIXME @\"..\"@ currently doesn't work in paths, the solution is non-trivial +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 + + +------------------------------------------------------------------------------ +-- | Converts a path into an array of the elements in reverse order using the +-- path separator of the local operating system. See 'splitPathWith' for more +-- details. +splitLocalPath :: ByteString -> TPath +splitLocalPath = splitPathWith pathSeparator + + +------------------------------------------------------------------------------ +-- | Converts a path into an array of the elements in reverse order using a +-- forward slash (/) as the path separator. See 'splitPathWith' for more +-- details. +splitTemplatePath :: ByteString -> TPath +splitTemplatePath = splitPathWith '/' + + +------------------------------------------------------------------------------ +-- | Convenience function for looking up a template. +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 + + +------------------------------------------------------------------------------ +-- | Returns 'True' if the given template can be found in the heist state. +hasTemplate :: ByteString -> HeistState n -> Bool +hasTemplate nameStr ts = + isJust $ lookupTemplate nameStr ts _templateMap + + +------------------------------------------------------------------------------ +-- | Does a single template lookup without cascading up. +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 + + +------------------------------------------------------------------------------ +-- | Searches for a template by looking in the full path then backing up into +-- each of the parent directories until the template is found. +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 + + +------------------------------------------------------------------------------ +-- | Maps a splice generating function over a list and concatenates the +-- results. This function now has a more general type signature so it works +-- with both compiled and interpreted splices. The old type signature was +-- this: +-- +-- > mapSplices :: (Monad n) +-- > => (a -> Splice n n) +-- > -> [a] +-- > -> Splice n n +mapSplices :: (Monad m, Monoid b) + => (a -> m b) + -- ^ Splice generating function + -> [a] + -- ^ List of items to generate splices for + -> m b + -- ^ The result of all splices concatenated together. +mapSplices f vs = liftM mconcat $ mapM f vs +{-# INLINE mapSplices #-} + + +------------------------------------------------------------------------------ +-- | Gets the current context +getContext :: Monad m => HeistT n m TPath +getContext = getsHS _curContext + + +------------------------------------------------------------------------------ +-- | Gets the full path to the file holding the template currently being +-- processed. Returns Nothing if the template is not associated with a file +-- on disk or if there is no template being processed. +getTemplateFilePath :: Monad m => HeistT n m (Maybe FilePath) +getTemplateFilePath = getsHS _curTemplateFile + + +------------------------------------------------------------------------------ +-- | Loads a template with the specified path and filename. The +-- template is only loaded if it has a ".tpl" or ".xtpl" extension. +loadTemplate :: String -- ^ path of the template root + -> String -- ^ full file path (includes the template root) + -> IO [Either String (TPath, DocumentFile)] --TemplateMap +loadTemplate templateRoot fname + | isHTMLTemplate = do + c <- getDoc fname + return [fmap (\t -> (splitLocalPath $ BC.pack tName, t)) c] + | isXMLTemplate = do + c <- getXMLDoc fname + return [fmap (\t -> (splitLocalPath $ BC.pack tName, t)) c] + | otherwise = return [] + where -- tName is path relative to the template root directory + isHTMLTemplate = ".tpl" `isSuffixOf` fname + isXMLTemplate = ".xtpl" `isSuffixOf` fname + correction = if last templateRoot == '/' then 0 else 1 + extLen = if isHTMLTemplate then 4 else 5 + tName = drop ((length templateRoot)+correction) $ + -- We're only dropping the template root, not the whole path + take ((length fname) - extLen) fname + + +------------------------------------------------------------------------------ +-- | Type synonym for parsers. +type ParserFun = String -> ByteString -> Either String X.Document + + +------------------------------------------------------------------------------ +-- | Reads an HTML or XML template from disk. +getDocWith :: ParserFun -> String -> IO (Either String DocumentFile) +getDocWith parser f = do + bs <- 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 + + +------------------------------------------------------------------------------ +-- | Reads an HTML template from disk. +getDoc :: String -> IO (Either String DocumentFile) +getDoc = getDocWith X.parseHTML + + +------------------------------------------------------------------------------ +-- | Reads an XML template from disk. +getXMLDoc :: String -> IO (Either String DocumentFile) +getXMLDoc = getDocWith X.parseXML + + +------------------------------------------------------------------------------ +-- | Sets the templateMap in a HeistState. +setTemplates :: HashMap TPath DocumentFile -> HeistState n -> HeistState n +setTemplates m ts = ts { _templateMap = m } + + +------------------------------------------------------------------------------ +-- | Adds a template to the heist state. +insertTemplate :: TPath + -> DocumentFile + -> HeistState n + -> HeistState n +insertTemplate p t st = + setTemplates (Map.insert p t (_templateMap st)) st + + +------------------------------------------------------------------------------ +-- Gives the MIME type for a 'X.Document' +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" + -- Should not include byte order designation for UTF-16 since + -- rendering will include a byte order mark. (RFC 2781, Sec. 3.3) + enc X.UTF16BE = "utf-16" + enc X.UTF16LE = "utf-16" + + diff --git a/src/Heist/Compiled.hs b/src/Heist/Compiled.hs new file mode 100644 --- /dev/null +++ b/src/Heist/Compiled.hs @@ -0,0 +1,61 @@ +{-| + +Compiled splices are similar to the original Heist (interpreted) splices, but +without the high performance costs of traversing a DOM at runtime. Compiled +splices do all of their DOM processing at load time. They are compiled to +produce a runtime computation that generates a ByteString Builder. This +preserves the ability to write splices that access runtime information from +the HTTP request, database, etc. + +If you import both this module and "Heist.Interpreted" in the same file, then +you will need to import them qualified. + +-} + +module Heist.Compiled + ( + -- * High level compiled splice API + Splice + , renderTemplate + , mapPromises + , promiseChildren + , promiseChildrenWith + , promiseChildrenWithTrans + , promiseChildrenWithText + , promiseChildrenWithNodes + + -- * Constructing Chunks + -- $yieldOverview + , yieldPure + , yieldRuntime + , yieldRuntimeEffect + , yieldPureText + , yieldRuntimeText + , yieldLater + , addSplices + + -- * Lower level promise functions + , Promise + , newEmptyPromise + + -- * RuntimeSplice functions + , getPromise + , putPromise + , adjustPromise + , codeGen + + -- * Running nodes and splices + , runNodeList + , runNode + , compileNode + , runSplice + + ) where + +import Heist.Compiled.Internal + +-- $yieldOverview +-- The internals of the Chunk data type are deliberately not exported because +-- we want to hide the underlying implementation as much as possible. The +-- @yield...@ functions give you lower lever construction of Chunks and DLists +-- of Chunks. diff --git a/src/Heist/Compiled/Internal.hs b/src/Heist/Compiled/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Heist/Compiled/Internal.hs @@ -0,0 +1,604 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Heist.Compiled.Internal where + +import Blaze.ByteString.Builder +import Control.Arrow +import Control.Monad.RWS.Strict +import Control.Monad.State.Strict +import qualified Data.Attoparsec.Text as AP +import Data.ByteString (ByteString) +import Data.DList (DList) +import qualified Data.DList as DL +import qualified Data.HashMap.Strict as H +import qualified Data.HeterogeneousEnvironment as HE +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 Prelude hiding (catch) +import qualified Text.XmlHtml as X + +import Heist.Common +import Heist.Types + +------------------------------------------------------------------------------ +-- | A compiled Splice is a HeistT computation that returns a @DList +-- (Chunk m)@. +-- +-- The more interesting part of the type signature is what comes before the +-- return value. The first type parameter in @'HeistT' n IO@ is the runtime +-- monad. This reveals that the Chunks know about the runtime monad. The +-- second type parameter in @HeistT n IO@ is @IO@. This tells is that the +-- compiled splices themselves are run in the IO monad, which will usually +-- mean at load time. Compiled splices run at load time, and they return +-- computations that run at runtime. +type Splice n = HeistT n IO (DList (Chunk n)) + + +------------------------------------------------------------------------------ +-- | Takes a promise function and a runtime action returning a list of items +-- that fit in the promise and returns a Splice that executes the promise +-- function for each item and concatenates the results. +-- +-- This function works nicely with the 'promiseChildrenWith' family of +-- functions, much like the combination of 'mapSplices' and 'runChildrenWith' +-- for interpreted splices. +mapPromises :: Monad n + => (Promise a -> HeistT n IO (RuntimeSplice n Builder)) + -- ^ Use 'promiseChildrenWith' or a variant to create this + -- function. + -> n [a] + -- ^ Runtime computation returning a list of items + -> Splice n +mapPromises f getList = do + singlePromise <- newEmptyPromise + runSingle <- f singlePromise + return $ yieldRuntime $ do + list <- lift getList + htmls <- forM list $ \item -> + putPromise singlePromise item >> runSingle + return $ mconcat htmls + + +------------------------------------------------------------------------------ +-- | Returns a runtime computation that simply renders the node's children. +promiseChildren :: Monad m => HeistT m IO (RuntimeSplice m Builder) +promiseChildren = do + res <- runNodeList . X.childNodes =<< getParamNode + return $! codeGen $! consolidate res +{-# INLINE promiseChildren #-} + + +------------------------------------------------------------------------------ +-- | Binds a list of Builder splices before using the children of the spliced +-- node as a view. +promiseChildrenWith :: (Monad n) + => [(Text, a -> Builder)] + -> Promise a + -> HeistT n IO (RuntimeSplice n Builder) +promiseChildrenWith splices prom = + localHS (bindSplices splices') promiseChildren + where + fieldSplice p f = return $ yieldRuntime $ liftM f $ getPromise p + splices' = map (second (fieldSplice prom)) splices + + +------------------------------------------------------------------------------ +-- | Wrapper that composes a transformation function with the second item in +-- each of the tuples before calling promiseChildren. +promiseChildrenWithTrans :: Monad n + => (b -> Builder) + -> [(Text, a -> b)] + -> Promise a + -> HeistT n IO (RuntimeSplice n Builder) +promiseChildrenWithTrans f = promiseChildrenWith . map (second (f .)) + + +------------------------------------------------------------------------------ +-- | Binds a list of Text splices before using the children of the spliced +-- node as a view. +promiseChildrenWithText :: (Monad n) + => [(Text, a -> Text)] + -> Promise a + -> HeistT n IO (RuntimeSplice n Builder) +promiseChildrenWithText = + promiseChildrenWithTrans (fromByteString . T.encodeUtf8) + + +------------------------------------------------------------------------------ +-- | Binds a list of Node splices before using the children of the spliced +-- node as a view. Note that this will slow down page generation because the +-- nodes generated by the splices must be traversed and rendered into a +-- ByteString at runtime. +promiseChildrenWithNodes :: (Monad n) + => [(Text, a -> [X.Node])] + -> Promise a + -> HeistT n IO (RuntimeSplice n Builder) +promiseChildrenWithNodes = + promiseChildrenWithTrans (X.renderHtmlFragment X.UTF8) + + +------------------------------------------------------------------------------ +-- | Yields pure text known at load time. +pureTextChunk :: Text -> Chunk n +pureTextChunk t = Pure $ T.encodeUtf8 t +{-# INLINE pureTextChunk #-} + + +------------------------------------------------------------------------------ +-- | Yields a pure Builder known at load time. You should use this and +-- 'yieldPureText' as much as possible to maximize the parts of your page that +-- can be compiled to static ByteStrings. +yieldPure :: Builder -> DList (Chunk m) +yieldPure = DL.singleton . Pure . toByteString +{-# INLINE yieldPure #-} + + +------------------------------------------------------------------------------ +-- | Yields a runtime action that returns a builder. +yieldRuntime :: RuntimeSplice m Builder -> DList (Chunk m) +yieldRuntime = DL.singleton . RuntimeHtml +{-# INLINE yieldRuntime #-} + + +------------------------------------------------------------------------------ +-- | Yields a runtime action that returns no value and is only needed for its +-- side effect. +yieldRuntimeEffect :: Monad m => RuntimeSplice m () -> DList (Chunk m) +yieldRuntimeEffect = DL.singleton . RuntimeAction +{-# INLINE yieldRuntimeEffect #-} + + +------------------------------------------------------------------------------ +-- | A convenience wrapper around yieldPure for working with Text. Roughly +-- equivalent to 'textSplice' from Heist.Interpreted. +yieldPureText :: Text -> DList (Chunk m) +yieldPureText = DL.singleton . pureTextChunk +{-# INLINE yieldPureText #-} + + +------------------------------------------------------------------------------ +-- | Convenience wrapper around yieldRuntime allowing you to work with Text. +yieldRuntimeText :: Monad m => RuntimeSplice m Text -> DList (Chunk m) +yieldRuntimeText = yieldRuntime . liftM (fromByteString . T.encodeUtf8) +{-# INLINE yieldRuntimeText #-} + + +------------------------------------------------------------------------------ +-- | This lets you turn a plain runtime monad function returning a Builder +-- into a compiled splice. +yieldLater :: Monad m => m Builder -> DList (Chunk m) +yieldLater = yieldRuntime . RuntimeSplice . lift +{-# INLINE yieldLater #-} + + +------------------------------------------------------------------------------ +-- | Returns a computation that performs load-time splice processing on the +-- supplied list of nodes. +runNodeList :: Monad n => [X.Node] -> Splice n +runNodeList = mapSplices runNode + + +------------------------------------------------------------------------------ +-- | Runs a single splice and returns the builder computation. +runSplice :: (Monad n) + => X.Node + -> HeistState n + -> Splice n + -> IO [Chunk n] +runSplice node hs splice = do + (!a,_) <- runHeistT splice node hs + return $! consolidate a + + +------------------------------------------------------------------------------ +-- | Runs a DocumentFile with the appropriate template context set. +runDocumentFile :: Monad n + => TPath + -> DocumentFile + -> Splice n +runDocumentFile tpath df = do + modifyHS (setCurTemplateFile curPath . setCurContext tpath) + runNodeList nodes + where + curPath = dfFile df + nodes = X.docContent $! dfDoc df + + +------------------------------------------------------------------------------ +compileTemplate :: Monad n + => HeistState n + -> TPath + -> DocumentFile + -> IO [Chunk n] +compileTemplate hs tpath df = do + !chunks <- runSplice nullNode hs $! runDocumentFile tpath df + return chunks + where + -- This gets overwritten in runDocumentFile + nullNode = X.TextNode "" + + +------------------------------------------------------------------------------ +compileTemplates :: Monad n => HeistState n -> IO (HeistState n) +compileTemplates hs = do + ctm <- compileTemplates' hs + return $! hs { _compiledTemplateMap = ctm } +-- let f = flip evalStateT HE.empty . unRT . codeGen +-- return $! hs { _compiledTemplateMap = H.map (first f) ctm } + + +------------------------------------------------------------------------------ +compileTemplates' :: Monad m + => HeistState m + -> IO (H.HashMap TPath ([Chunk m], MIMEType)) +compileTemplates' hs = do + ctm <- foldM runOne H.empty tpathDocfiles + return $! ctm + where + tpathDocfiles :: [(TPath, DocumentFile)] + tpathDocfiles = map (\(a,b) -> (a, b)) + (H.toList $ _templateMap hs) + + runOne tmap (tpath, df) = do + !mHtml <- compileTemplate hs tpath df + return $! H.insert tpath (mHtml, mimeType $! dfDoc df) tmap + + +------------------------------------------------------------------------------ +-- | Consolidate consecutive Pure Chunks. +consolidate :: (Monad m) => DList (Chunk m) -> [Chunk m] +consolidate = consolidateL . DL.toList + where + consolidateL [] = [] + consolidateL (y:ys) = boilDown [] $! go [] y ys + where + ---------------------------------------------------------------------- + go soFar x [] = x : soFar + + go soFar (Pure a) ((Pure b) : xs) = + go soFar (Pure $! a `mappend` b) xs + + go soFar (RuntimeHtml a) ((RuntimeHtml b) : xs) = + go soFar (RuntimeHtml $! a `mappend` b) xs + + go soFar (RuntimeHtml a) ((RuntimeAction b) : xs) = + go soFar (RuntimeHtml $! a >>= \x -> b >> return x) xs + + go soFar (RuntimeAction a) ((RuntimeHtml b) : xs) = + go soFar (RuntimeHtml $! a >> b) xs + + go soFar (RuntimeAction a) ((RuntimeAction b) : xs) = + go soFar (RuntimeAction $! a >> b) xs + + go soFar a (b : xs) = go (a : soFar) b xs + + ---------------------------------------------------------------------- + boilDown soFar [] = soFar + + boilDown soFar ((Pure h) : xs) = boilDown ((Pure $! h) : soFar) xs + + boilDown soFar (x : xs) = boilDown (x : soFar) xs + + +------------------------------------------------------------------------------ +-- | Given a list of output chunks, consolidate turns consecutive runs of +-- @Pure Html@ values into maximally-efficient pre-rendered strict +-- 'ByteString' chunks. +codeGen :: Monad m => [Chunk m] -> RuntimeSplice m Builder +codeGen l = V.foldr mappend mempty $! V.map toAct $! V.fromList l + where + toAct !(RuntimeHtml !m) = m + toAct !(Pure !h) = return $! fromByteString h + toAct !(RuntimeAction !m) = m >> return mempty +{-# INLINE codeGen #-} + + +------------------------------------------------------------------------------ +-- | Looks up a splice in the compiled splice map. +lookupSplice :: Text -> HeistT n IO (Maybe (Splice n)) +lookupSplice nm = getsHS (H.lookup nm . _compiledSpliceMap) + + +------------------------------------------------------------------------------ +-- | Runs a single node. If there is no splice referenced anywhere in the +-- subtree, then it is rendered as a pure chunk, otherwise it is compiled to +-- a runtime computation. +runNode :: Monad n => X.Node -> Splice n +runNode node = localParamNode (const node) $ do + isStatic <- subtreeIsStatic node + if isStatic + then return $! yieldPure $! + X.renderHtmlFragment X.UTF8 [parseAttrs node] + else compileNode node + + +parseAttrs :: X.Node -> X.Node +parseAttrs (X.Element nm attrs ch) = newAttrs `seq` X.Element nm newAttrs ch + where + newAttrs = map parseAttr attrs +parseAttrs !n = n + +parseAttr :: (Text, Text) -> (Text, Text) +parseAttr (k,v) = (k, T.concat $! map cvt ast) + where + !ast = case AP.feed (AP.parse attParser v) "" of + (AP.Done _ res) -> res + (AP.Fail _ _ _) -> [] + (AP.Partial _ ) -> [] + cvt (Literal x) = x + cvt (Escaped c) = T.singleton c + cvt (Ident _) = error "parseAttrs: impossible case" + +------------------------------------------------------------------------------ +-- | Checks whether a node's subtree is static and can be rendered up front at +-- load time. +subtreeIsStatic :: X.Node -> HeistT n IO Bool +subtreeIsStatic (X.Element nm attrs ch) = do + isNodeDynamic <- liftM isJust $ lookupSplice nm + attrSplices <- getsHS _attrSpliceMap + let hasSubstitutions (k,v) = hasAttributeSubstitutions v || + H.member k attrSplices + if isNodeDynamic + then return False + else do + let hasDynamicAttrs = any hasSubstitutions attrs + if hasDynamicAttrs + then return False + else do + staticSubtrees <- mapM subtreeIsStatic ch + return $ and staticSubtrees + +subtreeIsStatic _ = return True + + +------------------------------------------------------------------------------ +-- | Checks whether a string has any attribute substitutions. +hasAttributeSubstitutions :: Text -> Bool +hasAttributeSubstitutions txt = any isIdent ast + where + ast = case AP.feed (AP.parse attParser txt) "" of + (AP.Done _ res) -> res + (AP.Fail _ _ _) -> [] + (AP.Partial _ ) -> [] + + +------------------------------------------------------------------------------ +-- | +parseAtt :: Monad n => (Text, Text) -> HeistT n IO (DList (Chunk n)) +parseAtt (k,v) = do + mas <- getsHS (H.lookup k . _attrSpliceMap) + maybe doInline (return . doAttrSplice) mas + + where + cvt (Literal x) = return $ yieldPureText x + cvt (Escaped c) = return $ yieldPureText $ T.singleton c + cvt (Ident x) = + localParamNode (const $ X.Element x [] []) $ getAttributeSplice x + + -- Handles inline parsing of $() splice syntax in attributes + doInline = do + let ast = case AP.feed (AP.parse attParser v) "" of + (AP.Done _ res) -> res + (AP.Fail _ _ _) -> [] + (AP.Partial _ ) -> [] + chunks <- mapM cvt ast + let value = DL.concat chunks + return $ attrToChunk k value + + -- Handles attribute splices + doAttrSplice splice = DL.singleton $ RuntimeHtml $ lift $ do + res <- splice v + return $ mconcat $ map attrToBuilder res + + +------------------------------------------------------------------------------ +-- | Given a 'X.Node' in the DOM tree, produces a \"runtime splice\" that will +-- generate html at runtime. Leaves the writer monad state untouched. +compileNode :: Monad n => X.Node -> Splice n +compileNode (X.Element nm attrs ch) = + -- Is this node a splice, or does it merely contain splices? + lookupSplice nm >>= fromMaybe compileStaticElement + where + tag0 = T.append "<" nm + end = T.concat [ ""] + -- If the tag is not a splice, but it contains dynamic children + compileStaticElement = do + -- Parse the attributes: we have Left for static and Right for runtime + compiledAttrs <- mapM parseAtt attrs + + childHtml <- runNodeList ch + + return $! if null (DL.toList childHtml) + then DL.concat [ DL.singleton $! pureTextChunk $! tag0 + , DL.concat compiledAttrs + , DL.singleton $! pureTextChunk " />" + ] + else DL.concat [ DL.singleton $! pureTextChunk $! tag0 + , DL.concat compiledAttrs + , DL.singleton $! pureTextChunk ">" + , childHtml + , DL.singleton $! pureTextChunk $! end + ] +compileNode _ = error "impossible" + + +attrToChunk :: Text -> DList (Chunk n) -> DList (Chunk n) +attrToChunk !k !v = do + DL.concat + [ DL.singleton $! pureTextChunk $! T.concat [" ", k, "=\""] + , v, DL.singleton $! pureTextChunk "\"" ] + + +attrToBuilder :: (Text, Text) -> Builder +attrToBuilder (k,v) + | T.null v = mconcat + [ fromByteString $! T.encodeUtf8 " " + , fromByteString $! T.encodeUtf8 k + ] + | otherwise = mconcat + [ fromByteString $! T.encodeUtf8 " " + , fromByteString $! T.encodeUtf8 k + , fromByteString $! T.encodeUtf8 "=\"" + , fromByteString $! T.encodeUtf8 v + , fromByteString $! T.encodeUtf8 "\"" + ] + + +------------------------------------------------------------------------------ +getAttributeSplice :: Text -> HeistT n IO (DList (Chunk n)) +getAttributeSplice name = + lookupSplice name >>= fromMaybe (return DL.empty) +{-# INLINE getAttributeSplice #-} + + +------------------------------------------------------------------------------ +-- | Promises are used for referencing the results of future runtime +-- computations during load time splice processing. +newtype Promise a = Promise (HE.Key a) + + +------------------------------------------------------------------------------ +-- | Gets the result of a promised runtime computation. +getPromise :: (Monad m) => Promise a -> RuntimeSplice m a +getPromise (Promise k) = do + mb <- gets (HE.lookup k) + return $ fromMaybe e mb + + where + e = error $ "getPromise: dereferenced empty key (id " + ++ show (HE.getKeyId k) ++ ")" +{-# INLINE getPromise #-} + + +------------------------------------------------------------------------------ +-- | Adds a promise to the runtime splice context. +putPromise :: (Monad m) => Promise a -> a -> RuntimeSplice m () +putPromise (Promise k) x = modify (HE.insert k x) +{-# INLINE putPromise #-} + + +------------------------------------------------------------------------------ +-- | Modifies a promise. +adjustPromise :: Monad m => Promise a -> (a -> a) -> RuntimeSplice m () +adjustPromise (Promise k) f = modify (HE.adjust f k) +{-# INLINE adjustPromise #-} + + +------------------------------------------------------------------------------ +-- | Creates an empty promise. +newEmptyPromise :: HeistT n IO (Promise a) +newEmptyPromise = do + keygen <- getsHS _keygen + key <- liftIO $ HE.makeKey keygen + return $! Promise key +{-# INLINE newEmptyPromise #-} + + +-- ------------------------------------------------------------------------------ +-- -- | Creates an empty promise with some error checking to help with debugging. +-- newEmptyPromiseWithError :: (Monad n) +-- => String -> HeistT n IO (Promise a) +-- newEmptyPromiseWithError from = do +-- keygen <- getsHS _keygen +-- prom <- liftM Promise $ liftIO $ HE.makeKey keygen +-- yieldRuntimeEffect $ putPromise prom +-- $ error +-- $ "deferenced empty promise created at" ++ from +-- return prom +-- {-# INLINE newEmptyPromiseWithError #-} +-- +-- +-- ------------------------------------------------------------------------------ +-- -- | Creates a promise for a future runtime computation. +-- promise :: (Monad n) => n a -> HeistT n IO (Promise a) +-- promise act = runtimeSplicePromise (lift act) +-- {-# INLINE promise #-} +-- +-- +-- ------------------------------------------------------------------------------ +-- -- | Turns a RuntimeSplice computation into a promise. +-- runtimeSplicePromise :: (Monad n) +-- => RuntimeSplice n a +-- -> HeistT n IO (Promise a) +-- runtimeSplicePromise act = do +-- prom <- newEmptyPromiseWithError "runtimeSplicePromise" +-- +-- let m = do +-- x <- act +-- putPromise prom x +-- return () +-- +-- yieldRuntimeEffect m +-- return prom +-- {-# INLINE runtimeSplicePromise #-} +-- +-- +-- ------------------------------------------------------------------------------ +-- -- | Sets up a runtime transformation on a 'Promise'. +-- withPromise :: (Monad n) +-- => Promise a +-- -> (a -> n b) +-- -> HeistT n IO (Promise b) +-- withPromise promA f = do +-- promB <- newEmptyPromiseWithError "withPromise" +-- +-- let m = do +-- a <- getPromise promA +-- b <- lift $ f a +-- putPromise promB b +-- return () +-- +-- yieldRuntimeEffect m +-- return promB +-- {-# INLINE withPromise #-} + + +------------------------------------------------------------------------------ +-- | Binds a compiled splice. This function should not be exported. +bindSplice :: Text -- ^ tag name + -> Splice n -- ^ splice action + -> HeistState n -- ^ source state + -> HeistState n +bindSplice n v ts = + ts { _compiledSpliceMap = H.insert n v (_compiledSpliceMap ts) } + + +------------------------------------------------------------------------------ +-- | Binds a list of compiled splices. This function should not be exported. +bindSplices :: [(Text, Splice n)] -- ^ splices to bind + -> HeistState n -- ^ source state + -> HeistState n +bindSplices ss ts = foldr (uncurry bindSplice) ts ss + + +------------------------------------------------------------------------------ +-- | Adds a list of compiled splices to the splice map. This function is +-- useful because it allows compiled splices to bind other compiled splices +-- during load-time splice processing. +addSplices :: Monad m => [(Text, Splice n)] -> HeistT n m () +addSplices ss = modifyHS (bindSplices ss) + + +------------------------------------------------------------------------------ +-- | Looks up a compiled template and returns a runtime monad computation that +-- constructs a builder. +renderTemplate :: Monad n + => HeistState n + -> ByteString + -> Maybe (n Builder, MIMEType) +renderTemplate hs nm = + fmap (first interpret . fst) $! lookupTemplate nm hs _compiledTemplateMap + +interpret :: Monad m => [Chunk m] -> m Builder +interpret = flip evalStateT HE.empty . unRT . codeGen + + diff --git a/src/Heist/Interpreted.hs b/src/Heist/Interpreted.hs new file mode 100644 --- /dev/null +++ b/src/Heist/Interpreted.hs @@ -0,0 +1,80 @@ +{-| + +This module defines the API for writing and working with interpreted splices. +It exports some of the same symbols as "Heist.Compiled", so you will probably +want to import it qualified. + +Interpreted splices can be thought of as a function @Node -> m [Node]@. Heist +then substitutes the resulting list of nodes into your template in place of +the input node. 'Splice' is implemented as a type synonym @type Splice m = +HeistT m [Node]@, and 'HeistT' has a function 'getParamNode' that lets you get +the input node. + +Suppose you have a place on your page where you want to display a link with +the text \"Logout username\" if the user is currently logged in or a link to +the login page if no user is logged in. Assume you have a function +@getUser :: MyAppMonad (Maybe Text)@ that gets the current user. +You can implement this functionality with a 'Splice' as follows: + +> import Blaze.ByteString.Builder +> import Data.ByteString.Char8 (ByteString) +> import qualified Data.ByteString.Char8 as B +> import Data.Text (Text) +> import qualified Data.Text as T +> import qualified Text.XmlHtml as X +> +> import qualified Heist.Interpreted as I +> +> link :: Text -> Text -> X.Node +> link target text = X.Element "a" [("href", target)] [X.TextNode text] +> +> loginLink :: X.Node +> loginLink = link "/login" "Login" +> +> logoutLink :: Text -> X.Node +> logoutLink user = link "/logout" (T.append "Logout " user) +> +> loginLogoutSplice :: I.Splice MyAppMonad +> loginLogoutSplice = do +> user <- lift getUser +> return [maybe loginLink logoutLink user] +> + +-} + +module Heist.Interpreted + ( + Splice + + -- * HeistState Functions + , addTemplate + , addXMLTemplate + , lookupSplice + , bindSplice + , bindSplices + + -- * Functions for creating splices + , textSplice + , runChildren + , runChildrenWith + , runChildrenWithTrans + , runChildrenWithTemplates + , runChildrenWithText + , mapSplices + + -- * HeistT functions + , stopRecursion + , runNode + , runNodeList + , evalTemplate + , bindStrings + , bindString + , callTemplate + , callTemplateWithText + , renderTemplate + , renderWithArgs + ) where + +import Heist.Interpreted.Internal +import Heist.Common (mapSplices) + diff --git a/src/Heist/Interpreted/Internal.hs b/src/Heist/Interpreted/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Heist/Interpreted/Internal.hs @@ -0,0 +1,427 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Heist.Interpreted.Internal where + +------------------------------------------------------------------------------ +import Blaze.ByteString.Builder +import Control.Arrow hiding (loop) +import Control.Monad +import Control.Monad.Trans +import qualified Data.Attoparsec.Text as AP +import Data.ByteString (ByteString) +import Data.List +import qualified Data.HashMap.Strict as Map +import Data.Maybe +import Data.Monoid +import qualified Data.Text as T +import Data.Text (Text) +import Prelude hiding (catch) +import qualified Text.XmlHtml as X + +------------------------------------------------------------------------------ +import Heist.Common +import Heist.Types + + +type Splice n = HeistT n n Template + + +------------------------------------------------------------------------------ +-- | Mappends a doctype to the state. +addDoctype :: Monad m => [X.DocType] -> HeistT n m () +addDoctype dt = do + modifyHS (\s -> s { _doctypes = _doctypes s `mappend` dt }) + + +------------------------------------------------------------------------------ +-- HeistState functions +------------------------------------------------------------------------------ + + +------------------------------------------------------------------------------ +-- | Binds a new splice declaration to a tag name within a 'HeistState'. +bindSplice :: Text -- ^ tag name + -> Splice n -- ^ splice action + -> HeistState n -- ^ source state + -> HeistState n +bindSplice n v ts = ts {_spliceMap = Map.insert n v (_spliceMap ts)} + + +------------------------------------------------------------------------------ +-- | Binds a set of new splice declarations within a 'HeistState'. +bindSplices :: [(Text, Splice n)] -- ^ splices to bind + -> HeistState n -- ^ start state + -> HeistState n +bindSplices ss ts = foldl' (flip id) ts acts + where + acts = map (uncurry bindSplice) ss + + +------------------------------------------------------------------------------ +-- | Converts 'Text' to a splice returning a single 'TextNode'. +textSplice :: Monad n => Text -> Splice n +textSplice t = return [X.TextNode t] + + +------------------------------------------------------------------------------ +-- | Runs the parameter node's children and returns the resulting node list. +-- By itself this function is a simple passthrough splice that makes the +-- spliced node disappear. In combination with locally bound splices, this +-- function makes it easier to pass the desired view into your splices. +runChildren :: Monad n => Splice n +runChildren = runNodeList . X.childNodes =<< getParamNode + + +------------------------------------------------------------------------------ +-- | Binds a list of splices before using the children of the spliced node as +-- a view. +runChildrenWith :: (Monad n) + => [(Text, Splice n)] + -- ^ List of splices to bind before running the param nodes. + -> Splice n + -- ^ Returns the passed in view. +runChildrenWith splices = localHS (bindSplices splices) runChildren + + +------------------------------------------------------------------------------ +-- | Wrapper around runChildrenWith that applies a transformation function to +-- the second item in each of the tuples before calling runChildrenWith. +runChildrenWithTrans :: (Monad n) + => (b -> Splice n) + -- ^ Splice generating function + -> [(Text, b)] + -- ^ List of tuples to be bound + -> Splice n +runChildrenWithTrans f = runChildrenWith . map (second f) + + +------------------------------------------------------------------------------ +-- | Like runChildrenWith but using constant templates rather than dynamic +-- splices. +runChildrenWithTemplates :: (Monad n) => [(Text, Template)] -> Splice n +runChildrenWithTemplates = runChildrenWithTrans return + + +------------------------------------------------------------------------------ +-- | Like runChildrenWith but using literal text rather than dynamic splices. +runChildrenWithText :: (Monad n) => [(Text, Text)] -> Splice n +runChildrenWithText = runChildrenWithTrans textSplice + + +------------------------------------------------------------------------------ +-- | Convenience function for looking up a splice. +lookupSplice :: Text + -> HeistState n + -> Maybe (Splice n) +lookupSplice nm ts = Map.lookup nm $ _spliceMap ts +{-# INLINE lookupSplice #-} + + +------------------------------------------------------------------------------ +-- | Adds an HTML format template to the heist state. +addTemplate :: ByteString + -- ^ Path that the template will be referenced by + -> Template + -- ^ The template's DOM nodes + -> Maybe FilePath + -- ^ An optional path to the actual file on disk where the + -- template is stored + -> HeistState n + -> HeistState n +addTemplate n t mfp st = + insertTemplate (splitTemplatePath n) doc st + where + doc = DocumentFile (X.HtmlDocument X.UTF8 Nothing t) mfp + + +------------------------------------------------------------------------------ +-- | Adds an XML format template to the heist state. +addXMLTemplate :: ByteString + -- ^ Path that the template will be referenced by + -> Template + -- ^ The template's DOM nodes + -> Maybe FilePath + -- ^ An optional path to the actual file on disk where the + -- template is stored + -> HeistState n + -> HeistState n +addXMLTemplate n t mfp st = + insertTemplate (splitTemplatePath n) doc st + where + doc = DocumentFile (X.XmlDocument X.UTF8 Nothing t) mfp + + +------------------------------------------------------------------------------ +-- | Stops the recursive processing of splices. Consider the following +-- example: +-- +-- > +-- > +-- > ... +-- > +-- > +-- +-- Assume that @\"foo\"@ is bound to a splice procedure. Running the @foo@ +-- splice will result in a list of nodes @L@. Normally @foo@ will recursively +-- scan @L@ for splices and run them. If @foo@ calls @stopRecursion@, @L@ +-- will be included in the output verbatim without running any splices. +stopRecursion :: Monad m => HeistT n m () +stopRecursion = modifyHS (\st -> st { _recurse = False }) + + +------------------------------------------------------------------------------ +-- | Performs splice processing on a single node. +runNode :: Monad n => X.Node -> Splice n +runNode (X.Element nm at ch) = do + newAtts <- (return . concat) =<< mapM runAttrSplice at + let n = X.Element nm newAtts ch + s <- liftM (lookupSplice nm) getHS + maybe (runKids newAtts) (recurseSplice n) s + where + runKids newAtts = do + newKids <- runNodeList ch + return [X.Element nm newAtts newKids] +runNode n = return [n] + + +------------------------------------------------------------------------------ +-- | Runs the attribute splice if it exists, otherwise it does inline $() +-- substitution. +runAttrSplice :: (Monad n) => (Text, Text) -> HeistT n n [(Text, Text)] +runAttrSplice a@(k,v) = do + splice <- getsHS (Map.lookup k . _attrSpliceMap) + maybe (liftM (:[]) $ attSubst a) (lift . ($v)) splice + + +------------------------------------------------------------------------------ +-- | Helper function for substituting a parsed attribute into an attribute +-- tuple. +attSubst :: (Monad n) => (t, Text) -> HeistT n n (t, Text) +attSubst (n,v) = do + v' <- parseAtt v + return (n,v') + + +------------------------------------------------------------------------------ +-- | Parses an attribute for any identifier expressions and performs +-- appropriate substitution. +parseAtt :: (Monad n) => Text -> HeistT n n Text +parseAtt bs = do + let ast = case AP.feed (AP.parse attParser bs) "" of + (AP.Done _ res) -> res + (AP.Fail _ _ _) -> [] + (AP.Partial _) -> [] + chunks <- mapM cvt ast + return $ T.concat chunks + where + cvt (Literal x) = return x + cvt (Escaped c) = renderEscaped c + cvt (Ident x) = + localParamNode (const $ X.Element x [] []) $ getAttributeSplice x + + renderEscaped c = do + hs <- getHS + if _preprocessingMode hs + then return $ T.snoc "\\" c + else return $ T.singleton c + + +------------------------------------------------------------------------------ +-- | Gets the attribute value. If the splice's result list contains non-text +-- nodes, this will translate them into text nodes with nodeText and +-- concatenate them together. +-- +-- Originally, this only took the first node from the splices's result list, +-- and only if it was a text node. This caused problems when the splice's +-- result contained HTML entities, as they would split a text node. This was +-- then fixed to take the first consecutive bunch of text nodes, and return +-- their concatenation. This was seen as more useful than throwing an error, +-- and more intuitive than trying to render all the nodes as text. +-- +-- However, it was decided in the end to render all the nodes as text, and +-- then concatenate them. If a splice returned +-- \"some \text\<\/b\> foobar\", the user would almost certainly want +-- \"some text foobar\" to be rendered, and Heist would probably seem +-- annoyingly limited for not being able to do this. If the user really did +-- want it to render \"some \", it would probably be easier for them to +-- accept that they were silly to pass more than that to be substituted than +-- it would be for the former user to accept that +-- \"some \text\<\/b\> foobar\" is being rendered as \"some \" because +-- it's \"more intuitive\". +getAttributeSplice :: Monad n => Text -> HeistT n n Text +getAttributeSplice name = do + hs <- getHS + let noSplice = if _preprocessingMode hs + then return $ T.concat ["${", name, "}"] + else return "" + let s = lookupSplice name hs + maybe noSplice (liftM (T.concat . map X.nodeText)) s + +------------------------------------------------------------------------------ +-- | Performs splice processing on a list of nodes. +runNodeList :: Monad n => [X.Node] -> Splice n +runNodeList = mapSplices runNode +{-# INLINE runNodeList #-} + + +------------------------------------------------------------------------------ +-- | The maximum recursion depth. (Used to prevent infinite loops.) +mAX_RECURSION_DEPTH :: Int +mAX_RECURSION_DEPTH = 50 + + +------------------------------------------------------------------------------ +-- | Checks the recursion flag and recurses accordingly. Does not recurse +-- deeper than mAX_RECURSION_DEPTH to avoid infinite loops. +recurseSplice :: Monad n => X.Node -> Splice n -> Splice n +recurseSplice node splice = do + result <- localParamNode (const node) splice + hs <- getHS + if _recurse hs + then if _recursionDepth hs < mAX_RECURSION_DEPTH + then do modRecursionDepth (+1) + res <- runNodeList result + restoreHS hs + return res + else return result `orError` err + else return result + where + err = unwords + ["Recursion limit reached in node" + ,"<"++(T.unpack $ X.elementTag node)++">. You" + ,"probably have infinite splice recursion!" + ] + + + +------------------------------------------------------------------------------ +-- | Looks up a template name runs a 'HeistT' computation on it. +lookupAndRun :: Monad m + => ByteString + -> ((DocumentFile, TPath) -> HeistT n m (Maybe a)) + -> HeistT n m (Maybe a) +lookupAndRun name k = do + ts <- getHS + let mt = lookupTemplate name ts _templateMap + let curPath = join $ fmap (dfFile . fst) mt + modifyHS (setCurTemplateFile curPath) + maybe (return Nothing) k mt + + +------------------------------------------------------------------------------ +-- | Looks up a template name evaluates it by calling runNodeList. +evalTemplate :: Monad n + => ByteString + -> HeistT n n (Maybe Template) +evalTemplate name = lookupAndRun name + (\(t,ctx) -> localHS (\ts -> ts {_curContext = ctx}) + (liftM Just $ runNodeList $ X.docContent $ dfDoc t)) + + +------------------------------------------------------------------------------ +-- | Sets the document type of a 'X.Document' based on the 'HeistT' +-- value. +fixDocType :: Monad m => X.Document -> HeistT n m X.Document +fixDocType d = do + dts <- getsHS _doctypes + return $ d { X.docType = listToMaybe dts } + + +------------------------------------------------------------------------------ +-- | Runs a template and sets the doctype properly. This is the right thing +-- to do if we are starting at the top level. +evalWithDoctypes :: Monad n + => ByteString + -> HeistT n n (Maybe X.Document) +evalWithDoctypes name = lookupAndRun name $ \(t,ctx) -> do + addDoctype $ maybeToList $ X.docType $ dfDoc t + ts <- getHS + let nodes = X.docContent $ dfDoc t + putHS (ts {_curContext = ctx}) + newNodes <- runNodeList nodes + restoreHS ts + newDoc <- fixDocType $ (dfDoc t) { X.docContent = newNodes } + return (Just newDoc) + + +------------------------------------------------------------------------------ +-- | Binds a list of constant string splices. +bindStrings :: Monad n + => [(Text, Text)] + -> HeistState n + -> HeistState n +bindStrings pairs ts = foldr (uncurry bindString) ts pairs + + +------------------------------------------------------------------------------ +-- | Binds a single constant string splice. +bindString :: Monad n + => Text + -> Text + -> HeistState n + -> HeistState n +bindString n = bindSplice n . textSplice + + +------------------------------------------------------------------------------ +-- | Renders a template with the specified parameters. This is the function +-- to use when you want to "call" a template and pass in parameters from +-- inside a splice. If the template does not exist, this version simply +-- returns an empty list. +callTemplate :: Monad n + => ByteString -- ^ The name of the template + -> [(Text, Splice n)] -- ^ Association list of + -- (name,value) parameter pairs + -> HeistT n n Template +callTemplate name params = do + modifyHS $ bindSplices params + liftM (maybe [] id) $ evalTemplate name + + +------------------------------------------------------------------------------ +-- | Like callTemplate except the splices being bound are constant text +-- splices. +callTemplateWithText :: Monad n + => ByteString -- ^ The name of the template + -> [(Text, Text)] -- ^ Association list of + -- (name,value) parameter pairs + -> HeistT n n Template +callTemplateWithText name params = do + modifyHS $ bindStrings params + liftM (maybe [] id) $ evalTemplate name + + +------------------------------------------------------------------------------ +-- | Renders a template from the specified HeistState to a 'Builder'. The +-- MIME type returned is based on the detected character encoding, and whether +-- the root template was an HTML or XML format template. It will always be +-- @text/html@ or @text/xml@. If a more specific MIME type is needed for a +-- particular XML application, it must be provided by the application. +renderTemplate :: Monad n + => HeistState n + -> ByteString + -> n (Maybe (Builder, MIMEType)) +renderTemplate ts name = evalHeistT tpl (X.TextNode "") ts + where tpl = do mt <- evalWithDoctypes name + case mt of + Nothing -> return Nothing + Just doc -> return $ Just $ (X.render doc, mimeType doc) + + +------------------------------------------------------------------------------ +-- | Renders a template with the specified arguments passed to it. This is a +-- convenience function for the common pattern of calling renderTemplate after +-- using bindString, bindStrings, or bindSplice to set up the arguments to the +-- template. +renderWithArgs :: Monad n + => [(Text, Text)] + -> HeistState n + -> ByteString + -> n (Maybe (Builder, MIMEType)) +renderWithArgs args ts = renderTemplate (bindStrings args ts) + + diff --git a/src/Heist/Splices.hs b/src/Heist/Splices.hs new file mode 100644 --- /dev/null +++ b/src/Heist/Splices.hs @@ -0,0 +1,16 @@ +module Heist.Splices + ( module Heist.Splices.Apply + , module Heist.Splices.Bind + , module Heist.Splices.Cache + , module Heist.Splices.Html + , module Heist.Splices.Ignore + , module Heist.Splices.Markdown + ) where + +import Heist.Splices.Apply +import Heist.Splices.Bind +import Heist.Splices.Cache +import Heist.Splices.Html +import Heist.Splices.Ignore +import Heist.Splices.Markdown + diff --git a/src/Heist/Splices/Apply.hs b/src/Heist/Splices/Apply.hs new file mode 100644 --- /dev/null +++ b/src/Heist/Splices/Apply.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +module Heist.Splices.Apply where + +------------------------------------------------------------------------------ +import Control.Monad.Trans +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Text.XmlHtml as X + +------------------------------------------------------------------------------ +import Heist.Common +import Heist.Interpreted.Internal +import Heist.Types + + +------------------------------------------------------------------------------ +-- | Default name for the apply splice. +applyTag :: Text +applyTag = "apply" + + +------------------------------------------------------------------------------ +-- | Default attribute name for the apply tag. +applyAttr :: Text +applyAttr = "template" + + +------------------------------------------------------------------------------ +-- | +rawApply :: (Monad n) + => Text + -> [X.Node] + -> Maybe FilePath + -> TPath + -> [X.Node] + -> Splice n +rawApply paramTag calledNodes templateFile newContext paramNodes = do + hs <- getHS -- Can't use localHS here because the modifier is not pure + processedParams <- runNodeList paramNodes + + -- apply should do a bottom-up traversal, so we run the called nodes + -- before doing substitution. + modifyHS (setCurContext newContext . setCurTemplateFile templateFile) + + let process = concatMap (treeMap processedParams) + if _recursionDepth hs < mAX_RECURSION_DEPTH + then do modRecursionDepth (+1) + res <- runNodeList calledNodes + restoreHS hs + return $! process res + else do restoreHS hs + (return []) `orError` err + where + err = "template recursion exceeded max depth, "++ + "you probably have infinite splice recursion!" + treeMap :: [X.Node] -> X.Node -> [X.Node] + treeMap ns n@(X.Element nm _ cs) + | nm == paramTag = ns + | otherwise = [n { X.elementChildren = cs' }] + where + !cs' = concatMap (treeMap ns) cs + treeMap _ n = [n] + + +------------------------------------------------------------------------------ +-- | Applies a template as if the supplied nodes were the children of the +-- tag. +applyNodes :: MonadIO n => Template -> Text -> Splice n +applyNodes nodes template = do + hs <- getHS + maybe (return [] `orError` err) + (\(t,ctx) -> do + addDoctype $ maybeToList $ X.docType $ dfDoc t + rawApply "apply-content" (X.docContent $ dfDoc t) + (dfFile t) ctx nodes) + (lookupTemplate (T.encodeUtf8 template) hs _templateMap) + where + err = "apply tag cannot find template \""++(T.unpack template)++"\"" + + +------------------------------------------------------------------------------ +-- | Implementation of the apply splice. +applyImpl :: MonadIO n => Splice n +applyImpl = do + node <- getParamNode + let err = "must supply \"" ++ T.unpack applyAttr ++ + "\" attribute in <" ++ T.unpack (X.elementTag node) ++ ">" + case X.getAttribute applyAttr node of + Nothing -> return [] `orError` err + Just template -> applyNodes (X.childNodes node) template + + +deprecatedContentCheck :: Monad m => Splice m +deprecatedContentCheck = + return [] `orError` unwords + [" tag deprecated. Use" + ," or " + ] + diff --git a/src/Heist/Splices/Bind.hs b/src/Heist/Splices/Bind.hs new file mode 100644 --- /dev/null +++ b/src/Heist/Splices/Bind.hs @@ -0,0 +1,43 @@ +module Heist.Splices.Bind where + +------------------------------------------------------------------------------ +import Control.Monad.Trans +import Data.Text (Text) +import qualified Data.Text as T +import qualified Text.XmlHtml as X + +------------------------------------------------------------------------------ +import Heist.Common +import Heist.Interpreted.Internal +import Heist.Splices.Apply +import Heist.Types + +-- | Default name for the bind splice. +bindTag :: Text +bindTag = "bind" + + +------------------------------------------------------------------------------ +-- | Default attribute name for the bind tag. +bindAttr :: Text +bindAttr = "tag" + + +------------------------------------------------------------------------------ +-- | Implementation of the bind splice. +bindImpl :: MonadIO n => Splice n +bindImpl = do + node <- getParamNode + let err = "must supply \"" ++ T.unpack bindAttr ++ + "\" attribute in <" ++ T.unpack (X.elementTag node) ++ ">" + maybe (return () `orError` err) + (add node) + (X.getAttribute bindAttr node) + return [] + where + add node nm = modifyHS $ bindSplice nm $ do + caller <- getParamNode + ctx <- getContext + rawApply "bind-content" (X.childNodes node) + Nothing ctx (X.childNodes caller) + diff --git a/src/Heist/Splices/BindStrict.hs b/src/Heist/Splices/BindStrict.hs new file mode 100644 --- /dev/null +++ b/src/Heist/Splices/BindStrict.hs @@ -0,0 +1,37 @@ +module Heist.Splices.BindStrict where + +------------------------------------------------------------------------------ +import Control.Monad.Trans +import Data.Text (Text) +import qualified Data.Text as T +import qualified Text.XmlHtml as X + +------------------------------------------------------------------------------ +import Heist.Common +import Heist.Interpreted.Internal +import Heist.Splices.Apply +import Heist.Splices.Bind +import Heist.Types + +-- | Default name for the bind splice. +bindStrictTag :: Text +bindStrictTag = "bindStrict" + + +------------------------------------------------------------------------------ +-- | Implementation of the bind splice. +bindStrictImpl :: MonadIO n => Splice n +bindStrictImpl = do + node <- getParamNode + cs <- runChildren + let err = "must supply \"" ++ T.unpack bindAttr ++ + "\" attribute in <" ++ T.unpack (X.elementTag node) ++ ">" + maybe (return () `orError` err) (add cs) + (X.getAttribute bindAttr node) + return [] + + where + add cs nm = modifyHS $ bindSplice nm $ do + caller <- getParamNode + ctx <- getContext + rawApply "bindstrict-content" cs Nothing ctx (X.childNodes caller) diff --git a/src/Heist/Splices/Cache.hs b/src/Heist/Splices/Cache.hs new file mode 100644 --- /dev/null +++ b/src/Heist/Splices/Cache.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | The \"cache\" splice ensures that its contents are cached and only +-- evaluated periodically. The cached contents are returned every time the +-- splice is referenced. +-- +-- Use the ttl attribute to set the amount of time between reloads. The ttl +-- value should be a positive integer followed by a single character +-- specifying the units. Valid units are a single letter abbreviation for one +-- of seconds, minutes, hours, days, and weeks. If the ttl string is invalid +-- or the ttl attribute is not specified, the cache is never refreshed unless +-- explicitly cleared with clearCacheTagState. The compiled splice version of +-- the cache tag does not require a cache tag state, so clearCacheTagState +-- will not work for compiled cache tags. + +module Heist.Splices.Cache + ( CacheTagState + , cacheImpl + , cacheImplCompiled + , mkCacheTag + , clearCacheTagState + ) where + +------------------------------------------------------------------------------ +import Blaze.ByteString.Builder +import Control.Concurrent +import Control.Monad +import Control.Monad.Trans +import Data.IORef +import qualified Data.HashMap.Strict as H +import Data.HashMap.Strict (HashMap) +import qualified Data.HashSet as Set +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Read +import Data.Time.Clock +import Data.Word +import System.Random +import Text.XmlHtml + + +------------------------------------------------------------------------------ +import qualified Heist.Compiled.Internal as C +import Heist.Interpreted.Internal +import Heist.Types + + +------------------------------------------------------------------------------ +cacheTagName :: Text +cacheTagName = "cache" + + +------------------------------------------------------------------------------ +-- | State for storing cache tag information +newtype CacheTagState = + CTS (MVar ([IORef (Maybe (UTCTime, Builder))], HashMap Text (UTCTime, Template))) + + +addCompiledRef :: IORef (Maybe (UTCTime, Builder)) -> CacheTagState -> IO () +addCompiledRef ref (CTS mv) = do + modifyMVar_ mv (\(a,b) -> return (ref:a, b)) + + +------------------------------------------------------------------------------ +-- | Clears the cache tag state. +clearCacheTagState :: CacheTagState -> IO () +clearCacheTagState (CTS cacheMVar) = do + refs <- modifyMVar cacheMVar (\(a,_) -> return ((a, H.empty), a)) + mapM_ (\ref -> writeIORef ref Nothing) refs + + +------------------------------------------------------------------------------ +-- | Converts a TTL string into an integer number of seconds. +parseTTL :: Text -> Int +parseTTL s = value * multiplier + where + (value,rest) = either (const (0::Int,"s")) id $ decimal s + multiplier = case T.take 1 rest of + "s" -> 1 :: Int + "m" -> 60 + "h" -> 3600 + "d" -> 86400 + "w" -> 604800 + _ -> 1 + + +getTTL :: Node -> NominalDiffTime +getTTL tree = fromIntegral $ maybe 0 parseTTL $ getAttribute "ttl" tree +{-# INLINE getTTL #-} + + +------------------------------------------------------------------------------ +-- | This is the splice that actually does the work. You should bind it to +-- the same tag name as you bound the splice returned by mkCacheTag otherwise +-- it won't work and you'll get runtime errors. +cacheImpl :: (MonadIO n) => CacheTagState -> Splice n +cacheImpl (CTS mv) = do + tree <- getParamNode + let err = error $ unwords ["cacheImpl is bound to a tag" + ,"that didn't get an id attribute." + ," This should never happen."] + let i = maybe err id $ getAttribute "id" tree + !ttl = getTTL tree + mp <- liftIO $ readMVar mv + + ns <- do + cur <- liftIO getCurrentTime + let mbn = H.lookup i $ snd mp + reload = do + nodes' <- runNodeList $ childNodes tree + let newMap = H.insert i (cur, nodes') $ snd mp + liftIO $ modifyMVar_ mv (\(a,_) -> return (a, newMap)) + return $! nodes' + case mbn of + Nothing -> reload + (Just (lastUpdate,n)) -> do + if ttl > 0 && tagName tree == Just cacheTagName && + diffUTCTime cur lastUpdate > ttl + then reload + else do + stopRecursion + return $! n + + return ns + + +------------------------------------------------------------------------------ +-- | This is the compiled splice version of cacheImpl. +cacheImplCompiled :: (MonadIO n) => CacheTagState -> C.Splice n +cacheImplCompiled cts = do + tree <- getParamNode + let !ttl = getTTL tree + + compiled <- C.runNodeList $ childNodes tree + ref <- liftIO $ newIORef Nothing + liftIO $ addCompiledRef ref cts + let reload curTime = do + builder <- C.codeGen $! C.consolidate compiled + let out = fromByteString $! toByteString $! builder + liftIO $ writeIORef ref (Just (curTime, out)) + return $! out + return $ C.yieldRuntime $ do + mbn <- liftIO $ readIORef ref + cur <- liftIO getCurrentTime + case mbn of + Nothing -> reload cur + (Just (lastUpdate,bs)) -> do + if (ttl > 0 && diffUTCTime cur lastUpdate > ttl) + then reload cur + else return $! bs + + +------------------------------------------------------------------------------ +-- | Returns items necessary to set up a \"cache\" tag. The cache tag cannot +-- be bound automatically with the other default Heist tags. This is because +-- this function also returns CacheTagState, so the user will be able to clear +-- it with the 'clearCacheTagState' function. +-- +-- This function returns a splice and a CacheTagState. The splice is of type +-- @Splice IO@ because it has to be bound as a load time preprocessing splice. +-- Haskell's type system won't allow you to screw up and pass this splice as +-- the wrong argument to initHeist. +mkCacheTag :: IO (Splice IO, CacheTagState) +mkCacheTag = do + sr <- newIORef $ Set.empty + mv <- liftM CTS $ newMVar ([], H.empty) + + return $ (setupSplice sr, mv) + + +------------------------------------------------------------------------------ +-- | Explicit type signature to avoid the Show polymorphism problem. +generateId :: IO Word +generateId = getStdRandom random + + +------------------------------------------------------------------------------ +-- | Gets a unique ID for use in the cache tags. +getId :: IORef (Set.HashSet Text) -> IO Text +getId setref = do + i <- liftM (T.pack . show) generateId + _set <- readIORef setref + if Set.member i _set + then getId setref + else do + writeIORef setref $ Set.insert i _set + return $ T.append "cache-id-" i + + +------------------------------------------------------------------------------ +-- | A splice that sets the id attribute so that nodes can be cache-aware. +setupSplice :: IORef (Set.HashSet Text) -> Splice IO +setupSplice setref = do + i <- liftIO $ getId setref + node <- getParamNode + + newChildren <- runNodeList $ childNodes node + stopRecursion + return $ [setAttribute "id" i $ node { elementChildren = newChildren }] + + diff --git a/src/Heist/Splices/Html.hs b/src/Heist/Splices/Html.hs new file mode 100644 --- /dev/null +++ b/src/Heist/Splices/Html.hs @@ -0,0 +1,47 @@ +module Heist.Splices.Html where + +------------------------------------------------------------------------------ +import Data.Maybe +import Data.Text (Text) +import qualified Text.XmlHtml as X + +------------------------------------------------------------------------------ +import Heist.Interpreted.Internal +import Heist.Types + + +------------------------------------------------------------------------------ +-- | Name for the html splice. +htmlTag :: Text +htmlTag = "html" + + +------------------------------------------------------------------------------ +-- | The html splice runs all children and then traverses the returned node +-- forest removing all head nodes. Then it merges them all and prepends it to +-- the html tag's child list. +htmlImpl :: Monad n => Splice n +htmlImpl = do + node <- getParamNode + children <- runNodeList $ X.childNodes node + let (heads, mnode) = extractHeads $ node { X.elementChildren = children } + new (X.Element t a c) = X.Element t a $ + X.Element "head" [] heads : c + new n = n + stopRecursion + return [maybe node new mnode] + +------------------------------------------------------------------------------ +-- | Extracts all heads from a node tree. +extractHeads :: X.Node + -- ^ The root (html) node + -> ([X.Node], Maybe X.Node) + -- ^ A tuple of a list of head nodes and the original tree with + -- heads removed. +extractHeads (X.Element t a c) + | t == "head" = (c, Nothing) + | otherwise = (concat heads, Just $ X.Element t a (catMaybes mcs)) + where + (heads, mcs) = unzip $ map extractHeads c +extractHeads n = ([], Just n) + diff --git a/src/Heist/Splices/Ignore.hs b/src/Heist/Splices/Ignore.hs new file mode 100644 --- /dev/null +++ b/src/Heist/Splices/Ignore.hs @@ -0,0 +1,22 @@ +module Heist.Splices.Ignore where + +------------------------------------------------------------------------------ +import Data.Text (Text) + +------------------------------------------------------------------------------ +import Heist.Interpreted.Internal + + +------------------------------------------------------------------------------ +-- | Default name for the ignore splice. +ignoreTag :: Text +ignoreTag = "ignore" + + +------------------------------------------------------------------------------ +-- | The ignore tag and everything it surrounds disappears in the +-- rendered output. +ignoreImpl :: Monad m => Splice m +ignoreImpl = return [] + + diff --git a/src/Heist/Splices/Json.hs b/src/Heist/Splices/Json.hs new file mode 100644 --- /dev/null +++ b/src/Heist/Splices/Json.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Heist.Splices.Json ( + bindJson +) where + +------------------------------------------------------------------------------ +import Control.Monad.Reader +import Data.Aeson +import Data.Attoparsec.Number +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy.Char8 as L +import qualified Data.HashMap.Strict as Map +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 qualified Text.Blaze.Html5 as B +import Text.Blaze.Html5 ((!)) +import Text.Blaze.Renderer.XmlHtml +import Text.XmlHtml +------------------------------------------------------------------------------ + +import Heist.Interpreted.Internal +import Heist.Types + + ------------ + -- 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 } +-- +-- @\@ -- treats v_i as text +-- @\@ -- treats v_i as HTML +-- @\@ -- explodes v_i and runs its children +-- +-- @\@ -- walks the JSON tree to find +-- \"foo.bar.baz\", and interprets it as a string +-- @\@ +-- @\...\@ +-- +-- /Tags bound when you pass in anything else/ +-- +-- @\@ -- the given JSON value, as a string +-- @\@ -- 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 :: Number -> 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 [ ("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 [(Text, Splice n)] + genericBindings = ask >>= \v -> return [ ("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 = [ (T.append "with:" k , withValue v explodeTag) + , (T.append "snippet:" k, withValue v snippetTag) + , (T.append "value:" k , withValue v valueTag ) + ] + in newBindings ++ bindings diff --git a/src/Heist/Splices/Markdown.hs b/src/Heist/Splices/Markdown.hs new file mode 100644 --- /dev/null +++ b/src/Heist/Splices/Markdown.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-| The \"markdown\" splice formats markdown content as HTML and inserts +it into the document. + +If the file attribute is present the contents of the tag is ignored and +the file specified is converted to HTML. + +Otherwise the non-markup children of the tag are processed as markdown +and converted to HTML. + +This splice requires that the \"pandoc\" executable is in your path. +-} +module Heist.Splices.Markdown where + +------------------------------------------------------------------------------ +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Maybe +import Control.Concurrent +import Control.Exception (throwIO) +import Control.Monad +import Control.Monad.CatchIO +import Control.Monad.Trans +import Data.Typeable +import Prelude hiding (catch) +import System.Directory +import System.Exit +import System.FilePath.Posix +import System.IO +import System.Process +import Text.XmlHtml + +------------------------------------------------------------------------------ +import Heist.Common +import Heist.Interpreted.Internal +import Heist.Types + +data PandocMissingException = PandocMissingException + deriving (Typeable) + +instance Show PandocMissingException where + show PandocMissingException = + "Cannot find the \"pandoc\" executable; is it on your $PATH?" + +instance Exception PandocMissingException + + +data MarkdownException = MarkdownException ByteString + deriving (Typeable) + +instance Show MarkdownException where + show (MarkdownException e) = + "Markdown error: pandoc replied:\n\n" ++ BC.unpack e + +instance Exception MarkdownException + + +data NoMarkdownFileException = NoMarkdownFileException + deriving (Typeable) + +instance Show NoMarkdownFileException where + show NoMarkdownFileException = + "Markdown error: no file or template in context" ++ + " during processing of markdown tag" + +instance Exception NoMarkdownFileException where + +------------------------------------------------------------------------------ +-- | Default name for the markdown splice. +markdownTag :: Text +markdownTag = "markdown" + +------------------------------------------------------------------------------ +-- | Implementation of the markdown splice. +markdownSplice :: MonadIO m => Splice m +markdownSplice = do + templateDir <- liftM (fmap takeDirectory) getTemplateFilePath + pdMD <- liftIO $ findExecutable "pandoc" + + when (isNothing pdMD) $ liftIO $ throwIO PandocMissingException + + tree <- getParamNode + (source,markup) <- liftIO $ + case getAttribute "file" tree of + Just f -> do + m <- maybe (liftIO $ throwIO NoMarkdownFileException ) + (\tp -> pandoc (fromJust pdMD) tp $ T.unpack f) + templateDir + return (T.unpack f,m) + Nothing -> do + m <- pandocBS (fromJust pdMD) $ T.encodeUtf8 $ nodeText tree + return ("inline_splice",m) + + let ee = parseHTML source markup + case ee of + Left e -> throw $ MarkdownException + $ BC.pack ("Error parsing markdown output: " ++ e) + Right d -> return (docContent d) + + +pandoc :: FilePath -> FilePath -> FilePath -> IO ByteString +pandoc pandocPath templateDir inputFile = do + (ex, sout, serr) <- readProcessWithExitCode' pandocPath args "" + + when (isFail ex) $ throw $ MarkdownException serr + return $ BC.concat [ "
\n" + , sout + , "\n
" ] + + where + isFail ExitSuccess = False + isFail _ = True + + args = [ "-S", "--no-wrap", templateDir inputFile ] + + +pandocBS :: FilePath -> ByteString -> IO ByteString +pandocBS pandocPath s = do + -- using the crummy string functions for convenience here + (ex, sout, serr) <- readProcessWithExitCode' pandocPath args s + + when (isFail ex) $ throw $ MarkdownException serr + return $ BC.concat [ "
\n" + , sout + , "\n
" ] + + where + isFail ExitSuccess = False + isFail _ = True + args = [ "-S", "--no-wrap" ] + + +-- a version of readProcessWithExitCode that does I/O properly +readProcessWithExitCode' + :: FilePath -- ^ command to run + -> [String] -- ^ any arguments + -> ByteString -- ^ standard input + -> IO (ExitCode,ByteString,ByteString) -- ^ exitcode, stdout, stderr +readProcessWithExitCode' cmd args input = do + (Just inh, Just outh, Just errh, pid) <- + createProcess (proc cmd args){ std_in = CreatePipe, + std_out = CreatePipe, + std_err = CreatePipe } + outMVar <- newEmptyMVar + + outM <- newEmptyMVar + errM <- newEmptyMVar + + -- fork off a thread to start consuming stdout + _ <- forkIO $ do + out <- B.hGetContents outh + putMVar outM out + putMVar outMVar () + + -- fork off a thread to start consuming stderr + _ <- forkIO $ do + err <- B.hGetContents errh + putMVar errM err + putMVar outMVar () + + -- now write and flush any input + when (not (B.null input)) $ do B.hPutStr inh input; hFlush inh + hClose inh -- done with stdin + + -- wait on the output + takeMVar outMVar + takeMVar outMVar + hClose outh + + -- wait on the process + ex <- waitForProcess pid + + out <- readMVar outM + err <- readMVar errM + + return (ex, out, err) + + + + diff --git a/src/Heist/TemplateDirectory.hs b/src/Heist/TemplateDirectory.hs new file mode 100644 --- /dev/null +++ b/src/Heist/TemplateDirectory.hs @@ -0,0 +1,100 @@ +{-| + +This module defines a TemplateDirectory data structure for convenient +interaction with templates within web apps. + +-} + +module Heist.TemplateDirectory + ( TemplateDirectory + , newTemplateDirectory + , newTemplateDirectory' + + , getDirectoryHS + , getDirectoryCTS + , reloadTemplateDirectory + ) where + +------------------------------------------------------------------------------ +import Control.Concurrent +import Control.Error +import Control.Monad +import Control.Monad.Trans +import Heist +import Heist.Splices.Cache + + +------------------------------------------------------------------------------ +-- | Structure representing a template directory. +data TemplateDirectory n + = TemplateDirectory + FilePath + (HeistConfig n) + (MVar (HeistState n)) + (MVar CacheTagState) + + +------------------------------------------------------------------------------ +-- | Creates and returns a new 'TemplateDirectory' wrapped in an Either for +-- error handling. +newTemplateDirectory :: MonadIO n + => FilePath + -> HeistConfig n + -> EitherT [String] IO (TemplateDirectory n) +newTemplateDirectory dir hc = do + templates <- loadTemplates dir + let hc' = hc { hcTemplates = templates } + (hs,cts) <- initHeistWithCacheTag hc' + tsMVar <- liftIO $ newMVar hs + ctsMVar <- liftIO $ newMVar cts + return $ TemplateDirectory dir hc' tsMVar ctsMVar + + +------------------------------------------------------------------------------ +-- | Creates and returns a new 'TemplateDirectory', using the monad's fail +-- function on error. +newTemplateDirectory' :: MonadIO n + => FilePath + -> HeistConfig n + -> IO (TemplateDirectory n) +newTemplateDirectory' dir hc = do + res <- runEitherT $ newTemplateDirectory dir hc + either (error . concat) return res + + +------------------------------------------------------------------------------ +-- | Gets the 'HeistState' from a TemplateDirectory. +getDirectoryHS :: (MonadIO n) + => TemplateDirectory n + -> IO (HeistState n) +getDirectoryHS (TemplateDirectory _ _ tsMVar _) = + liftIO $ readMVar $ tsMVar + + +------------------------------------------------------------------------------ +-- | Clears the TemplateDirectory's cache tag state. +getDirectoryCTS :: TemplateDirectory n -> IO CacheTagState +getDirectoryCTS (TemplateDirectory _ _ _ ctsMVar) = readMVar ctsMVar + + +------------------------------------------------------------------------------ +-- | Clears cached content and reloads templates from disk. +reloadTemplateDirectory :: (MonadIO n) + => TemplateDirectory n + -> IO (Either String ()) +reloadTemplateDirectory (TemplateDirectory p hc tsMVar ctsMVar) = do + ehs <- runEitherT $ do + templates <- loadTemplates p + initHeistWithCacheTag (hc { hcTemplates = templates }) + leftPass ehs $ \(hs,cts) -> do + modifyMVar_ tsMVar (const $ return hs) + modifyMVar_ ctsMVar (const $ return cts) + + +------------------------------------------------------------------------------ +-- | Prepends an error onto a Left. +leftPass :: Monad m => Either [String] b -> (b -> m c) -> m (Either String c) +leftPass e m = either (return . Left . loadError . concat) + (liftM Right . m) e + where + loadError = (++) "Error loading templates: " diff --git a/src/Heist/Types.hs b/src/Heist/Types.hs new file mode 100644 --- /dev/null +++ b/src/Heist/Types.hs @@ -0,0 +1,489 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| + +This module contains the core Heist data types. + +Edward Kmett wrote most of the HeistT monad code and associated instances, +liberating us from the unused writer portion of RWST. + +-} + +module Heist.Types where + +------------------------------------------------------------------------------ +import Blaze.ByteString.Builder +import Control.Applicative +import Control.Arrow +import Control.Monad.CatchIO +import Control.Monad.Cont +import Control.Monad.Error +import Control.Monad.Reader +import Control.Monad.State.Strict +import Data.ByteString.Char8 (ByteString) +import Data.DList (DList) +import qualified Data.HashMap.Strict as H +import Data.HashMap.Strict (HashMap) +import Data.HeterogeneousEnvironment (HeterogeneousEnvironment) +import qualified Data.HeterogeneousEnvironment as HE +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding +import Data.Typeable +import Prelude hiding (catch) +import qualified Text.XmlHtml as X + +import Debug.Trace + +tr :: Show a => String -> a -> a +tr s x = trace (s++show x) x + +------------------------------------------------------------------------------ +-- | A 'Template' is a forest of XML nodes. Here we deviate from the \"single +-- root node\" constraint of well-formed XML because we want to allow +-- templates to contain document fragments that may not have a single root. +type Template = [X.Node] + + +------------------------------------------------------------------------------ +-- | MIME Type. The type alias is here to make the API clearer. +type MIMEType = ByteString + + +------------------------------------------------------------------------------ +-- | Reversed list of directories. This holds the path to the template +-- currently being processed. +type TPath = [ByteString] + + +------------------------------------------------------------------------------ +-- | Holds data about templates read from disk. +data DocumentFile = DocumentFile + { dfDoc :: X.Document + , dfFile :: Maybe FilePath + } deriving (Eq) + + +------------------------------------------------------------------------------ +-- | Monad used for runtime splice execution. +newtype RuntimeSplice m a = RuntimeSplice { + unRT :: StateT HeterogeneousEnvironment m a + } deriving ( Applicative + , Functor + , Monad + , MonadIO + , MonadState HeterogeneousEnvironment + , MonadTrans ) + + +------------------------------------------------------------------------------ +instance (Monad m, Monoid a) => Monoid (RuntimeSplice m a) where + mempty = return mempty + + a `mappend` b = do + !x <- a + !y <- b + return $! x `mappend` y + + +------------------------------------------------------------------------------ +-- | Opaque type representing pieces of output from compiled splices. +data Chunk m = Pure !ByteString + -- ^ output known at load time + | RuntimeHtml !(RuntimeSplice m Builder) + -- ^ output computed at run time + | RuntimeAction !(RuntimeSplice m ()) + -- ^ runtime action used only for its side-effect + + +instance Show (Chunk m) where + show (Pure _) = "Pure" + show (RuntimeHtml _) = "RuntimeHtml" + show (RuntimeAction _) = "RuntimeAction" + + +showChunk :: Chunk m -> String +showChunk (Pure b) = T.unpack $ decodeUtf8 b +showChunk (RuntimeHtml _) = "RuntimeHtml" +showChunk (RuntimeAction _) = "RuntimeAction" + + +isPureChunk :: Chunk m -> Bool +isPureChunk (Pure _) = True +isPureChunk _ = False + + +------------------------------------------------------------------------------ +-- | Type alias for attribute splices. The function parameter is the value of +-- the bound attribute splice. The return value is a list of attribute +-- key/value pairs that get substituted in the place of the bound attribute. +type AttrSplice m = Text -> m [(Text, Text)] + + +------------------------------------------------------------------------------ +-- | Holds all the state information needed for template processing. You will +-- build a @HeistState@ using 'initHeist' and any of Heist's @HeistState -> +-- HeistState@ \"filter\" functions. Then you use the resulting @HeistState@ +-- in calls to 'renderTemplate'. +-- +-- m is the runtime monad +data HeistState m = HeistState { + -- | A mapping of splice names to splice actions + _spliceMap :: HashMap Text (HeistT m m Template) + -- | A mapping of template names to templates + , _templateMap :: HashMap TPath DocumentFile + + -- | A mapping of splice names to splice actions + , _compiledSpliceMap :: HashMap Text (HeistT m IO (DList (Chunk m))) + -- | A mapping of template names to templates + --, _compiledTemplateMap :: HashMap TPath (m Builder, MIMEType) + , _compiledTemplateMap :: !(HashMap TPath ([Chunk m], MIMEType)) + + , _attrSpliceMap :: HashMap Text (AttrSplice m) + + -- | A flag to control splice recursion + , _recurse :: Bool + -- | The path to the template currently being processed. + , _curContext :: TPath + -- | A counter keeping track of the current recursion depth to prevent + -- infinite loops. + , _recursionDepth :: Int + -- | The doctypes encountered during template processing. + , _doctypes :: [X.DocType] + -- | The full path to the current template's file on disk. + , _curTemplateFile :: Maybe FilePath + -- | A key generator used to produce new unique Promises. + , _keygen :: HE.KeyGen + + -- | Flag indicating whether we're in preprocessing mode. During + -- preprocessing, errors should stop execution and be reported. During + -- template rendering, it's better to skip the errors and render the page. + , _preprocessingMode :: Bool +} + + +-- NOTE: We got rid of the Monoid instance because it is absolutely not safe +-- to combine two compiledTemplateMaps. All compiled templates must be known +-- at load time and processed in a single call to initHeist/loadTemplates or +-- whatever we end up calling it.. + +instance (Typeable1 m) => Typeable (HeistState m) where + typeOf _ = mkTyConApp templateStateTyCon [typeOf1 (undefined :: m ())] + + +------------------------------------------------------------------------------ +-- | HeistT is the monad transformer used for splice processing. HeistT +-- intentionally does not expose any of its functionality via MonadState or +-- MonadReader functions. We define passthrough instances for the most common +-- types of monads. These instances allow the user to use HeistT in a monad +-- stack without needing calls to `lift`. +-- +-- @n@ is the runtime monad (the parameter to HeistState). +-- +-- @m@ is the monad being run now. In this case, \"now\" is a variable +-- concept. The type @HeistT n n@ means that \"now\" is runtime. The type +-- @HeistT n IO@ means that \"now\" is @IO@, and more importantly it is NOT +-- runtime. In Heist, the rule of thumb is that @IO@ means load time and @n@ +-- means runtime. +newtype HeistT n m a = HeistT { + runHeistT :: X.Node + -> HeistState n + -> m (a, HeistState n) +} + + +------------------------------------------------------------------------------ +-- | Gets the names of all the templates defined in a HeistState. +templateNames :: HeistState m -> [TPath] +templateNames ts = H.keys $ _templateMap ts + + +------------------------------------------------------------------------------ +-- | Gets the names of all the templates defined in a HeistState. +compiledTemplateNames :: HeistState m -> [TPath] +compiledTemplateNames ts = H.keys $ _compiledTemplateMap ts + + +------------------------------------------------------------------------------ +-- | Gets the names of all the splices defined in a HeistState. +spliceNames :: HeistState m -> [Text] +spliceNames ts = H.keys $ _spliceMap ts + + +------------------------------------------------------------------------------ +-- | The Typeable instance is here so Heist can be dynamically executed with +-- Hint. +templateStateTyCon :: TyCon +templateStateTyCon = mkTyCon "Heist.HeistState" +{-# NOINLINE templateStateTyCon #-} + +------------------------------------------------------------------------------ +-- | Evaluates a template monad as a computation in the underlying monad. +evalHeistT :: (Monad m) + => HeistT n m a + -> X.Node + -> HeistState n + -> m a +evalHeistT m r s = do + (a, _) <- runHeistT m r s + return a +{-# INLINE evalHeistT #-} + + +------------------------------------------------------------------------------ +-- | Functor instance +instance Functor m => Functor (HeistT n m) where + fmap f (HeistT m) = HeistT $ \r s -> first f <$> m r s + + +------------------------------------------------------------------------------ +-- | Applicative instance +instance (Monad m, Functor m) => Applicative (HeistT n m) where + pure = return + (<*>) = ap + + +------------------------------------------------------------------------------ +-- | Monad instance +instance Monad m => Monad (HeistT n m) where + return a = HeistT (\_ s -> return (a, s)) + {-# INLINE return #-} + HeistT m >>= k = HeistT $ \r s -> do + (a, s') <- m r s + runHeistT (k a) r s' + {-# INLINE (>>=) #-} + + +------------------------------------------------------------------------------ +-- | MonadIO instance +instance MonadIO m => MonadIO (HeistT n m) where + liftIO = lift . liftIO + + +------------------------------------------------------------------------------ +-- | MonadTrans instance +instance MonadTrans (HeistT n) where + lift m = HeistT $ \_ s -> do + a <- m + return (a, s) + + +------------------------------------------------------------------------------ +-- | MonadCatchIO instance +instance MonadCatchIO m => MonadCatchIO (HeistT n m) where + catch (HeistT a) h = HeistT $ \r s -> do + let handler e = runHeistT (h e) r s + catch (a r s) handler + block (HeistT m) = HeistT $ \r s -> block (m r s) + unblock (HeistT m) = HeistT $ \r s -> unblock (m r s) + + +------------------------------------------------------------------------------ +-- | MonadFix passthrough instance +instance MonadFix m => MonadFix (HeistT n m) where + mfix f = HeistT $ \r s -> + mfix $ \ (a, _) -> runHeistT (f a) r s + + +------------------------------------------------------------------------------ +-- | Alternative passthrough instance +instance (Functor m, MonadPlus m) => Alternative (HeistT n m) where + empty = mzero + (<|>) = mplus + + +------------------------------------------------------------------------------ +-- | MonadPlus passthrough instance +instance MonadPlus m => MonadPlus (HeistT n m) where + mzero = lift mzero + m `mplus` n = HeistT $ \r s -> + runHeistT m r s `mplus` runHeistT n r s + + +------------------------------------------------------------------------------ +-- | MonadState passthrough instance +instance MonadState s m => MonadState s (HeistT n m) where + get = lift get + {-# INLINE get #-} + put = lift . put + {-# INLINE put #-} + + +------------------------------------------------------------------------------ +-- | MonadReader passthrough instance +instance MonadReader r m => MonadReader r (HeistT n m) where + ask = HeistT $ \_ s -> do + r <- ask + return (r,s) + local f (HeistT m) = + HeistT $ \r s -> local f (m r s) + + +------------------------------------------------------------------------------ +-- | Helper for MonadError instance. +liftCatch :: (m (a,HeistState n) + -> (e -> m (a,HeistState n)) + -> m (a,HeistState n)) + -> HeistT n m a + -> (e -> HeistT n m a) + -> HeistT n m a +liftCatch ce m h = + HeistT $ \r s -> + (runHeistT m r s `ce` + (\e -> runHeistT (h e) r s)) + + +------------------------------------------------------------------------------ +-- | MonadError passthrough instance +instance (MonadError e m) => MonadError e (HeistT n m) where + throwError = lift . throwError + catchError = liftCatch catchError + + +------------------------------------------------------------------------------ +-- | Helper for MonadCont instance. +liftCallCC :: ((((a,HeistState n) -> m (b, HeistState n)) + -> m (a, HeistState n)) + -> m (a, HeistState n)) + -> ((a -> HeistT n m b) -> HeistT n m a) + -> HeistT n m a +liftCallCC ccc f = HeistT $ \r s -> + ccc $ \c -> + runHeistT (f (\a -> HeistT $ \_ _ -> c (a, s))) r s + + +------------------------------------------------------------------------------ +-- | MonadCont passthrough instance +instance (MonadCont m) => MonadCont (HeistT n m) where + callCC = liftCallCC callCC + + +------------------------------------------------------------------------------ +-- | The Typeable instance is here so Heist can be dynamically executed with +-- Hint. +templateMonadTyCon :: TyCon +templateMonadTyCon = mkTyCon "Heist.HeistT" +{-# NOINLINE templateMonadTyCon #-} + +instance (Typeable1 m) => Typeable1 (HeistT n m) where + typeOf1 _ = mkTyConApp templateMonadTyCon [typeOf1 (undefined :: m ())] + + +------------------------------------------------------------------------------ +-- Functions for our monad. +------------------------------------------------------------------------------ + + +------------------------------------------------------------------------------ +-- | Gets the node currently being processed. +-- +-- > +-- > To sleep, perchance to dream. +-- > +-- +-- When you call @getParamNode@ inside the code for the @speech@ splice, it +-- returns the Node for the @speech@ tag and its children. @getParamNode >>= +-- childNodes@ returns a list containing one 'TextNode' containing part of +-- Hamlet's speech. @liftM (getAttribute \"author\") getParamNode@ would +-- return @Just "Shakespeare"@. +getParamNode :: Monad m => HeistT n m X.Node +getParamNode = HeistT $ \r s -> return (r,s) +{-# INLINE getParamNode #-} + + +------------------------------------------------------------------------------ +-- | HeistT's 'local'. +localParamNode :: Monad m + => (X.Node -> X.Node) + -> HeistT n m a + -> HeistT n m a +localParamNode f m = HeistT $ \r s -> runHeistT m (f r) s +{-# INLINE localParamNode #-} + + +------------------------------------------------------------------------------ +-- | HeistT's 'gets'. +getsHS :: Monad m => (HeistState n -> r) -> HeistT n m r +getsHS f = HeistT $ \_ s -> return (f s, s) +{-# INLINE getsHS #-} + + +------------------------------------------------------------------------------ +-- | HeistT's 'get'. +getHS :: Monad m => HeistT n m (HeistState n) +getHS = HeistT $ \_ s -> return (s, s) +{-# INLINE getHS #-} + + +------------------------------------------------------------------------------ +-- | HeistT's 'put'. +putHS :: Monad m => HeistState n -> HeistT n m () +putHS s = HeistT $ \_ _ -> return ((), s) +{-# INLINE putHS #-} + + +------------------------------------------------------------------------------ +-- | HeistT's 'modify'. +modifyHS :: Monad m + => (HeistState n -> HeistState n) + -> HeistT n m () +modifyHS f = HeistT $ \_ s -> return ((), f s) +{-# INLINE modifyHS #-} + + +------------------------------------------------------------------------------ +-- | Restores the HeistState. This function is almost like putHS except it +-- preserves the current doctypes. You should use this function instead of +-- @putHS@ to restore an old state. This was needed because doctypes needs to +-- be in a "global scope" as opposed to the template call "local scope" of +-- state items such as recursionDepth, curContext, and spliceMap. +restoreHS :: Monad m => HeistState n -> HeistT n m () +restoreHS old = modifyHS (\cur -> old { _doctypes = _doctypes cur }) +{-# INLINE restoreHS #-} + + +------------------------------------------------------------------------------ +-- | Abstracts the common pattern of running a HeistT computation with +-- a modified heist state. +localHS :: Monad m + => (HeistState n -> HeistState n) + -> HeistT n m a + -> HeistT n m a +localHS f k = do + ts <- getHS + putHS $ f ts + res <- k + restoreHS ts + return res +{-# INLINE localHS #-} + + +------------------------------------------------------------------------------ +-- | Modifies the recursion depth. +modRecursionDepth :: Monad m => (Int -> Int) -> HeistT n m () +modRecursionDepth f = + modifyHS (\st -> st { _recursionDepth = f (_recursionDepth st) }) + + +------------------------------------------------------------------------------ +-- | AST to hold attribute parsing structure. This is necessary because +-- attoparsec doesn't support parsers running in another monad. +data AttAST = Literal Text + | Ident Text + | Escaped Char + deriving (Show) + + +------------------------------------------------------------------------------ +isIdent :: AttAST -> Bool +isIdent (Ident _) = True +isIdent _ = False + + diff --git a/src/Text/Templating/Heist.hs b/src/Text/Templating/Heist.hs deleted file mode 100644 --- a/src/Text/Templating/Heist.hs +++ /dev/null @@ -1,176 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -{-| - - This module contains the core definitions for the Heist template system. - - The Heist template system is based on HTML and XML. It allows you to build - custom HTML and XML based markup languages. With Heist you can define your - own domain-specific HTML and XML tags implemented with Haskell and use them - in your templates. - - The most important concept in Heist is the 'Splice'. Splices can be thought - of as functions that transform a node into a list of nodes. Heist then - substitutes the resulting list of nodes into your template in place of the - input node. 'Splice' is implemented as a type synonym @type Splice m = - HeistT m [Node]@, and 'HeistT' has a function 'getParamNode' - that lets you get the input node. - - Suppose you have a place on your page where you want to display a link with - the text \"Logout username\" if the user is currently logged in or a link to - the login page if no user is logged in. Assume you have a function - @getUser :: MyAppMonad (Maybe Text)@ that gets the current user. - You can implement this functionality with a 'Splice' as follows: - - > import Blaze.ByteString.Builder - > import Data.ByteString.Char8 (ByteString) - > import qualified Data.ByteString.Char8 as B - > import Data.Text (Text) - > import qualified Data.Text as T - > import qualified Text.XmlHtml as X - > - > import Text.Templating.Heist - > - > link :: Text -> Text -> X.Node - > link target text = X.Element "a" [("href", target)] [X.TextNode text] - > - > loginLink :: X.Node - > loginLink = link "/login" "Login" - > - > logoutLink :: Text -> X.Node - > logoutLink user = link "/logout" (T.append "Logout " user) - > - > loginLogoutSplice :: Splice MyAppMonad - > loginLogoutSplice = do - > user <- lift getUser - > return [maybe loginLink logoutLink user] - > - - Next, you need to bind that splice to a tag. Heist stores information - about splices and templates in the 'HeistState' data structure. The - following code demonstrates how this splice would be used. - - > mySplices = [ ("loginLogout", loginLogoutSplice) ] - > - > main = do - > ets <- loadTemplates "templates" $ - > bindSplices mySplices defaultHeistState - > let ts = either error id ets - > t <- runMyAppMonad $ renderTemplate ts "index" - > print $ maybe "Page not found" (toByteString . fst) t - - Here we build up our 'HeistState' by starting with defaultHeistState and - applying bindSplice for all the splices we want to add. Then we pass this - to loadTemplates our final 'HeistState' wrapped in an Either to handle - errors. Then we use this 'HeistState' to render our templates. - --} - -module Text.Templating.Heist - ( - -- * Types - Template - , MIMEType - , Splice - , HeistT - , HeistState - , evalHeistT - , templateNames - , spliceNames - - -- * Functions and declarations on HeistState values - , addTemplate - , addXMLTemplate - , defaultHeistState - , bindSplice - , bindSplices - , lookupSplice - , setTemplates - , loadTemplates - , hasTemplate - , addTemplatePathPrefix - - -- * Hook functions - -- $hookDoc - , addOnLoadHook - , addPreRunHook - , addPostRunHook - - -- * HeistT functions - , stopRecursion - , getParamNode - , runNodeList - , getContext - , getTemplateFilePath - - , localParamNode - , getsTS - , getTS - , putTS - , modifyTS - , restoreTS - , localTS - - -- * Functions for running splices and templates - , evalTemplate - , callTemplate - , callTemplateWithText - , renderTemplate - , renderWithArgs - , bindStrings - , bindString - - -- * Functions for creating splices - , textSplice - , runChildren - , runChildrenWith - , runChildrenWithTrans - , runChildrenWithTemplates - , runChildrenWithText - , mapSplices - - -- * Misc functions - , getDoc - , getXMLDoc - , mkCacheTag - ) where - -import Control.Monad.Trans -import qualified Data.HashMap.Strict as Map -import Text.Templating.Heist.Internal -import Text.Templating.Heist.Splices -import Text.Templating.Heist.Types - - ------------------------------------------------------------------------------- --- | The default set of built-in splices. -defaultSpliceMap :: MonadIO m => SpliceMap m -defaultSpliceMap = Map.fromList - [(applyTag, applyImpl) - ,(bindTag, bindImpl) - ,(ignoreTag, ignoreImpl) - ,(markdownTag, markdownSplice) - ] - - ------------------------------------------------------------------------------- --- | An empty heist state, with Heist's default splices (@\@, --- @\@, @\@, and @\@) mapped. The cache tag is --- not mapped here because it must be mapped manually in your application. -defaultHeistState :: MonadIO m => HeistState m -defaultHeistState = - HeistState (defaultSpliceMap) Map.empty True [] 0 - return return return [] Nothing - - --- $hookDoc --- Heist hooks allow you to modify templates when they are loaded and before --- and after they are run. Every time you call one of the addAbcHook --- functions the hook is added to onto the processing pipeline. The hooks --- processes the template in the order that they were added to the --- HeistState. --- --- The pre-run and post-run hooks are run before and after every template is --- run/rendered. You should be careful what code you put in these hooks --- because it can significantly affect the performance of your site. - diff --git a/src/Text/Templating/Heist/Internal.hs b/src/Text/Templating/Heist/Internal.hs deleted file mode 100644 --- a/src/Text/Templating/Heist/Internal.hs +++ /dev/null @@ -1,743 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Text.Templating.Heist.Internal where - ------------------------------------------------------------------------------- -import Blaze.ByteString.Builder -import Control.Applicative -import Control.Arrow hiding (loop) -import Control.Exception (SomeException) -import Control.Monad -import Control.Monad.CatchIO -import Control.Monad.Trans -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.Either -import qualified Data.Foldable as F -import Data.List -import qualified Data.HashMap.Strict as Map -import Data.Maybe -import Data.Monoid -import qualified Data.Text as T -import Data.Text (Text) -import Prelude hiding (catch) -import System.Directory.Tree hiding (name) -import System.FilePath -import qualified Text.XmlHtml as X - ------------------------------------------------------------------------------- -import Text.Templating.Heist.Types - - ------------------------------------------------------------------------------- --- | Mappends a doctype to the state. -addDoctype :: Monad m => [X.DocType] -> HeistT m () -addDoctype dt = do - modifyTS (\s -> s { _doctypes = _doctypes s `mappend` dt }) - - ------------------------------------------------------------------------------- --- HeistState functions ------------------------------------------------------------------------------- - - ------------------------------------------------------------------------------- --- | Adds an on-load hook to a `HeistState`. -addOnLoadHook :: (Monad m) => - (Template -> IO Template) - -> HeistState m - -> HeistState m -addOnLoadHook hook ts = ts { _onLoadHook = _onLoadHook ts >=> hook } - - ------------------------------------------------------------------------------- --- | Adds a pre-run hook to a `HeistState`. -addPreRunHook :: (Monad m) => - (Template -> m Template) - -> HeistState m - -> HeistState m -addPreRunHook hook ts = ts { _preRunHook = _preRunHook ts >=> hook } - - ------------------------------------------------------------------------------- --- | Adds a post-run hook to a `HeistState`. -addPostRunHook :: (Monad m) => - (Template -> m Template) - -> HeistState m - -> HeistState m -addPostRunHook hook ts = ts { _postRunHook = _postRunHook ts >=> hook } - - ------------------------------------------------------------------------------- --- | Binds a new splice declaration to a tag name within a 'HeistState'. -bindSplice :: Monad m => - Text -- ^ tag name - -> Splice m -- ^ splice action - -> HeistState m -- ^ source state - -> HeistState m -bindSplice n v ts = ts {_spliceMap = Map.insert n v (_spliceMap ts)} - - ------------------------------------------------------------------------------- --- | Binds a set of new splice declarations within a 'HeistState'. -bindSplices :: Monad m => - [(Text, Splice m)] -- ^ splices to bind - -> HeistState m -- ^ start state - -> HeistState m -bindSplices ss ts = foldl' (flip id) ts acts - where - acts = map (uncurry bindSplice) ss - - ------------------------------------------------------------------------------- --- | Sets the current template file. -setCurTemplateFile :: Monad m - => Maybe FilePath -> HeistState m -> HeistState m -setCurTemplateFile fp ts = ts { _curTemplateFile = fp } - - ------------------------------------------------------------------------------- --- | Converts 'Text' to a splice returning a single 'TextNode'. -textSplice :: (Monad m) => Text -> Splice m -textSplice t = return [X.TextNode t] - - ------------------------------------------------------------------------------- --- | Runs the parameter node's children and returns the resulting node list. --- By itself this function is a simple passthrough splice that makes the --- spliced node disappear. In combination with locally bound splices, this --- function makes it easier to pass the desired view into your splices. -runChildren :: Monad m => Splice m -runChildren = runNodeList . X.childNodes =<< getParamNode - - ------------------------------------------------------------------------------- --- | Binds a list of splices before using the children of the spliced node as --- a view. -runChildrenWith :: (Monad m) - => [(Text, Splice m)] - -- ^ List of splices to bind before running the param nodes. - -> Splice m - -- ^ Returns the passed in view. -runChildrenWith splices = localTS (bindSplices splices) runChildren - - ------------------------------------------------------------------------------- --- | Wrapper around runChildrenWith that applies a transformation function to --- the second item in each of the tuples before calling runChildrenWith. -runChildrenWithTrans :: (Monad m) - => (b -> Splice m) - -- ^ Splice generating function - -> [(Text, b)] - -- ^ List of tuples to be bound - -> Splice m -runChildrenWithTrans f = runChildrenWith . map (second f) - - ------------------------------------------------------------------------------- --- | Like runChildrenWith but using constant templates rather than dynamic --- splices. -runChildrenWithTemplates :: (Monad m) => [(Text, Template)] -> Splice m -runChildrenWithTemplates = runChildrenWithTrans return - - ------------------------------------------------------------------------------- --- | Like runChildrenWith but using literal text rather than dynamic splices. -runChildrenWithText :: (Monad m) => [(Text, Text)] -> Splice m -runChildrenWithText = runChildrenWithTrans textSplice - - ------------------------------------------------------------------------------- --- | Maps a splice generating function over a list and concatenates the --- results. -mapSplices :: (Monad m) - => (a -> Splice m) - -- ^ Splice generating function - -> [a] - -- ^ List of items to generate splices for - -> Splice m - -- ^ The result of all splices concatenated together. -mapSplices f vs = liftM concat $ mapM f vs -{-# INLINE mapSplices #-} - - ------------------------------------------------------------------------------- --- | Convenience function for looking up a splice. -lookupSplice :: Monad m => - Text - -> HeistState m - -> Maybe (Splice m) -lookupSplice nm ts = Map.lookup nm $ _spliceMap ts -{-# INLINE lookupSplice #-} - - ------------------------------------------------------------------------------- --- | Converts a path into an array of the elements in reverse order. If the --- path is absolute, we need to remove the leading slash so the split doesn't --- leave @\"\"@ as the last element of the TPath. --- --- FIXME @\"..\"@ currently doesn't work in paths, the solution is non-trivial -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 - --- | Converts a path into an array of the elements in reverse order using the --- path separator of the local operating system. See 'splitPathWith' for more --- details. -splitLocalPath :: ByteString -> TPath -splitLocalPath = splitPathWith pathSeparator - --- | Converts a path into an array of the elements in reverse order using a --- forward slash (/) as the path separator. See 'splitPathWith' for more --- details. -splitTemplatePath :: ByteString -> TPath -splitTemplatePath = splitPathWith '/' - - ------------------------------------------------------------------------------- --- | Does a single template lookup without cascading up. -singleLookup :: TemplateMap - -> TPath - -> ByteString - -> Maybe (DocumentFile, TPath) -singleLookup tm path name = fmap (\a -> (a,path)) $ Map.lookup (name:path) tm - - ------------------------------------------------------------------------------- --- | Searches for a template by looking in the full path then backing up into --- each of the parent directories until the template is found. -traversePath :: TemplateMap - -> TPath - -> ByteString - -> Maybe (DocumentFile, 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 - - ------------------------------------------------------------------------------- --- | Returns 'True' if the given template can be found in the heist state. -hasTemplate :: Monad m => - ByteString - -> HeistState m - -> Bool -hasTemplate nameStr ts = isJust $ lookupTemplate nameStr ts - - ------------------------------------------------------------------------------- --- | Convenience function for looking up a template. -lookupTemplate :: Monad m => - ByteString - -> HeistState m - -> Maybe (DocumentFile, TPath) -lookupTemplate nameStr ts = - f (_templateMap 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 - - ------------------------------------------------------------------------------- --- | Sets the templateMap in a HeistState. -setTemplates :: Monad m => TemplateMap -> HeistState m -> HeistState m -setTemplates m ts = ts { _templateMap = m } - - ------------------------------------------------------------------------------- --- | Adds a template to the heist state. -insertTemplate :: Monad m => - TPath - -> DocumentFile - -> HeistState m - -> HeistState m -insertTemplate p t st = - setTemplates (Map.insert p t (_templateMap st)) st - - ------------------------------------------------------------------------------- --- | Adds an HTML format template to the heist state. -addTemplate :: Monad m - => ByteString - -- ^ Path that the template will be referenced by - -> Template - -- ^ The template's DOM nodes - -> Maybe FilePath - -- ^ An optional path to the actual file on disk where the - -- template is stored - -> HeistState m - -> HeistState m -addTemplate n t mfp st = - insertTemplate (splitTemplatePath n) doc st - where - doc = DocumentFile (X.HtmlDocument X.UTF8 Nothing t) mfp - - ------------------------------------------------------------------------------- --- | Adds an XML format template to the heist state. -addXMLTemplate :: Monad m - => ByteString - -- ^ Path that the template will be referenced by - -> Template - -- ^ The template's DOM nodes - -> Maybe FilePath - -- ^ An optional path to the actual file on disk where the - -- template is stored - -> HeistState m - -> HeistState m -addXMLTemplate n t mfp st = - insertTemplate (splitTemplatePath n) doc st - where - doc = DocumentFile (X.XmlDocument X.UTF8 Nothing t) mfp - - ------------------------------------------------------------------------------- --- | Stops the recursive processing of splices. Consider the following --- example: --- --- > --- > --- > ... --- > --- > --- --- Assume that @\"foo\"@ is bound to a splice procedure. Running the @foo@ --- splice will result in a list of nodes @L@. Normally @foo@ will recursively --- scan @L@ for splices and run them. If @foo@ calls @stopRecursion@, @L@ --- will be included in the output verbatim without running any splices. -stopRecursion :: Monad m => HeistT m () -stopRecursion = modifyTS (\st -> st { _recurse = False }) - - ------------------------------------------------------------------------------- --- | Sets the current context -setContext :: Monad m => TPath -> HeistT m () -setContext c = modifyTS (\st -> st { _curContext = c }) - - ------------------------------------------------------------------------------- --- | Gets the current context -getContext :: Monad m => HeistT m TPath -getContext = getsTS _curContext - - ------------------------------------------------------------------------------- --- | Gets the full path to the file holding the template currently being --- processed. Returns Nothing if the template is not associated with a file --- on disk or if there is no template being processed. -getTemplateFilePath :: Monad m => HeistT m (Maybe FilePath) -getTemplateFilePath = getsTS _curTemplateFile - - ------------------------------------------------------------------------------- --- | Performs splice processing on a single node. -runNode :: Monad m => X.Node -> Splice m -runNode (X.Element nm at ch) = do - newAtts <- mapM attSubst at - let n = X.Element nm newAtts ch - s <- liftM (lookupSplice nm) getTS - maybe (runKids newAtts) (recurseSplice n) s - where - runKids newAtts = do - newKids <- runNodeList ch - return [X.Element nm newAtts newKids] -runNode n = return [n] - - ------------------------------------------------------------------------------- --- | Helper function for substituting a parsed attribute into an attribute --- tuple. -attSubst :: (Monad m) => (t, Text) -> HeistT m (t, Text) -attSubst (n,v) = do - v' <- parseAtt v - return (n,v') - - ------------------------------------------------------------------------------- --- | Parses an attribute for any identifier expressions and performs --- appropriate substitution. -parseAtt :: (Monad m) => Text -> HeistT m Text -parseAtt bs = do - let ast = case AP.feed (AP.parse attParser bs) "" of - (AP.Done _ res) -> res - (AP.Fail _ _ _) -> [] - (AP.Partial _) -> [] - chunks <- mapM cvt ast - return $ T.concat chunks - where - cvt (Literal x) = return x - cvt (Ident x) = - localParamNode (const $ X.Element x [] []) $ getAttributeSplice x - - ------------------------------------------------------------------------------- --- | AST to hold attribute parsing structure. This is necessary because --- attoparsec doesn't support parsers running in another monad. -data AttAST = Literal Text - | Ident Text - deriving (Show) - - ------------------------------------------------------------------------------- --- | Parser for attribute variable substitution. -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) - <|> (escChar >>= go . append subDL) - <|> (do - idp <- identParser - dl' <- finish subDL - loop $! append dl' idp) - - gobbleText = AP.takeWhile1 (AP.notInClass "\\$") - - escChar = AP.char '\\' *> (T.singleton <$> AP.anyChar) - - identParser = AP.char '$' *> (ident <|> return (Literal "$")) - ident = (AP.char '{' *> (Ident <$> AP.takeWhile (/='}')) <* AP.string "}") - - ------------------------------------------------------------------------------- --- | Gets the attribute value. If the splice's result list contains non-text --- nodes, this will translate them into text nodes with nodeText and --- concatenate them together. --- --- Originally, this only took the first node from the splices's result list, --- and only if it was a text node. This caused problems when the splice's --- result contained HTML entities, as they would split a text node. This was --- then fixed to take the first consecutive bunch of text nodes, and return --- their concatenation. This was seen as more useful than throwing an error, --- and more intuitive than trying to render all the nodes as text. --- --- However, it was decided in the end to render all the nodes as text, and --- then concatenate them. If a splice returned --- \"some \text\<\/b\> foobar\", the user would almost certainly want --- \"some text foobar\" to be rendered, and Heist would probably seem --- annoyingly limited for not being able to do this. If the user really did --- want it to render \"some \", it would probably be easier for them to --- accept that they were silly to pass more than that to be substituted than --- it would be for the former user to accept that --- \"some \text\<\/b\> foobar\" is being rendered as \"some \" because --- it's \"more intuitive\". -getAttributeSplice :: Monad m => Text -> HeistT m Text -getAttributeSplice name = do - s <- liftM (lookupSplice name) getTS - nodes <- maybe (return []) id s - return $ T.concat $ map X.nodeText nodes - ------------------------------------------------------------------------------- --- | Performs splice processing on a list of nodes. -runNodeList :: Monad m => [X.Node] -> Splice m -runNodeList = mapSplices runNode -{-# INLINE runNodeList #-} - - ------------------------------------------------------------------------------- --- | The maximum recursion depth. (Used to prevent infinite loops.) -mAX_RECURSION_DEPTH :: Int -mAX_RECURSION_DEPTH = 50 - - ------------------------------------------------------------------------------- --- | Checks the recursion flag and recurses accordingly. Does not recurse --- deeper than mAX_RECURSION_DEPTH to avoid infinite loops. -recurseSplice :: Monad m => X.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 - restoreTS ts' - return res - else return result - where - modRecursionDepth :: Monad m => (Int -> Int) -> HeistT m () - modRecursionDepth f = - modifyTS (\st -> st { _recursionDepth = f (_recursionDepth st) }) - - ------------------------------------------------------------------------------- --- | Looks up a template name runs a 'HeistT' computation on it. -lookupAndRun :: Monad m - => ByteString - -> ((DocumentFile, TPath) -> HeistT m (Maybe a)) - -> HeistT m (Maybe a) -lookupAndRun name k = do - ts <- getTS - let mt = lookupTemplate name ts - let curPath = join $ fmap (dfFile . fst) mt - modifyTS (setCurTemplateFile curPath) - maybe (return Nothing) k mt - - ------------------------------------------------------------------------------- --- | Looks up a template name evaluates it by calling runNodeList. -evalTemplate :: Monad m - => ByteString - -> HeistT m (Maybe Template) -evalTemplate name = lookupAndRun name - (\(t,ctx) -> localTS (\ts -> ts {_curContext = ctx}) - (liftM Just $ runNodeList $ X.docContent $ dfDoc t)) - - ------------------------------------------------------------------------------- --- | Sets the document type of a 'X.Document' based on the 'HeistT' --- value. -fixDocType :: Monad m => X.Document -> HeistT m X.Document -fixDocType d = do - dts <- getsTS _doctypes - return $ d { X.docType = listToMaybe dts } - - ------------------------------------------------------------------------------- --- | Same as evalWithHooks, but returns the entire 'X.Document' rather than --- just the nodes. This is the right thing to do if we are starting at the --- top level. -evalWithHooksInternal :: Monad m - => ByteString - -> HeistT m (Maybe X.Document) -evalWithHooksInternal name = lookupAndRun name $ \(t,ctx) -> do - addDoctype $ maybeToList $ X.docType $ dfDoc t - ts <- getTS - nodes <- lift $ _preRunHook ts $ X.docContent $ dfDoc t - putTS (ts {_curContext = ctx}) - res <- runNodeList nodes - restoreTS ts - newNodes <- lift (_postRunHook ts res) - newDoc <- fixDocType $ (dfDoc t) { X.docContent = newNodes } - return (Just newDoc) - - ------------------------------------------------------------------------------- --- | Looks up a template name evaluates it by calling runNodeList. This also --- executes pre- and post-run hooks and adds the doctype. -evalWithHooks :: Monad m - => ByteString - -> HeistT m (Maybe Template) -evalWithHooks name = liftM (liftM X.docContent) (evalWithHooksInternal name) - - ------------------------------------------------------------------------------- --- | Binds a list of constant string splices. -bindStrings :: Monad m - => [(Text, Text)] - -> HeistState m - -> HeistState m -bindStrings pairs ts = foldr (uncurry bindString) ts pairs - - ------------------------------------------------------------------------------- --- | Binds a single constant string splice. -bindString :: Monad m - => Text - -> Text - -> HeistState m - -> HeistState m -bindString n = bindSplice n . textSplice - - ------------------------------------------------------------------------------- --- | Renders a template with the specified parameters. This is the function --- to use when you want to "call" a template and pass in parameters from --- inside a splice. If the template does not exist, this version simply --- returns an empty list. -callTemplate :: Monad m - => ByteString -- ^ The name of the template - -> [(Text, Splice m)] -- ^ Association list of - -- (name,value) parameter pairs - -> HeistT m Template -callTemplate name params = do - modifyTS $ bindSplices params - liftM (maybe [] id) $ evalTemplate name - - ------------------------------------------------------------------------------- --- | Like callTemplate except the splices being bound are constant text --- splices. -callTemplateWithText :: Monad m - => ByteString -- ^ The name of the template - -> [(Text, Text)] -- ^ Association list of - -- (name,value) parameter pairs - -> HeistT m Template -callTemplateWithText name params = do - modifyTS $ bindStrings params - liftM (maybe [] id) $ evalTemplate name - - ------------------------------------------------------------------------------- --- Gives the MIME type for a 'X.Document' -mimeType :: X.Document -> ByteString -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" - -- Should not include byte order designation for UTF-16 since - -- rendering will include a byte order mark. (RFC 2781, Sec. 3.3) - enc X.UTF16BE = "utf-16" - enc X.UTF16LE = "utf-16" - - ------------------------------------------------------------------------------- --- | Renders a template from the specified HeistState to a 'Builder'. The --- MIME type returned is based on the detected character encoding, and whether --- the root template was an HTML or XML format template. It will always be --- @text/html@ or @text/xml@. If a more specific MIME type is needed for a --- particular XML application, it must be provided by the application. -renderTemplate :: Monad m - => HeistState m - -> ByteString - -> m (Maybe (Builder, MIMEType)) -renderTemplate ts name = evalHeistT tpl (X.TextNode "") ts - where tpl = do mt <- evalWithHooksInternal name - case mt of - Nothing -> return Nothing - Just doc -> return $ Just $ (X.render doc, mimeType doc) - - ------------------------------------------------------------------------------- --- | Renders a template with the specified arguments passed to it. This is a --- convenience function for the common pattern of calling renderTemplate after --- using bindString, bindStrings, or bindSplice to set up the arguments to the --- template. -renderWithArgs :: Monad m - => [(Text, Text)] - -> HeistState m - -> ByteString - -> m (Maybe (Builder, MIMEType)) -renderWithArgs args ts = renderTemplate (bindStrings args ts) - - ------------------------------------------------------------------------------- --- Template loading ------------------------------------------------------------------------------- - - ------------------------------------------------------------------------------- --- | Type synonym for parsers. -type ParserFun = String -> ByteString -> Either String X.Document - - ------------------------------------------------------------------------------- --- | Reads an HTML or XML template from disk. -getDocWith :: ParserFun -> String -> IO (Either String DocumentFile) -getDocWith parser f = do - bs <- 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 - - ------------------------------------------------------------------------------- --- | Reads an HTML template from disk. -getDoc :: String -> IO (Either String DocumentFile) -getDoc = getDocWith X.parseHTML - - ------------------------------------------------------------------------------- --- | Reads an XML template from disk. -getXMLDoc :: String -> IO (Either String DocumentFile) -getXMLDoc = getDocWith X.parseXML - - ------------------------------------------------------------------------------- --- | Loads a template with the specified path and filename. The --- template is only loaded if it has a ".tpl" or ".xtpl" extension. -loadTemplate :: String -- ^ path of the template root - -> String -- ^ full file path (includes the template root) - -> IO [Either String (TPath, DocumentFile)] --TemplateMap -loadTemplate templateRoot fname - | isHTMLTemplate = do - c <- getDoc fname - return [fmap (\t -> (splitLocalPath $ BC.pack tName, t)) c] - | isXMLTemplate = do - c <- getXMLDoc fname - return [fmap (\t -> (splitLocalPath $ BC.pack tName, t)) c] - | otherwise = return [] - where -- tName is path relative to the template root directory - isHTMLTemplate = ".tpl" `isSuffixOf` fname - isXMLTemplate = ".xtpl" `isSuffixOf` fname - correction = if last templateRoot == '/' then 0 else 1 - extLen = if isHTMLTemplate then 4 else 5 - tName = drop ((length templateRoot)+correction) $ - -- We're only dropping the template root, not the whole path - take ((length fname) - extLen) fname - - ------------------------------------------------------------------------------- --- | Traverses the specified directory structure and builds a HeistState by --- loading all the files with a ".tpl" or ".xtpl" extension. -loadTemplates :: Monad m => FilePath -> HeistState m - -> IO (Either String (HeistState 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 - - ------------------------------------------------------------------------------- --- | Runs a template modifying function on a DocumentFile. -runHook :: Monad m => (Template -> m Template) - -> DocumentFile - -> m DocumentFile -runHook f t = do - n <- f $ X.docContent $ dfDoc t - return $ t { dfDoc = (dfDoc t) { X.docContent = n } } - - ------------------------------------------------------------------------------- --- | Runs the onLoad hook on the template and returns the 'HeistState' --- with the result inserted. -loadHook :: Monad m => HeistState m -> (TPath, DocumentFile) - -> IO (HeistState m) -loadHook ts (tp, t) = do - t' <- runHook (_onLoadHook ts) t - return $ insertTemplate tp t' ts - - ------------------------------------------------------------------------------- --- | Adds a path prefix to all the templates in the 'HeistState'. If you --- want to add multiple levels of directories, separate them with slashes as --- in "foo/bar". Using an empty string as a path prefix will leave the --- 'HeistState' unchanged. -addTemplatePathPrefix :: ByteString -> HeistState m -> HeistState m -addTemplatePathPrefix dir ts - | B.null dir = ts - | otherwise = ts { _templateMap = Map.fromList $ - map (\(x,y) -> (f x, y)) $ - Map.toList $ - _templateMap ts - } - where - f ps = ps++splitTemplatePath dir - diff --git a/src/Text/Templating/Heist/Splices.hs b/src/Text/Templating/Heist/Splices.hs deleted file mode 100644 --- a/src/Text/Templating/Heist/Splices.hs +++ /dev/null @@ -1,16 +0,0 @@ -module Text.Templating.Heist.Splices - ( module Text.Templating.Heist.Splices.Apply - , module Text.Templating.Heist.Splices.Bind - , module Text.Templating.Heist.Splices.Cache - , module Text.Templating.Heist.Splices.Html - , module Text.Templating.Heist.Splices.Ignore - , module Text.Templating.Heist.Splices.Markdown - ) where - -import Text.Templating.Heist.Splices.Apply -import Text.Templating.Heist.Splices.Bind -import Text.Templating.Heist.Splices.Cache -import Text.Templating.Heist.Splices.Html -import Text.Templating.Heist.Splices.Ignore -import Text.Templating.Heist.Splices.Markdown - diff --git a/src/Text/Templating/Heist/Splices/Apply.hs b/src/Text/Templating/Heist/Splices/Apply.hs deleted file mode 100644 --- a/src/Text/Templating/Heist/Splices/Apply.hs +++ /dev/null @@ -1,65 +0,0 @@ -module Text.Templating.Heist.Splices.Apply where - ------------------------------------------------------------------------------- -import Data.Maybe -import Data.Text (Text) -import qualified Data.Text.Encoding as T -import qualified Text.XmlHtml as X - ------------------------------------------------------------------------------- -import Text.Templating.Heist.Internal -import Text.Templating.Heist.Types - ------------------------------------------------------------------------------- --- | Default name for the apply splice. -applyTag :: Text -applyTag = "apply" - - ------------------------------------------------------------------------------- --- | Default attribute name for the apply tag. -applyAttr :: Text -applyAttr = "template" - - ------------------------------------------------------------------------------- --- | Raw core of apply functionality. This is abstracted for use in other --- places like an enhanced (from the original) bind -rawApply :: (Monad m) - => [X.Node] - -> TPath - -> [X.Node] - -> HeistT m Template -rawApply calledNodes newContext paramNodes = do - st <- getTS -- Can't use localTS here because the modifier is not pure - processedParams <- runNodeList paramNodes - modifyTS (bindSplice "content" $ return processedParams) - setContext newContext - result <- runNodeList calledNodes - restoreTS st - return result - - ------------------------------------------------------------------------------- --- | Applies a template as if the supplied nodes were the children of the --- tag. -applyNodes :: Monad m => Template -> Text -> Splice m -applyNodes nodes template = do - st <- getTS - maybe (return []) -- TODO: error handling - (\(t,ctx) -> do - addDoctype $ maybeToList $ X.docType $ dfDoc t - rawApply (X.docContent $ dfDoc t) ctx nodes) - (lookupTemplate (T.encodeUtf8 template) st) - - ------------------------------------------------------------------------------- --- | Implementation of the apply splice. -applyImpl :: Monad m => Splice m -applyImpl = do - node <- getParamNode - case X.getAttribute applyAttr node of - Nothing -> return [] -- TODO: error handling - Just template -> applyNodes (X.childNodes node) template - - diff --git a/src/Text/Templating/Heist/Splices/Bind.hs b/src/Text/Templating/Heist/Splices/Bind.hs deleted file mode 100644 --- a/src/Text/Templating/Heist/Splices/Bind.hs +++ /dev/null @@ -1,39 +0,0 @@ -module Text.Templating.Heist.Splices.Bind where - ------------------------------------------------------------------------------- -import Data.Text (Text) -import qualified Text.XmlHtml as X - ------------------------------------------------------------------------------- -import Text.Templating.Heist.Internal -import Text.Templating.Heist.Splices.Apply -import Text.Templating.Heist.Types - --- | Default name for the bind splice. -bindTag :: Text -bindTag = "bind" - - ------------------------------------------------------------------------------- --- | Default attribute name for the bind tag. -bindAttr :: Text -bindAttr = "tag" - - ------------------------------------------------------------------------------- --- | Implementation of the bind splice. -bindImpl :: Monad m => Splice m -bindImpl = do - node <- getParamNode - maybe (return ()) - (add node) - (X.getAttribute bindAttr node) - return [] - - where - add node nm = modifyTS $ bindSplice nm $ do - caller <- getParamNode - ctx <- getContext - rawApply (X.childNodes node) ctx (X.childNodes caller) - - diff --git a/src/Text/Templating/Heist/Splices/BindStrict.hs b/src/Text/Templating/Heist/Splices/BindStrict.hs deleted file mode 100644 --- a/src/Text/Templating/Heist/Splices/BindStrict.hs +++ /dev/null @@ -1,32 +0,0 @@ -module Text.Templating.Heist.Splices.BindStrict where - ------------------------------------------------------------------------------- -import Data.Text (Text) -import qualified Text.XmlHtml as X - ------------------------------------------------------------------------------- -import Text.Templating.Heist.Internal -import Text.Templating.Heist.Splices.Apply -import Text.Templating.Heist.Splices.Bind -import Text.Templating.Heist.Types - --- | Default name for the bind splice. -bindStrictTag :: Text -bindStrictTag = "bindStrict" - - ------------------------------------------------------------------------------- --- | Implementation of the bind splice. -bindStrictImpl :: Monad m => Splice m -bindStrictImpl = do - node <- getParamNode - cs <- runChildren - maybe (return ()) (add cs) - (X.getAttribute bindAttr node) - return [] - - where - add cs nm = modifyTS $ bindSplice nm $ do - caller <- getParamNode - ctx <- getContext - rawApply cs ctx (X.childNodes caller) diff --git a/src/Text/Templating/Heist/Splices/Cache.hs b/src/Text/Templating/Heist/Splices/Cache.hs deleted file mode 100644 --- a/src/Text/Templating/Heist/Splices/Cache.hs +++ /dev/null @@ -1,152 +0,0 @@ --- | The \"cache\" splice ensures that its contents are cached and only --- evaluated periodically. The cached contents are returned every time the --- splice is referenced. --- --- Use the ttl attribute to set the amount of time between reloads. The ttl --- value should be a positive integer followed by a single character --- specifying the units. Valid units are seconds, minutes, hours, days, and --- weeks. If the ttl string is invalid or the ttl attribute is not specified, --- the cache is never refreshed unless explicitly cleared with --- clearCacheTagState. -module Text.Templating.Heist.Splices.Cache - ( CacheTagState - , mkCacheTag - , clearCacheTagState - ) where - ------------------------------------------------------------------------------- -import Control.Concurrent -import Control.Monad -import Control.Monad.Trans -import Data.IORef -import qualified Data.HashMap.Strict as H -import Data.HashMap.Strict (HashMap) -import qualified Data.HashSet as Set -import Data.Text (Text) -import qualified Data.Text as T -import Data.Text.Read -import Data.Time.Clock -import System.Random -import Text.XmlHtml.Cursor -import Text.XmlHtml hiding (Node) - - ------------------------------------------------------------------------------- -import Text.Templating.Heist.Internal -import Text.Templating.Heist.Types - - ------------------------------------------------------------------------------- -cacheTagName :: Text -cacheTagName = "cache" - - ------------------------------------------------------------------------------- --- | State for storing cache tag information -newtype CacheTagState = CTS (MVar (HashMap Text (UTCTime, Template))) - - ------------------------------------------------------------------------------- --- | Clears the cache tag state. -clearCacheTagState :: CacheTagState -> IO () -clearCacheTagState (CTS cacheMVar) = - modifyMVar_ cacheMVar (const $ return H.empty) - - ------------------------------------------------------------------------------- --- | Converts a TTL string into an integer number of seconds. -parseTTL :: Text -> Int -parseTTL s = value * multiplier - where - value = either (const 0) fst $ decimal s - multiplier = case T.last s of - 's' -> 1 - 'm' -> 60 - 'h' -> 3600 - 'd' -> 86400 - 'w' -> 604800 - _ -> 0 - ------------------------------------------------------------------------------- -cacheImpl :: (MonadIO m) - => CacheTagState - -> HeistT m Template -cacheImpl (CTS mv) = do - tree <- getParamNode - let err = error $ unwords ["cacheImpl is bound to a tag" - ,"that didn't get an id attribute." - ," This should never happen."] - let i = maybe err id $ getAttribute "id" tree - ttl = maybe 0 parseTTL $ getAttribute "ttl" tree - mp <- liftIO $ readMVar mv - - (mp',ns) <- do - cur <- liftIO getCurrentTime - let mbn = H.lookup i mp - reload = do - nodes' <- runNodeList $ childNodes tree - return $! (H.insert i (cur,nodes') mp, nodes') - case mbn of - Nothing -> reload - (Just (lastUpdate,n)) -> do - if ttl > 0 && tagName tree == Just cacheTagName && - diffUTCTime cur lastUpdate > fromIntegral ttl - then reload - else do - stopRecursion - return $! (mp,n) - - liftIO $ modifyMVar_ mv (const $ return mp') - - return ns - - ------------------------------------------------------------------------------- --- | Returns a function that modifies a HeistState to include a \"cache\" --- tag. The cache tag is not bound automatically with the other default Heist --- tags. This is because this function also returns CacheTagState, so the --- user will be able to clear it with the 'clearCacheTagState' function. -mkCacheTag :: MonadIO m - => IO (HeistState m -> HeistState m, CacheTagState) -mkCacheTag = do - sr <- newIORef $ Set.empty - mv <- liftM CTS $ newMVar H.empty - - return $ ( addOnLoadHook (assignIds sr) . - -- The cache tag allows the ttl attribute. - bindSplice cacheTagName (cacheImpl mv) . - -- Like the old static tag...does not allow ttl - bindSplice "static" (cacheImpl mv) - , mv) - - where - generateId :: IO Int - generateId = getStdRandom random - - assignIds setref = mapM f - where - f node = g $ fromNode node - - getId = do - i <- liftM (T.pack . show) generateId - st <- readIORef setref - if Set.member i st - then getId - else do - writeIORef setref $ Set.insert i st - return $ T.append "cache-id-" i - - g curs = do - let node = current curs - curs' <- if tagName node == Just cacheTagName || - tagName node == Just "static" - then do - i <- getId - return $ modifyNode (setAttribute "id" i) curs - else return curs - let mbc = nextDF curs' - maybe (return $ topNode curs') g mbc - - - - diff --git a/src/Text/Templating/Heist/Splices/Html.hs b/src/Text/Templating/Heist/Splices/Html.hs deleted file mode 100644 --- a/src/Text/Templating/Heist/Splices/Html.hs +++ /dev/null @@ -1,47 +0,0 @@ -module Text.Templating.Heist.Splices.Html where - ------------------------------------------------------------------------------- -import Data.Maybe -import Data.Text (Text) -import qualified Text.XmlHtml as X - ------------------------------------------------------------------------------- -import Text.Templating.Heist.Internal -import Text.Templating.Heist.Types - - ------------------------------------------------------------------------------- --- | Name for the html splice. -htmlTag :: Text -htmlTag = "html" - - ------------------------------------------------------------------------------- --- | The html splice runs all children and then traverses the returned node --- forest removing all head nodes. Then it merges them all and prepends it to --- the html tag's child list. -htmlImpl :: Monad m => Splice m -htmlImpl = do - node <- getParamNode - children <- runNodeList $ X.childNodes node - let (heads, mnode) = extractHeads $ node { X.elementChildren = children } - new (X.Element t a c) = X.Element t a $ - X.Element "head" [] heads : c - new n = n - stopRecursion - return [maybe node new mnode] - ------------------------------------------------------------------------------- --- | Extracts all heads from a node tree. -extractHeads :: X.Node - -- ^ The root (html) node - -> ([X.Node], Maybe X.Node) - -- ^ A tuple of a list of head nodes and the original tree with - -- heads removed. -extractHeads (X.Element t a c) - | t == "head" = (c, Nothing) - | otherwise = (concat heads, Just $ X.Element t a (catMaybes mcs)) - where - (heads, mcs) = unzip $ map extractHeads c -extractHeads n = ([], Just n) - diff --git a/src/Text/Templating/Heist/Splices/Ignore.hs b/src/Text/Templating/Heist/Splices/Ignore.hs deleted file mode 100644 --- a/src/Text/Templating/Heist/Splices/Ignore.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Text.Templating.Heist.Splices.Ignore where - ------------------------------------------------------------------------------- -import Data.Text (Text) - ------------------------------------------------------------------------------- -import Text.Templating.Heist.Types - - ------------------------------------------------------------------------------- --- | Default name for the ignore splice. -ignoreTag :: Text -ignoreTag = "ignore" - - ------------------------------------------------------------------------------- --- | The ignore tag and everything it surrounds disappears in the --- rendered output. -ignoreImpl :: Monad m => Splice m -ignoreImpl = return [] - - diff --git a/src/Text/Templating/Heist/Splices/Json.hs b/src/Text/Templating/Heist/Splices/Json.hs deleted file mode 100644 --- a/src/Text/Templating/Heist/Splices/Json.hs +++ /dev/null @@ -1,222 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE OverloadedStrings #-} - -module Text.Templating.Heist.Splices.Json ( - bindJson -) where - ------------------------------------------------------------------------------- -import Control.Monad.Reader -import Data.Aeson -import Data.Attoparsec.Number -import qualified Data.ByteString.Char8 as S -import qualified Data.ByteString.Lazy.Char8 as L -import qualified Data.HashMap.Strict as Map -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.Templating.Heist -import qualified Text.Blaze.Html5 as B -import Text.Blaze.Html5 ((!)) -import Text.Blaze.Renderer.XmlHtml -import Text.XmlHtml ------------------------------------------------------------------------------- - - ------------ - -- 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 } --- --- @\@ -- treats v_i as text --- @\@ -- treats v_i as HTML --- @\@ -- explodes v_i and runs its children --- --- @\@ -- walks the JSON tree to find --- \"foo.bar.baz\", and interprets it as a string --- @\@ --- @\...\@ --- --- /Tags bound when you pass in anything else/ --- --- @\@ -- the given JSON value, as a string --- @\@ -- the given JSON value, parsed and spliced in as HTML --- -bindJson :: (ToJSON a, Monad m) => a -> Splice m -bindJson = runReaderT explodeTag . toJSON - - - ------------- - -- private -- - ------------- - ------------------------------------------------------------------------------- -errorMessage :: String -> [Node] -errorMessage s = renderHtmlNodes $ - B.strong ! B.customAttribute "class" "error" $ - B.toHtml s - - ------------------------------------------------------------------------------- -type JsonMonad m a = ReaderT Value (HeistT m) a - - ------------------------------------------------------------------------------- -withValue :: (Monad m) => Value -> JsonMonad m a -> HeistT m a -withValue = flip runReaderT - - ------------------------------------------------------------------------------- -boolToText :: Bool -> Text -boolToText b = if b then "true" else "false" - - ------------------------------------------------------------------------------- -numToText :: Number -> 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 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 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 m) => JsonMonad m [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 [ ("value" , return [TextNode t]) - , ("snippet" , asHtml t ) - ] - - -------------------------------------------------------------------------- - goArray :: (Monad m) => V.Vector Value -> JsonMonad m [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 [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 m => JsonMonad m [(Text, Splice m)] - genericBindings = ask >>= \v -> return [ ("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 = [ (T.append "with:" k , withValue v explodeTag) - , (T.append "snippet:" k, withValue v snippetTag) - , (T.append "value:" k , withValue v valueTag ) - ] - in newBindings ++ bindings diff --git a/src/Text/Templating/Heist/Splices/Markdown.hs b/src/Text/Templating/Heist/Splices/Markdown.hs deleted file mode 100644 --- a/src/Text/Templating/Heist/Splices/Markdown.hs +++ /dev/null @@ -1,183 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-| The \"markdown\" splice formats markdown content as HTML and inserts -it into the document. - -If the file attribute is present the contents of the tag is ignored and -the file specified is converted to HTML. - -Otherwise the non-markup children of the tag are processed as markdown -and converted to HTML. - -This splice requires that the \"pandoc\" executable is in your path. --} -module Text.Templating.Heist.Splices.Markdown where - ------------------------------------------------------------------------------- -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as BC -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Data.Maybe -import Control.Concurrent -import Control.Exception (throwIO) -import Control.Monad -import Control.Monad.CatchIO -import Control.Monad.Trans -import Data.Typeable -import Prelude hiding (catch) -import System.Directory -import System.Exit -import System.FilePath.Posix -import System.IO -import System.Process -import Text.XmlHtml - ------------------------------------------------------------------------------- -import Text.Templating.Heist.Internal -import Text.Templating.Heist.Types - -data PandocMissingException = PandocMissingException - deriving (Typeable) - -instance Show PandocMissingException where - show PandocMissingException = - "Cannot find the \"pandoc\" executable; is it on your $PATH?" - -instance Exception PandocMissingException - - -data MarkdownException = MarkdownException ByteString - deriving (Typeable) - -instance Show MarkdownException where - show (MarkdownException e) = - "Markdown error: pandoc replied:\n\n" ++ BC.unpack e - -instance Exception MarkdownException - - -data NoMarkdownFileException = NoMarkdownFileException - deriving (Typeable) - -instance Show NoMarkdownFileException where - show NoMarkdownFileException = - "Markdown error: no file or template in context" ++ - " during processing of markdown tag" - -instance Exception NoMarkdownFileException where - ------------------------------------------------------------------------------- --- | Default name for the markdown splice. -markdownTag :: Text -markdownTag = "markdown" - ------------------------------------------------------------------------------- --- | Implementation of the markdown splice. -markdownSplice :: MonadIO m => Splice m -markdownSplice = do - templateDir <- liftM (fmap takeDirectory) getTemplateFilePath - pdMD <- liftIO $ findExecutable "pandoc" - - when (isNothing pdMD) $ liftIO $ throwIO PandocMissingException - - tree <- getParamNode - (source,markup) <- liftIO $ - case getAttribute "file" tree of - Just f -> do - m <- maybe (liftIO $ throwIO NoMarkdownFileException ) - (\tp -> pandoc (fromJust pdMD) tp $ T.unpack f) - templateDir - return (T.unpack f,m) - Nothing -> do - m <- pandocBS (fromJust pdMD) $ T.encodeUtf8 $ nodeText tree - return ("inline_splice",m) - - let ee = parseHTML source markup - case ee of - Left e -> throw $ MarkdownException - $ BC.pack ("Error parsing markdown output: " ++ e) - Right d -> return (docContent d) - - -pandoc :: FilePath -> FilePath -> FilePath -> IO ByteString -pandoc pandocPath templateDir inputFile = do - (ex, sout, serr) <- readProcessWithExitCode' pandocPath args "" - - when (isFail ex) $ throw $ MarkdownException serr - return $ BC.concat [ "
\n" - , sout - , "\n
" ] - - where - isFail ExitSuccess = False - isFail _ = True - - args = [ "-S", "--no-wrap", templateDir inputFile ] - - -pandocBS :: FilePath -> ByteString -> IO ByteString -pandocBS pandocPath s = do - -- using the crummy string functions for convenience here - (ex, sout, serr) <- readProcessWithExitCode' pandocPath args s - - when (isFail ex) $ throw $ MarkdownException serr - return $ BC.concat [ "
\n" - , sout - , "\n
" ] - - where - isFail ExitSuccess = False - isFail _ = True - args = [ "-S", "--no-wrap" ] - - --- a version of readProcessWithExitCode that does I/O properly -readProcessWithExitCode' - :: FilePath -- ^ command to run - -> [String] -- ^ any arguments - -> ByteString -- ^ standard input - -> IO (ExitCode,ByteString,ByteString) -- ^ exitcode, stdout, stderr -readProcessWithExitCode' cmd args input = do - (Just inh, Just outh, Just errh, pid) <- - createProcess (proc cmd args){ std_in = CreatePipe, - std_out = CreatePipe, - std_err = CreatePipe } - outMVar <- newEmptyMVar - - outM <- newEmptyMVar - errM <- newEmptyMVar - - -- fork off a thread to start consuming stdout - forkIO $ do - out <- B.hGetContents outh - putMVar outM out - putMVar outMVar () - - -- fork off a thread to start consuming stderr - forkIO $ do - err <- B.hGetContents errh - putMVar errM err - putMVar outMVar () - - -- now write and flush any input - when (not (B.null input)) $ do B.hPutStr inh input; hFlush inh - hClose inh -- done with stdin - - -- wait on the output - takeMVar outMVar - takeMVar outMVar - hClose outh - - -- wait on the process - ex <- waitForProcess pid - - out <- readMVar outM - err <- readMVar errM - - return (ex, out, err) - - - - diff --git a/src/Text/Templating/Heist/TemplateDirectory.hs b/src/Text/Templating/Heist/TemplateDirectory.hs deleted file mode 100644 --- a/src/Text/Templating/Heist/TemplateDirectory.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-| - -This module defines a TemplateDirectory data structure for convenient -interaction with templates within web apps. - --} - -module Text.Templating.Heist.TemplateDirectory - ( TemplateDirectory - , newTemplateDirectory - , newTemplateDirectory' - - , getDirectoryTS - , reloadTemplateDirectory - ) where - ------------------------------------------------------------------------------- -import Control.Concurrent -import Control.Monad -import Control.Monad.Trans -import Text.Templating.Heist -import Text.Templating.Heist.Splices.Cache - - ------------------------------------------------------------------------------- --- | Structure representing a template directory. -data TemplateDirectory m - = TemplateDirectory - FilePath - (HeistState m) - (MVar (HeistState m)) - CacheTagState - - ------------------------------------------------------------------------------- --- | Creates and returns a new 'TemplateDirectory' wrapped in an Either for --- error handling. -newTemplateDirectory :: (MonadIO m, MonadIO n) - => FilePath - -> HeistState m - -> n (Either String (TemplateDirectory m)) -newTemplateDirectory dir templateState = liftIO $ do - (modTs,cts) <- mkCacheTag - let origTs = modTs templateState - ets <- loadTemplates dir origTs - leftPass ets $ \ts -> do - tsMVar <- newMVar $ ts - return $ TemplateDirectory dir origTs tsMVar cts - - ------------------------------------------------------------------------------- --- | Creates and returns a new 'TemplateDirectory', using the monad's fail --- function on error. -newTemplateDirectory' :: (MonadIO m, MonadIO n) - => FilePath - -> HeistState m - -> n (TemplateDirectory m) -newTemplateDirectory' = ((either fail return =<<) .) . newTemplateDirectory - - ------------------------------------------------------------------------------- --- | Gets the 'HeistState' from a TemplateDirectory. -getDirectoryTS :: (Monad m, MonadIO n) - => TemplateDirectory m - -> n (HeistState m) -getDirectoryTS (TemplateDirectory _ _ tsMVar _) = liftIO $ readMVar $ tsMVar - - ------------------------------------------------------------------------------- --- | Clears cached content and reloads templates from disk. -reloadTemplateDirectory :: (MonadIO m, MonadIO n) - => TemplateDirectory m - -> n (Either String ()) -reloadTemplateDirectory (TemplateDirectory p origTs tsMVar cts) = liftIO $ do - clearCacheTagState cts - ets <- loadTemplates p origTs - leftPass ets $ \ts -> modifyMVar_ tsMVar (const $ return ts) - - ------------------------------------------------------------------------------- --- | Prepends an error onto a Left. -leftPass :: Monad m => Either String b -> (b -> m c) -> m (Either String c) -leftPass e m = either (return . Left . loadError) (liftM Right . m) e - where - loadError = (++) "Error loading templates: " diff --git a/src/Text/Templating/Heist/Types.hs b/src/Text/Templating/Heist/Types.hs deleted file mode 100644 --- a/src/Text/Templating/Heist/Types.hs +++ /dev/null @@ -1,406 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UndecidableInstances #-} - -{-| - -This module contains the core Heist data types. HeistT intentionally -does not expose any of its functionality via MonadState or MonadReader -functions. We define passthrough instances for the most common types of -monads. These instances allow the user to use HeistT in a monad stack -without needing calls to `lift`. - -Edward Kmett wrote most of the HeistT code and associated instances, -liberating us from the unused writer portion of RWST. - --} - -module Text.Templating.Heist.Types where - ------------------------------------------------------------------------------- -import Control.Applicative -import Control.Arrow -import Control.Monad.CatchIO -import Control.Monad.Cont -import Control.Monad.Error -import Control.Monad.Reader -import Control.Monad.State -import Data.ByteString.Char8 (ByteString) -import qualified Data.HashMap.Strict as H -import Data.HashMap.Strict (HashMap) -import Data.Monoid -import Data.Text (Text) -import Data.Typeable -import Prelude hiding (catch) -import qualified Text.XmlHtml as X - - ------------------------------------------------------------------------------- --- | A 'Template' is a forest of XML nodes. Here we deviate from the "single --- root node" constraint of well-formed XML because we want to allow templates --- to contain fragments of a document that may not have a single root. -type Template = [X.Node] - - ------------------------------------------------------------------------------- --- | MIME Type. The type alias is here to make the API clearer. -type MIMEType = ByteString - - ------------------------------------------------------------------------------- --- | Reversed list of directories. This holds the path to the template --- currently being processed. -type TPath = [ByteString] - - -data DocumentFile = DocumentFile - { dfDoc :: X.Document - , dfFile :: Maybe FilePath - } deriving (Eq) - ------------------------------------------------------------------------------- --- | All documents representing templates are stored in a map. -type TemplateMap = HashMap TPath DocumentFile - - ------------------------------------------------------------------------------- --- | A Splice is a HeistT computation that returns a 'Template'. -type Splice m = HeistT m Template - - ------------------------------------------------------------------------------- --- | SpliceMap associates a name and a Splice. -type SpliceMap m = HashMap Text (Splice m) - - ------------------------------------------------------------------------------- --- | Holds all the state information needed for template processing. You will --- build a @HeistState@ using any of Heist's @HeistState m -> HeistState m@ --- \"filter\" functions. Then you use the resulting @HeistState@ in calls to --- @renderTemplate@. -data HeistState m = HeistState { - -- | A mapping of splice names to splice actions - _spliceMap :: SpliceMap m - -- | A mapping of template names to templates - , _templateMap :: TemplateMap - -- | A flag to control splice recursion - , _recurse :: Bool - -- | The path to the template currently being processed. - , _curContext :: TPath - -- | A counter keeping track of the current recursion depth to prevent - -- infinite loops. - , _recursionDepth :: Int - -- | A hook run on all templates at load time. - , _onLoadHook :: Template -> IO Template - -- | A hook run on all templates just before they are rendered. - , _preRunHook :: Template -> m Template - -- | A hook run on all templates just after they are rendered. - , _postRunHook :: Template -> m Template - -- | The doctypes encountered during template processing. - , _doctypes :: [X.DocType] - -- | The full path to the current template's file on disk. - , _curTemplateFile :: Maybe FilePath -} - - ------------------------------------------------------------------------------- --- | Gets the names of all the templates defined in a HeistState. -templateNames :: HeistState m -> [TPath] -templateNames ts = H.keys $ _templateMap ts - - ------------------------------------------------------------------------------- --- | Gets the names of all the splices defined in a HeistState. -spliceNames :: HeistState m -> [Text] -spliceNames ts = H.keys $ _spliceMap ts - - ------------------------------------------------------------------------------- -instance (Monad m) => Monoid (HeistState m) where - mempty = HeistState H.empty H.empty True [] 0 - return return return [] Nothing - - (HeistState s1 t1 r1 _ d1 o1 b1 a1 dt1 ctf1) `mappend` - (HeistState s2 t2 r2 c2 d2 o2 b2 a2 dt2 ctf2) = - HeistState s t r c2 d (o1 >=> o2) (b1 >=> b2) (a1 >=> a2) - (dt1 `mappend` dt2) ctf - where - s = s1 `mappend` s2 - t = t1 `mappend` t2 - r = r1 && r2 - d = max d1 d2 - ctf = getLast $ Last ctf1 `mappend` Last ctf2 - - ------------------------------------------------------------------------------- -instance Eq (HeistState m) where - a == b = (_recurse a == _recurse b) && - (_templateMap a == _templateMap b) && - (_curContext a == _curContext b) - - ------------------------------------------------------------------------------- --- | The Typeable instance is here so Heist can be dynamically executed with --- Hint. -templateStateTyCon :: TyCon -templateStateTyCon = mkTyCon "Text.Templating.Heist.HeistState" -{-# NOINLINE templateStateTyCon #-} - -instance (Typeable1 m) => Typeable (HeistState m) where - typeOf _ = mkTyConApp templateStateTyCon [typeOf1 (undefined :: m ())] - - ------------------------------------------------------------------------------- --- | HeistT is the monad used for 'Splice' processing. HeistT provides --- \"passthrough\" instances for many of the monads you might use in the inner --- monad. -newtype HeistT m a = HeistT { - runHeistT :: X.Node - -> HeistState m - -> m (a, HeistState m) -} - - ------------------------------------------------------------------------------- --- | Evaluates a template monad as a computation in the underlying monad. -evalHeistT :: Monad m - => HeistT m a - -> X.Node - -> HeistState m - -> m a -evalHeistT m r s = do - (a, _) <- runHeistT m r s - return a -{-# INLINE evalHeistT #-} - - ------------------------------------------------------------------------------- --- | Functor instance -instance Functor m => Functor (HeistT m) where - fmap f (HeistT m) = HeistT $ \r s -> first f <$> m r s - - ------------------------------------------------------------------------------- --- | Applicative instance -instance (Monad m, Functor m) => Applicative (HeistT m) where - pure = return - (<*>) = ap - - ------------------------------------------------------------------------------- --- | Monad instance -instance Monad m => Monad (HeistT m) where - return a = HeistT (\_ s -> return (a, s)) - {-# INLINE return #-} - HeistT m >>= k = HeistT $ \r s -> do - (a, s') <- m r s - runHeistT (k a) r s' - {-# INLINE (>>=) #-} - - ------------------------------------------------------------------------------- --- | MonadIO instance -instance MonadIO m => MonadIO (HeistT m) where - liftIO = lift . liftIO - - ------------------------------------------------------------------------------- --- | MonadTrans instance -instance MonadTrans HeistT where - lift m = HeistT $ \_ s -> do - a <- m - return (a, s) - - ------------------------------------------------------------------------------- --- | MonadCatchIO instance -instance MonadCatchIO m => MonadCatchIO (HeistT m) where - catch (HeistT a) h = HeistT $ \r s -> do - let handler e = runHeistT (h e) r s - catch (a r s) handler - block (HeistT m) = HeistT $ \r s -> block (m r s) - unblock (HeistT m) = HeistT $ \r s -> unblock (m r s) - - ------------------------------------------------------------------------------- --- | MonadFix passthrough instance -instance MonadFix m => MonadFix (HeistT m) where - mfix f = HeistT $ \r s -> - mfix $ \ (a, _) -> runHeistT (f a) r s - - ------------------------------------------------------------------------------- --- | Alternative passthrough instance -instance (Functor m, MonadPlus m) => Alternative (HeistT m) where - empty = mzero - (<|>) = mplus - - ------------------------------------------------------------------------------- --- | MonadPlus passthrough instance -instance MonadPlus m => MonadPlus (HeistT m) where - mzero = lift mzero - m `mplus` n = HeistT $ \r s -> - runHeistT m r s `mplus` runHeistT n r s - - ------------------------------------------------------------------------------- --- | MonadState passthrough instance -instance MonadState s m => MonadState s (HeistT m) where - get = lift get - {-# INLINE get #-} - put = lift . put - {-# INLINE put #-} - - ------------------------------------------------------------------------------- --- | MonadReader passthrough instance -instance MonadReader r m => MonadReader r (HeistT m) where - ask = HeistT $ \_ s -> do - r <- ask - return (r,s) - local f (HeistT m) = - HeistT $ \r s -> local f (m r s) - - ------------------------------------------------------------------------------- --- | Helper for MonadError instance. -liftCatch :: (m (a,HeistState m) - -> (e -> m (a,HeistState m)) - -> m (a,HeistState m)) - -> HeistT m a - -> (e -> HeistT m a) - -> HeistT m a -liftCatch ce m h = - HeistT $ \r s -> - (runHeistT m r s `ce` - (\e -> runHeistT (h e) r s)) - - ------------------------------------------------------------------------------- --- | MonadError passthrough instance -instance (MonadError e m) => MonadError e (HeistT m) where - throwError = lift . throwError - catchError = liftCatch catchError - - ------------------------------------------------------------------------------- --- | Helper for MonadCont instance. -liftCallCC :: ((((a,HeistState m) -> m (b, HeistState m)) - -> m (a, HeistState m)) - -> m (a, HeistState m)) - -> ((a -> HeistT m b) -> HeistT m a) - -> HeistT m a -liftCallCC ccc f = HeistT $ \r s -> - ccc $ \c -> - runHeistT (f (\a -> HeistT $ \_ _ -> c (a, s))) r s - - ------------------------------------------------------------------------------- --- | MonadCont passthrough instance -instance (MonadCont m) => MonadCont (HeistT m) where - callCC = liftCallCC callCC - - ------------------------------------------------------------------------------- --- | The Typeable instance is here so Heist can be dynamically executed with --- Hint. -templateMonadTyCon :: TyCon -templateMonadTyCon = mkTyCon "Text.Templating.Heist.HeistT" -{-# NOINLINE templateMonadTyCon #-} - -instance (Typeable1 m) => Typeable1 (HeistT m) where - typeOf1 _ = mkTyConApp templateMonadTyCon [typeOf1 (undefined :: m ())] - - ------------------------------------------------------------------------------- --- Functions for our monad. ------------------------------------------------------------------------------- - - ------------------------------------------------------------------------------- --- | Gets the node currently being processed. --- --- > --- > To sleep, perchance to dream. --- > --- --- When you call @getParamNode@ inside the code for the @speech@ splice, it --- returns the Node for the @speech@ tag and its children. @getParamNode >>= --- childNodes@ returns a list containing one 'TextNode' containing part of --- Hamlet's speech. @liftM (getAttribute \"author\") getParamNode@ would --- return @Just "Shakespeare"@. -getParamNode :: Monad m => HeistT m X.Node -getParamNode = HeistT $ \r s -> return (r,s) -{-# INLINE getParamNode #-} - - ------------------------------------------------------------------------------- --- | HeistT's 'local'. -localParamNode :: Monad m - => (X.Node -> X.Node) - -> HeistT m a - -> HeistT m a -localParamNode f m = HeistT $ \r s -> runHeistT m (f r) s -{-# INLINE localParamNode #-} - - ------------------------------------------------------------------------------- --- | HeistT's 'gets'. -getsTS :: Monad m => (HeistState m -> r) -> HeistT m r -getsTS f = HeistT $ \_ s -> return (f s, s) -{-# INLINE getsTS #-} - - ------------------------------------------------------------------------------- --- | HeistT's 'get'. -getTS :: Monad m => HeistT m (HeistState m) -getTS = HeistT $ \_ s -> return (s, s) -{-# INLINE getTS #-} - - ------------------------------------------------------------------------------- --- | HeistT's 'put'. -putTS :: Monad m => HeistState m -> HeistT m () -putTS s = HeistT $ \_ _ -> return ((), s) -{-# INLINE putTS #-} - - ------------------------------------------------------------------------------- --- | HeistT's 'modify'. -modifyTS :: Monad m - => (HeistState m -> HeistState m) - -> HeistT m () -modifyTS f = HeistT $ \_ s -> return ((), f s) -{-# INLINE modifyTS #-} - - ------------------------------------------------------------------------------- --- | Restores the HeistState. This function is almost like putTS except it --- preserves the current doctypes. You should use this function instead of --- @putTS@ to restore an old state. This was needed because doctypes needs to --- be in a "global scope" as opposed to the template call "local scope" of --- state items such as recursionDepth, curContext, and spliceMap. -restoreTS :: Monad m => HeistState m -> HeistT m () -restoreTS old = modifyTS (\cur -> old { _doctypes = _doctypes cur }) -{-# INLINE restoreTS #-} - - ------------------------------------------------------------------------------- --- | Abstracts the common pattern of running a HeistT computation with --- a modified heist state. -localTS :: Monad m - => (HeistState m -> HeistState m) - -> HeistT m a - -> HeistT m a -localTS f k = do - ts <- getTS - putTS $ f ts - res <- k - restoreTS ts - return res -{-# INLINE localTS #-} - diff --git a/test/heist-testsuite.cabal b/test/heist-testsuite.cabal --- a/test/heist-testsuite.cabal +++ b/test/heist-testsuite.cabal @@ -8,33 +8,89 @@ main-is: TestSuite.hs build-depends: - QuickCheck >= 2, - aeson >= 0.4 && < 0.7, - attoparsec >= 0.10 && < 0.11, - base >= 4 && < 5, - blaze-builder >= 0.2 && < 0.4, - blaze-html >= 0.4 && < 0.6, - bytestring, - containers, - directory, - directory-tree, - process, - filepath, - xmlhtml >= 0.1.6 && < 0.3, HUnit >= 1.2 && < 2, - mtl >= 2, - random, - MonadCatchIO-transformers >= 0.2.1 && < 0.3, + QuickCheck >= 2, + MonadCatchIO-transformers >= 0.2.1 && < 0.4, test-framework >= 0.6 && <0.7, test-framework-hunit >= 0.2.7 && <0.3, test-framework-quickcheck2 >= 0.2.12.1 && <0.3, - text >= 0.10 && < 0.12, - time, - transformers, - unordered-containers >= 0.1.4 && < 0.3, - vector >= 0.9 && < 0.10 + aeson >= 0.6 && < 0.7, + attoparsec >= 0.10 && < 0.11, + base >= 4 && < 5, + blaze-builder >= 0.2 && < 0.4, + blaze-html >= 0.4 && < 0.6, + bytestring >= 0.9 && < 0.11, + containers >= 0.2 && < 0.6, + directory >= 1.1 && < 1.3, + directory-tree >= 0.10 && < 0.12, + dlist >= 0.5 && < 0.6, + errors >= 1.3 && < 1.4, + filepath >= 1.3 && < 1.4, + hashable >= 1.1 && < 1.2, + mtl >= 2.0 && < 2.2, + process >= 1.1 && < 1.2, + random >= 1.0.1.0 && < 1.1, + text >= 0.10 && < 0.12, + time >= 1.1 && < 1.5, + transformers >= 0.2 && < 0.4, + unordered-containers >= 0.1.4 && < 0.3, + vector >= 0.9 && < 0.11, + xmlhtml >= 0.1.6 && < 0.3 ghc-options: -O2 -Wall -fhpc -fwarn-tabs -funbox-strict-fields -threaded Extensions: OverloadedStrings + +Executable benchmark + hs-source-dirs: ../src suite + main-is: Benchmark.hs + + build-depends: + MonadCatchIO-transformers >= 0.3 && < 0.4, + HUnit >= 1.2 && < 1.3, + criterion >= 0.6 && < 0.7, + test-framework >= 0.4 && < 0.7, + test-framework-hunit >= 0.2 && < 0.3, + + -- Copied from regular dependencies: + + aeson >= 0.6 && < 0.7, + attoparsec >= 0.10 && < 0.11, + base >= 4 && < 5, + blaze-builder >= 0.2 && < 0.4, + blaze-html >= 0.4 && < 0.6, + bytestring >= 0.9 && < 0.11, + containers >= 0.2 && < 0.6, + directory >= 1.1 && < 1.3, + directory-tree >= 0.10 && < 0.12, + dlist >= 0.5 && < 0.6, + errors >= 1.3 && < 1.4, + filepath >= 1.3 && < 1.4, + hashable >= 1.1 && < 1.2, + mtl >= 2.0 && < 2.2, + process >= 1.1 && < 1.2, + random >= 1.0.1.0 && < 1.1, + text >= 0.10 && < 0.12, + time >= 1.1 && < 1.5, + transformers >= 0.2 && < 0.4, + unordered-containers >= 0.1.4 && < 0.3, + vector >= 0.9 && < 0.11, + xmlhtml >= 0.1.6 && < 0.3 + + ghc-options: -O2 -Wall -fwarn-tabs -funbox-strict-fields -threaded + -fno-warn-unused-do-bind -rtsopts + + ghc-prof-options: -prof -auto-all + + Extensions: + GeneralizedNewtypeDeriving, + PackageImports, + ScopedTypeVariables, + DeriveDataTypeable, + FlexibleInstances, + MultiParamTypeClasses, + UndecidableInstances, + OverloadedStrings, + TypeSynonymInstances, + NoMonomorphismRestriction diff --git a/test/runTestsAndCoverage.sh b/test/runTestsAndCoverage.sh --- a/test/runTestsAndCoverage.sh +++ b/test/runTestsAndCoverage.sh @@ -24,13 +24,13 @@ mkdir -p $DIR EXCLUDES='Main -Data.CIByteString -Snap.Internal.Http.Parser.Tests -Snap.Internal.Http.Server.Tests -Snap.Internal.Http.Types.Tests -Snap.Internal.Iteratee.Tests -Text.Snap.Templates.Tests -Snap.Test.Common' +Heist.Compiled.Tests +Heist.Interpreted.Tests +Heist.Tutorial.AttributeSplices +Heist.Tutorial.CompiledSplices +Heist.Tutorial.Imports +Heist.TestCommon +Heist.Tests' EXCL="" diff --git a/test/suite/Benchmark.hs b/test/suite/Benchmark.hs new file mode 100644 --- /dev/null +++ b/test/suite/Benchmark.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +------------------------------------------------------------------------------ +import Blaze.ByteString.Builder +import Criterion +import Criterion.Main +import Criterion.Measurement hiding (getTime) +import Control.Concurrent +import Control.Error +import Control.Exception (evaluate) +import Control.Monad +import qualified Data.ByteString as B +import qualified Data.DList as DL +import qualified Data.Text as T +import Data.Text.Encoding +import Data.Time.Clock +import Data.Maybe +import qualified Text.XmlHtml as X +import System.Environment + +import Heist +import Heist.Common +import qualified Heist.Compiled as C +import qualified Heist.Compiled.Internal as CI +import qualified Heist.Interpreted as I +import Heist.TestCommon +import Heist.Types + +loadWithCache baseDir = do + etm <- runEitherT $ do + templates <- loadTemplates baseDir + let hc = HeistConfig [] defaultLoadTimeSplices [] [] templates + initHeistWithCacheTag hc + either (error . unlines) (return . fst) etm + +main = do + (dir:file:_) <- getArgs + applyComparison dir file + +justRender dir = do + let page = "faq" + pageStr = T.unpack $ decodeUtf8 page + hs <- loadWithCache dir + let !compiledTemplate = fst $! fromJust $! C.renderTemplate hs page + compiledAction = do + res <- compiledTemplate + return $! toByteString $! res + out <- compiledAction + putStrLn $ "Rendered ByteString of length "++(show $ B.length out) + B.writeFile (pageStr++".out.compiled."++dir) $ out + + defaultMain + [ bench (pageStr++"-compiled (just render)") (whnfIO compiledAction) + ] + +------------------------------------------------------------------------------ +applyComparison :: FilePath -> String -> IO () +applyComparison dir pageStr = do + let page = encodeUtf8 $ T.pack pageStr + hs <- loadWithCache dir + let compiledAction = do + res <- fst $ fromJust $ C.renderTemplate hs page + return $! toByteString $! res + out <- compiledAction + B.writeFile (pageStr++".out.compiled."++dir) $ out + + let interpretedAction = do + res <- I.renderTemplate hs page + return $! toByteString $! fst $! fromJust res + out2 <- interpretedAction + B.writeFile (pageStr++".out.interpreted."++dir) $ out + + defaultMain + [ bench (pageStr++"-compiled") (whnfIO compiledAction) + , bench (pageStr++"-interpreted") (whnfIO interpretedAction) + ] + +cmdLineTemplate :: String -> String -> IO () +cmdLineTemplate dir page = do +-- args <- getArgs +-- let page = head args +-- let dir = "test/snap-website" + hs <- loadHS dir + let action = fst $ fromJust $ C.renderTemplate hs + (encodeUtf8 $ T.pack page) + out <- action + B.writeFile (page++".out.cur") $ toByteString out + +-- reference <- B.readFile "faq.out" +-- if False +-- then do +-- putStrLn "Template didn't render properly" +-- error "Aborting" +-- else +-- putStrLn "Template rendered correctly" + + defaultMain [ + bench (page++"-speed") action + ] + + +testNode = + X.Element "div" [("foo", "aoeu"), ("bar", "euid")] + [X.Element "b" [] [X.TextNode "bolded text"] + ,X.TextNode " not bolded" + ,X.Element "a" [("href", "/path/to/page")] [X.TextNode "link"] + ] + +getChunks templateName = do + hs <- loadHS "snap-website-nocache" + let (Just t) = lookupTemplate templateName hs _compiledTemplateMap + return $! fst $! fst t + diff --git a/test/suite/Heist/Compiled/Tests.hs b/test/suite/Heist/Compiled/Tests.hs new file mode 100644 --- /dev/null +++ b/test/suite/Heist/Compiled/Tests.hs @@ -0,0 +1,38 @@ +module Heist.Compiled.Tests + ( tests + ) where + +import Test.Framework (Test) +import Test.Framework.Providers.HUnit +import qualified Test.HUnit as H + + +------------------------------------------------------------------------------ +import Heist.Tutorial.CompiledSplices + +-- NOTE: We can't test compiled templates on the templates directory as it +-- stands today because that directory contains some error conditions such as +-- infinite bind loops, apply tags with no template attribute, and apply tags +-- with ".." in the tag path (which doesn't currently work). + +tests :: [Test] +tests = [ testCase "compiled/simple" simpleCompiledTest + , testCase "compiled/people" peopleTest + ] + +simpleCompiledTest :: IO () +simpleCompiledTest = do + res <- runWithStateSplice "templates" + H.assertEqual "compiled state splice" expected res + where + expected = + " 3 " + +peopleTest :: IO () +peopleTest = do + res <- personListTest "templates" + H.assertEqual "people splice" expected res + where + expected = + "

Doe, John: 42 years old

Smith, Jane: 21 years old

" + diff --git a/test/suite/Heist/Interpreted/Tests.hs b/test/suite/Heist/Interpreted/Tests.hs new file mode 100644 --- /dev/null +++ b/test/suite/Heist/Interpreted/Tests.hs @@ -0,0 +1,658 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Heist.Interpreted.Tests + ( tests + , quickRender + ) where + +------------------------------------------------------------------------------ +import Blaze.ByteString.Builder +import Control.Error +import Control.Monad.State +import Data.Aeson +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as L +import qualified Data.HashMap.Strict as Map +import Data.Maybe +import Data.Monoid +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Text (Text) +import System.IO.Unsafe +import Test.Framework (Test) +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 +import qualified Test.HUnit as H +import Test.QuickCheck +import Test.QuickCheck.Monadic + + +------------------------------------------------------------------------------ +import Heist +import Heist.Common +import Heist.Interpreted.Internal +import Heist.Splices.Apply +import Heist.Splices.Ignore +import Heist.Splices.Json +import Heist.Splices.Markdown +import Heist.TestCommon +import Heist.Types +import qualified Text.XmlHtml as X +import qualified Text.XmlHtml.Cursor as X + + +------------------------------------------------------------------------------ +tests :: [Test] +tests = [ testProperty "heist/simpleBind" simpleBindTest + , testProperty "heist/simpleApply" simpleApplyTest + , testCase "heist/templateAdd" addTest + , testCase "heist/hasTemplate" hasTemplateTest + , testCase "heist/getDoc" getDocTest + , testCase "heist/load" loadTest + , testCase "heist/fsLoad" fsLoadTest + , testCase "heist/renderNoName" renderNoNameTest + , testCase "heist/doctype" doctypeTest + , testCase "heist/attributeSubstitution" attrSubstTest + , testCase "heist/bindAttribute" bindAttrTest + , testCase "heist/markdown" markdownTest + , testCase "heist/title_expansion" titleExpansion + , testCase "heist/textarea_expansion" textareaExpansion + , testCase "heist/div_expansion" divExpansion + , testCase "heist/bind_param" bindParam + , testCase "heist/markdownText" markdownTextTest + , testCase "heist/apply" applyTest + , testCase "heist/ignore" ignoreTest + , testCase "heist/lookupTemplateContext" lookupTemplateTest + , testCase "heist/attrSpliceContext" attrSpliceContext + , testCase "heist/json/values" jsonValueTest + , testCase "heist/json/object" jsonObjectTest + ] + + +------------------------------------------------------------------------------ +simpleBindTest :: Property +simpleBindTest = monadicIO $ forAllM arbitrary prop + where + prop :: Bind -> PropertyM IO () + prop bind = do + let template = buildBindTemplate bind + let result = buildResult bind + + spliceResult <- run $ do + hs <- loadEmpty defaultLoadTimeSplices [] [] [] + evalHeistT (runNodeList template) + (X.TextNode "") hs + + assert $ result == spliceResult + + +------------------------------------------------------------------------------ +simpleApplyTest :: Property +simpleApplyTest = monadicIO $ forAllM arbitrary prop + where + prop :: Apply -> PropertyM IO () + prop apply = do + let correct = calcCorrect apply + result <- run $ calcResult apply + assert $ correct == result + + +------------------------------------------------------------------------------ +addTest :: IO () +addTest = do + es <- loadEmpty [] [] [] [] + let hs = addTemplate "aoeu" [] Nothing es + H.assertEqual "lookup test" (Just []) $ + fmap (X.docContent . dfDoc . fst) $ + lookupTemplate "aoeu" hs _templateMap + + +------------------------------------------------------------------------------ +hasTemplateTest :: H.Assertion +hasTemplateTest = do + ets <- loadIO "templates" [] [] [] [] + let tm = either (error "Error loading templates") _templateMap ets + hs <- loadEmpty [] [] [] [] + let hs's = setTemplates tm hs + H.assertBool "hasTemplate hs's" (hasTemplate "index" hs's) + + +------------------------------------------------------------------------------ +getDocTest :: H.Assertion +getDocTest = do + d <- getDoc "bkteoar" + H.assertBool "non-existent doc" $ isLeft d + f <- getDoc "templates/index.tpl" + H.assertBool "index doc" $ not $ isLeft f + + +------------------------------------------------------------------------------ +loadTest :: H.Assertion +loadTest = do + ets <- loadIO "templates" [] [] [] [] + either (error "Error loading templates") + (\ts -> do let tm = _templateMap ts + H.assertEqual "loadTest size" 36 $ Map.size tm + ) ets + + +------------------------------------------------------------------------------ +fsLoadTest :: H.Assertion +fsLoadTest = do + ets <- loadIO "templates" [] [] [] [] + let tm = either (error "Error loading templates") _templateMap ets + es <- loadEmpty [] [] [] [] + let hs = setTemplates tm es + let f = g hs + + f isNothing "abc/def/xyz" + f isJust "a" + f isJust "bar/a" + f isJust "/bar/a" + + where + g ts p n = H.assertBool ("loading template " ++ n) $ p $ + lookupTemplate (B.pack n) ts _templateMap + +------------------------------------------------------------------------------ +renderNoNameTest :: H.Assertion +renderNoNameTest = do + ets <- loadT "templates" [] [] [] [] + either (error "Error loading templates") + (\ts -> do t <- renderTemplate ts "" + H.assertBool "renderNoName" $ isNothing t + ) ets + + +------------------------------------------------------------------------------ +doctypeTest :: H.Assertion +doctypeTest = do + ets <- loadT "templates" [] [] [] [] + let ts = either (error "Error loading templates") id ets + Just (indexDoc, _) <- renderTemplate ts "index" + H.assertEqual "index doctype test" indexRes $ toByteString $ indexDoc + Just (_, _) <- renderTemplate ts "ioc" + H.assertEqual "ioc doctype test" indexRes $ toByteString $ indexDoc + where + indexRes = B.concat + [doctype + ,"\n \n
\n/index\n
\n\n" + ] + +------------------------------------------------------------------------------ +attrSubstTest :: H.Assertion +attrSubstTest = do + ets <- loadT "templates" [] [] [] [] + let ts = either (error "Error loading templates") id ets + check "attr subst 1" (bindSplices splices ts) out1 + check "attr subst 2" ts out2 + + where + splices = defaultLoadTimeSplices ++ + [("foo", return [X.TextNode "meaning_of_everything"])] + + check str ts expected = do + Just (resDoc, _) <- renderTemplate ts "attrs" + H.assertEqual str expected $ toByteString $ resDoc + + out1 = B.unlines + [doctype + ,"Empty attribute" + ,"No ident capture" + ,"
" + ] + out2 = B.unlines + [doctype + ,"Empty attribute" + ,"No ident capture" + ,"
" + ] + + +------------------------------------------------------------------------------ +bindAttrTest :: H.Assertion +bindAttrTest = do + ets <- loadT "templates" [] [] [] [] + let ts = either (error "Error loading templates") id ets + check ts "

This is a test.

" + ] + +------------------------------------------------------------------------------ +-- | Markdown test on a file +markdownTest :: H.Assertion +markdownTest = renderTest "markdown" markdownHtmlExpected + + +------------------------------------------------------------------------------ +jsonValueTest :: H.Assertion +jsonValueTest = do + renderTest "json" jsonExpected1 + renderTest "json_snippet" jsonExpected2 + + where + jsonExpected1 = B.concat [ doctype + , "<b>ok</b>1" + , "falsefoo" ] + jsonExpected2 = B.concat + [doctype, "ok1falsefoo"] + + + +------------------------------------------------------------------------------ +jsonObjectTest :: H.Assertion +jsonObjectTest = do + renderTest "json_object" jsonExpected + where + jsonExpected = B.concat + [ doctype + , "1ok12quuxquux1ok" ] + + +------------------------------------------------------------------------------ +-- | Render a template and assert that it matches an expected result +renderTest :: ByteString -- ^ template name + -> ByteString -- ^ expected result + -> H.Assertion +renderTest templateName expectedResult = do + ets <- loadT "templates" [] [] [] [] + let ts = either (error "Error loading templates") id ets + + check ts expectedResult + + where + bind txt = bindJson v + where + v :: Value + v = fromJust $ decode txt + + check ts0 str = do + let ts = bindSplices [ + ("json", bind "[\"ok\", 1, null, false, \"foo\"]") + , ("jsonObject", + bind $ mconcat [ + "{\"foo\": 1, \"bar\": \"ok\", " + , "\"baz\": { \"baz1\": 1, \"baz2\": 2 }, " + , "\"quux\": \"quux\" }" + ]) + ] ts0 + Just (doc, _) <- renderTemplate ts templateName + let result = B.filter (/= '\n') (toByteString doc) + H.assertEqual ("Should match " ++ (show str)) str result + + +------------------------------------------------------------------------------ +-- | Expansion of a bound name inside a title-tag +titleExpansion :: H.Assertion +titleExpansion = renderTest "title_expansion" expected + where + expected = B.concat + [ doctype + , "foo" + ] + + +------------------------------------------------------------------------------ +-- | Expansion of a bound name inside a textarea-tag +textareaExpansion :: H.Assertion +textareaExpansion = renderTest "textarea_expansion" expected + where + expected = B.concat + [ "" ] + + +------------------------------------------------------------------------------ +-- | Expansion of a bound name inside a div-tag +divExpansion :: H.Assertion +divExpansion = renderTest "div_expansion" expected + where + expected = B.concat + [ doctype + , "
foo
" + ] + + +------------------------------------------------------------------------------ +-- | Handling of and bound parameters in a bound tag. +bindParam :: H.Assertion +bindParam = renderTest "bind_param" $ + B.concat [doctype, "
  • Hi there world
    • "] + + +------------------------------------------------------------------------------ +-- | Handling of and bound parameters in a bound tag. +attrSpliceContext :: H.Assertion +attrSpliceContext = renderTest "attrsubtest2" $ + B.append doctype "linkfoo" + + +------------------------------------------------------------------------------ +-- | Markdown test on supplied text +markdownTextTest :: H.Assertion +markdownTextTest = do + hs <- loadEmpty [] [] [] [] + result <- evalHeistT markdownSplice + (X.TextNode "This *is* a test.") + hs + H.assertEqual "Markdown text" markdownHtmlExpected + (B.filter (/= '\n') $ toByteString $ + X.render (X.HtmlDocument X.UTF8 (Just dt) result)) + where + dt = X.DocType "html" (X.Public "-//W3C//DTD XHTML 1.0 Strict//EN" + "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd") + X.NoInternalSubset + + +------------------------------------------------------------------------------ +applyTest :: H.Assertion +applyTest = do + es <- loadEmpty [] [] [] [] + res <- evalHeistT applyImpl + (X.Element "apply" [("template", "nonexistant")] []) es + + H.assertEqual "apply nothing" [] res + + +------------------------------------------------------------------------------ +ignoreTest :: H.Assertion +ignoreTest = do + es <- loadEmpty [] [] [] [] + res <- evalHeistT ignoreImpl + (X.Element "ignore" [("tag", "ignorable")] + [X.TextNode "This should be ignored"]) es + H.assertEqual " tag" [] res + + +lookupTemplateTest :: IO () +lookupTemplateTest = do + hs <- loadHS "templates" + let k = do + modifyHS (\st -> st { _curContext = ["foo"] }) + getsHS $ (\hs' -> lookupTemplate "/user/menu" hs' _templateMap) + res <- runHeistT k (X.TextNode "") hs + H.assertBool "lookup context test" $ isJust $ fst res + + +------------------------------------------------------------------------------ +identStartChar :: [Char] +identStartChar = ['a'..'z'] + + +------------------------------------------------------------------------------ +identChar :: [Char] +identChar = '_' : identStartChar + + +------------------------------------------------------------------------------ +textGen :: Gen [Char] +textGen = listOf $ elements ((replicate 5 ' ') ++ identStartChar) + + +------------------------------------------------------------------------------ +limitedDepth :: Int -> Gen X.Node +limitedDepth 0 = liftM (X.TextNode . T.pack) textGen +limitedDepth n = + oneof [ liftM (X.TextNode . T.pack) textGen + , liftM3 X.Element arbitrary + (liftM (take 2) arbitrary) + (liftM (take 3) $ listOf $ limitedDepth (n - 1)) + ] + + +------------------------------------------------------------------------------ +-- | Returns the number of unique insertion points in the tree. +-- If h = insertAt f n g", the following property holds: +-- insSize h == (insSize f) + (insSize g) - 1 +insSize :: [X.Node] -> Int +insSize ns = 1 + (sum $ map nodeSize ns) + where nodeSize (X.Element _ _ c) = 1 + (insSize c) + nodeSize _ = 1 + + +------------------------------------------------------------------------------ +insertAt :: [X.Node] -> Int -> [X.Node] -> [X.Node] +insertAt elems 0 ns = elems ++ ns +insertAt elems _ [] = elems +insertAt elems n list = maybe [] X.topNodes $ + evalState (processNode elems $ fromJust $ X.fromNodes list) n + + +------------------------------------------------------------------------------ +move :: Insert () +move = modify (\x -> x - 1) + + +------------------------------------------------------------------------------ +processNode :: [X.Node] -> X.Cursor -> Insert (Maybe X.Cursor) +processNode elems loc = + liftM2 mplus (move >> goDown loc) (move >> goRight loc) + + where + goDown l = + case X.current l of + X.TextNode _ -> modify (+1) >> return Nothing + X.Element _ _ _ -> doneCheck (X.insertManyFirstChild elems) + X.firstChild + l + X.Comment _ -> return Nothing + + goRight = doneCheck (Just . X.insertManyRight elems) X.right + + doneCheck insertFunc next l = do + s <- get + if s == 0 + then return $ insertFunc l + else maybe (return Nothing) (processNode elems) $ next l + + +------------------------------------------------------------------------------ +newtype Name = Name { unName :: Text } deriving (Show) + +instance Arbitrary Name where + arbitrary = do + x <- elements identStartChar + n <- choose (4,10) + rest <- vectorOf n $ elements identChar + return $ Name $ T.pack (x:rest) + +instance Arbitrary X.Node where + arbitrary = limitedDepth 3 + shrink (X.Element _ [] []) = [] + shrink (X.Element n [] (_:cs)) = [X.Element n [] cs] + shrink (X.Element n (_:as) []) = [X.Element n as []] + shrink (X.Element n as cs) = [X.Element n as (tail cs), X.Element n (tail as) cs] + shrink _ = [] + +instance Arbitrary T.Text where + arbitrary = liftM unName arbitrary + +-- +-- Code for inserting nodes into any point of a tree +-- +type Insert a = State Int a + + +------------------------------------------------------------------------------ +-- tests + +-- Data type encapsulating the parameters for a bind operation +data Bind = Bind + { _bindElemName :: Name + , _bindChildren :: [X.Node] + , _bindDoc :: [X.Node] + , _bindPos :: Int + , _bindRefPos :: Int + } -- deriving (Show) + + +instance Arbitrary Bind where + arbitrary = do + name <- arbitrary + kids <- liftM (take 3) arbitrary + doc <- liftM (take 5) arbitrary + let s = insSize doc + loc <- choose (0, s - 1) + loc2 <- choose (0, s - loc - 1) + return $ Bind name kids doc loc loc2 + shrink (Bind e [c] (_:ds) p r) = [Bind e [c] ds p r] + shrink (Bind e (_:cs) d p r) = [Bind e cs d p r] + shrink _ = [] + + +instance Show Bind where + show b@(Bind e c d p r) = unlines + [ "\n" + , "Bind element name: " ++ (show e) + , "Bind pos: " ++ (show p) + , "Bind ref pos: " ++ (show r) + , "Bind document:" + , L.unpack $ L.concat $ map formatNode d + , "Bind children:" + , L.unpack $ L.concat $ map formatNode c + , "Result:" + , L.unpack $ L.concat $ map formatNode $ buildResult b + , "Splice result:" + , L.unpack $ L.concat $ map formatNode $ unsafePerformIO $ do + hs <- loadEmpty [] [] [] [] + evalHeistT (runNodeList $ buildBindTemplate b) + (X.TextNode "") hs + , "Template:" + , L.unpack $ L.concat $ map formatNode $ buildBindTemplate b + ] + where + formatNode n = toLazyByteString $ X.render + $ X.HtmlDocument X.UTF8 Nothing [n] + +------------------------------------------------------------------------------ +buildNode :: Text -> Text -> Bind -> X.Node +buildNode tag attr (Bind s c _ _ _) = X.Element tag [(attr, unName s)] c + + +------------------------------------------------------------------------------ +buildBind :: Bind -> X.Node +buildBind = buildNode "bind" "tag" + + +------------------------------------------------------------------------------ +empty :: Text -> X.Node +empty n = X.Element n [] [] + + +------------------------------------------------------------------------------ +buildBindTemplate :: Bind -> [X.Node] +buildBindTemplate s@(Bind n _ d b r) = + insertAt [empty $ unName $ n] pos $ withBind + where bind = [buildBind s] + bindSize = insSize bind + withBind = insertAt bind b d + pos = b + bindSize - 1 + r + + +------------------------------------------------------------------------------ +buildResult :: Bind -> [X.Node] +buildResult (Bind _ c d b r) = insertAt c (b + r) d + + +------------------------------------------------------------------------------ +-- tests + +data Apply = Apply + { _applyName :: Name + , _applyCaller :: [X.Node] + , _applyCallee :: Template + , _applyChildren :: [X.Node] + , _applyPos :: Int + } deriving (Show) + + +instance Arbitrary Apply where + arbitrary = do + name <- arbitrary + kids <- liftM (take 3) $ listOf $ limitedDepth 2 + caller <- liftM (take 5) arbitrary + callee <- liftM (take 1) $ listOf $ limitedDepth 3 + let s = insSize caller + loc <- choose (0, s - 1) + return $ Apply name caller callee kids loc + + +------------------------------------------------------------------------------ +buildApplyCaller :: Apply -> [X.Node] +buildApplyCaller (Apply name caller _ kids pos) = + insertAt [X.Element "apply" [("template", unName name)] kids] pos caller + + +------------------------------------------------------------------------------ +calcCorrect :: Apply -> [X.Node] +calcCorrect (Apply _ caller callee _ pos) = insertAt callee pos caller + + +------------------------------------------------------------------------------ +calcResult :: Apply -> IO [X.Node] +calcResult apply@(Apply name _ callee _ _) = do + hs <- loadEmpty defaultLoadTimeSplices [] [] [] + let hs' = setTemplates (Map.singleton [T.encodeUtf8 $ unName name] + (DocumentFile (X.HtmlDocument X.UTF8 Nothing callee) + Nothing)) hs + evalHeistT (runNodeList $ buildApplyCaller apply) + (X.TextNode "") hs' + + + + +{- + - Convenience code for manual ghci experimentation + -} + +--html :: [Node] -> Node +--html c = X.Element "html" [] [hhead, body c] +--hhead :: Node +--hhead = X.Element "head" [] [title, X.Element "script" [] []] +--title :: Node +--title = X.Element "title" [] [X.Text "Test Page"] +--body :: [Node] -> Node +--body = X.Element "body" [] +-- +--para :: Int -> Node +--para n = X.Element "p" [] [X.Text $ B.pack $ "This is paragraph " ++ show n] +--para2 :: B.ByteString -> Node +--para2 c = X.Element "p" [] [X.Text c] +--para3 :: Node +--para3 = X.Element "p" [] [X.Text "AHA!"] +-- +--foo :: Int -> [Node] +--foo n = insertAt [X.Element "NEW" [] []] n [html [para 1, para 2]] +-- +--tdoc :: [Node] +--tdoc = [para 1, para 2, para 3, para 4] +-- +--bindElem :: [Node] -> Int -> Int -> Bind +--bindElem = Bind (Name "mytag") [para2 "bound paragraph"] +-- +--addBind :: Bind -> [Node] -> [Node] +--addBind b = insertAt [buildBind b] 0 . insertAt [empty $ unName $ _bindElemName b] 2 +-- +--prn :: Node -> IO () +--prn = L.putStrLn . formatNode +--runTests :: IO () +--runTests = defaultMain tests + diff --git a/test/suite/Heist/TestCommon.hs b/test/suite/Heist/TestCommon.hs new file mode 100644 --- /dev/null +++ b/test/suite/Heist/TestCommon.hs @@ -0,0 +1,108 @@ +module Heist.TestCommon where + +------------------------------------------------------------------------------ +import Blaze.ByteString.Builder +import Control.Error +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import qualified Data.HashMap.Strict as Map +import Data.Maybe +import Data.Text (Text) + + +------------------------------------------------------------------------------ +import Heist +import qualified Heist.Compiled as C +import qualified Heist.Interpreted as I +import qualified Heist.Interpreted.Internal as I +import qualified Text.XmlHtml as X + + +------------------------------------------------------------------------------ +-- | The default doctype given to templates +doctype :: ByteString +doctype = B.concat + [ "" ] + + +loadT :: Monad m + => FilePath + -> [(Text, I.Splice m)] + -> [(Text, I.Splice IO)] + -> [(Text, C.Splice m)] + -> [(Text, AttrSplice m)] + -> IO (Either [String] (HeistState m)) +loadT baseDir a b c d = runEitherT $ do + ts <- loadTemplates baseDir + let hc = HeistConfig a (defaultLoadTimeSplices ++ b) c d ts + initHeist hc + + +------------------------------------------------------------------------------ +loadIO :: FilePath + -> [(Text, I.Splice IO)] + -> [(Text, I.Splice IO)] + -> [(Text, C.Splice IO)] + -> [(Text, AttrSplice IO)] + -> IO (Either [String] (HeistState IO)) +loadIO baseDir a b c d = runEitherT $ do + ts <- loadTemplates baseDir + let hc = HeistConfig a (defaultLoadTimeSplices ++ b) c d ts + initHeist hc + + +------------------------------------------------------------------------------ +loadHS :: FilePath -> IO (HeistState IO) +loadHS baseDir = do + etm <- runEitherT $ do + templates <- loadTemplates baseDir + let hc = HeistConfig [] defaultLoadTimeSplices [] [] templates + initHeist hc + either (error . concat) return etm + + +loadEmpty :: [(Text, I.Splice IO)] + -> [(Text, I.Splice IO)] + -> [(Text, C.Splice IO)] + -> [(Text, AttrSplice IO)] + -> IO (HeistState IO) +loadEmpty a b c d = do + let hc = HeistConfig a (defaultLoadTimeSplices ++ b) c d Map.empty + res <- runEitherT $ initHeist hc + either (error . concat) return res + + +testTemplate :: FilePath -> ByteString -> IO ByteString +testTemplate tdir tname = do + ts <- loadHS tdir + Just (resDoc, _) <- I.renderTemplate ts tname + return $ toByteString resDoc + + +testTemplateEval :: ByteString -> IO (Maybe Template) +testTemplateEval tname = do + ts <- loadHS "templates" + md <- evalHeistT (I.evalWithDoctypes tname) (X.TextNode "") ts + return $ fmap X.docContent md + + +------------------------------------------------------------------------------ +-- | Reloads the templates from disk and renders the specified +-- template. (Old convenience code.) +quickRender :: FilePath -> ByteString -> IO (Maybe ByteString) +quickRender baseDir name = do + ts <- loadHS baseDir + res <- I.renderTemplate ts name + return (fmap (toByteString . fst) res) + +cRender :: HeistState IO -> ByteString -> IO ByteString +cRender hs name = do + builder <- fst $ fromJust $ C.renderTemplate hs name + return $ toByteString builder + +iRender :: HeistState IO -> ByteString -> IO ByteString +iRender hs name = do + builder <- I.renderTemplate hs name + return $ toByteString $ fst $ fromJust builder + diff --git a/test/suite/Heist/Tests.hs b/test/suite/Heist/Tests.hs new file mode 100644 --- /dev/null +++ b/test/suite/Heist/Tests.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE FlexibleContexts #-} +module Heist.Tests + ( tests + ) where + + +------------------------------------------------------------------------------ +import Blaze.ByteString.Builder +import Control.Monad.State +import qualified Data.ByteString.Char8 as B +import Data.List +import Data.Maybe +import Data.Monoid +import qualified Data.Text as T +import Test.Framework (Test) +import Test.Framework.Providers.HUnit +import qualified Test.HUnit as H + + +------------------------------------------------------------------------------ +import Heist +import qualified Heist.Compiled as C +import Heist.Tutorial.AttributeSplices +import Heist.Tutorial.CompiledSplices +import qualified Heist.Interpreted as I +import Heist.Splices.Cache +import Heist.Splices.Html +import Heist.TemplateDirectory + +import Heist.TestCommon + +tests :: [Test] +tests = [ testCase "loadErrors" loadErrorsTest + , testCase "attrsplice/autocheck" attrSpliceTest + , testCase "tdirCache" tdirCacheTest + , testCase "headMerge" headMergeTest + , testCase "bindApplyInteraction" bindApplyInteractionTest + , testCase "backslashHandling" backslashHandlingTest + ] + + +------------------------------------------------------------------------------ +-- | Tests that load fails correctly on errors. +loadErrorsTest :: H.Assertion +loadErrorsTest = do + ets <- loadIO "templates-bad" [] [] [] [] + either (H.assertEqual "load errors test" expected . sort) + (const $ H.assertFailure "No failure when loading templates-bad") + ets + where + expected = sort + ["templates-bad/bind-infinite-loop.tpl: template recursion exceeded max depth, you probably have infinite splice recursion!" + ,"templates-bad/apply-template-not-found.tpl: apply tag cannot find template \"/page\"" + ,"templates-bad/bind-missing-attr.tpl: must supply \"tag\" attribute in " + ,"templates-bad/apply-missing-attr.tpl: must supply \"template\" attribute in " + ] + + +attrSpliceTest :: IO () +attrSpliceTest = do + ehs <- loadT "templates" [] [] [] [("autocheck", autocheckedSplice)] + let hs = either (error . show) id ehs + runtime = fromJust $ C.renderTemplate hs "attr_splice" + + mres <- evalStateT (I.renderTemplate hs "attr_splice") "foo" + H.assertEqual "interpreted foo" expected1 + (toByteString $ fst $ fromJust mres) + mres2 <- evalStateT (I.renderTemplate hs "attr_splice") "bar" + H.assertEqual "interpreted bar" expected2 + (toByteString $ fst $ fromJust mres2) + + builder <- evalStateT (fst runtime) "foo" + H.assertEqual "compiled foo" expected3 + (toByteString builder) + builder2 <- evalStateT (fst runtime) "bar" + H.assertEqual "compiled bar" expected4 + (toByteString builder2) + where + expected1 = doctype `B.append` "\n\n\n" + expected2 = doctype `B.append` "\n\n\n" + expected3 = " " + expected4 = " " + +fooSplice :: I.Splice (StateT Int IO) +fooSplice = do + val <- get + put val + I.textSplice $ T.pack $ show val + +tdirCacheTest :: IO () +tdirCacheTest = do + let rSplices = [ ("foosplice", fooSplice) ] + dSplices = [ ("foosplice", stateSplice) ] + hc = HeistConfig rSplices [] dSplices [] mempty + td <- newTemplateDirectory' "templates" hc + + [a,b,c,d] <- evalStateT (testInterpreted td) 5 + H.assertBool "interpreted doesn't cache" $ a == b + H.assertBool "interpreted doesn't clear" $ b /= c + H.assertBool "interpreted doesn't reload" $ c /= d + + td' <- newTemplateDirectory' "templates" hc + [e,f,g,h] <- evalStateT (testCompiled td') 5 + H.assertBool "compiled doesn't cache" $ e == f + H.assertBool "compiled doesn't clear" $ f /= g + H.assertBool "compiled doesn't reload" $ g /= h + where + testInterpreted td = do + hs <- liftIO $ getDirectoryHS td + cts <- liftIO $ getDirectoryCTS td + a <- I.renderTemplate hs "cache" + modify (+1) + b <- I.renderTemplate hs "cache" + liftIO $ clearCacheTagState cts + c <- I.renderTemplate hs "cache" + modify (+1) + _ <- liftIO $ reloadTemplateDirectory td + + -- The reload changes the HeistState, so we have to get it again + hs' <- liftIO $ getDirectoryHS td + d <- I.renderTemplate hs' "cache" + return $ map (toByteString . fst . fromJust) [a,b,c,d] + + testCompiled td = do + hs <- liftIO $ getDirectoryHS td + cts <- liftIO $ getDirectoryCTS td + a <- fst $ fromJust $ C.renderTemplate hs "cache" + modify (+1) + b <- fst $ fromJust $ C.renderTemplate hs "cache" + liftIO $ clearCacheTagState cts + c <- fst $ fromJust $ C.renderTemplate hs "cache" + modify (+1) + _ <- liftIO $ reloadTemplateDirectory td + + -- The reload changes the HeistState, so we have to get it again + hs' <- liftIO $ getDirectoryHS td + d <- fst $ fromJust $ C.renderTemplate hs' "cache" + return $ map toByteString [a,b,c,d] + + +headMergeTest :: IO () +headMergeTest = do + ehs <- loadT "templates" [] [(htmlTag, htmlImpl)] [] [] + let hs = either (error . show) id ehs + runtime = fromJust $ C.renderTemplate hs "head_merge/index" + mres <- fst runtime + H.assertEqual "assertion failed" expected + (toByteString mres) + where + expected = B.intercalate "\n" + ["\n\n" + ,"\n\n" + ,"\n\n\n\n
    nav bar
    \n\n\n" + ,"
    index page
    \n\n\n " + ] + +bindApplyInteractionTest :: IO () +bindApplyInteractionTest = do + hs <- loadHS "templates" + + cOut <- cRender hs "bind-apply-interaction/caller" + H.assertEqual "compiled failure" cExpected cOut + + iOut <- iRender hs "bind-apply-interaction/caller" + H.assertEqual "interpreted failure" iExpected iOut + where + cExpected = B.intercalate "\n" + [" This is a test." + ,"===bind content=== Another test line." + ,"apply content Last test line." + ," " + ] + iExpected = B.unlines + [doctype + ," This is a test." + ,"===bind content===" + ,"Another test line." + ,"apply content" + ,"Last test line." + ,"" + ] + + +------------------------------------------------------------------------------ +-- | Test backslash escaping in the attribute parser. +backslashHandlingTest :: IO () +backslashHandlingTest = do + hs <- loadHS "templates" + cOut <- cRender hs "backslash" + H.assertEqual "compiled failure" cExpected cOut + + iOut <- iRender hs "backslash" + H.assertEqual "interpreted failure" iExpected iOut + where + cExpected = " " + iExpected = B.unlines + [doctype + ,"" + ] + diff --git a/test/suite/Heist/Tutorial/AttributeSplices.lhs b/test/suite/Heist/Tutorial/AttributeSplices.lhs new file mode 100644 --- /dev/null +++ b/test/suite/Heist/Tutorial/AttributeSplices.lhs @@ -0,0 +1,58 @@ +Attribute Splices +================= + +Attribute splices are new in Heist 0.10. They solve the problem of wanting to +be able to dynamically make empty attributes appear or disappear with a splice +without binding a splice to the whole tag. This issue comes up most +frequently when dealing with empty attributes such as HTML's "disabled" or +"checked". + +> module Heist.Tutorial.AttributeSplices where +> import Heist.Tutorial.Imports + +Consider a page with several radio buttons. You want the correct one to be +selected based on the value of a parameter in the HTTP request. The HTML +would look something like this: + + Red + Green + Blue + +We want to automatically generate the "checked" attribute appropriately. This +could be done with a splice bound to the input tag, but there might be a +number of other input tags on the page, so your splice would at best be +executed on more tags than necessary and at worst not have the granularity +necessary to work properly. The ${} syntax for splices inside of attribute +values also won't work because it can only affect an attribute's value. It +can't make the attribute disappear entirely. This problem can be solved +nicely with attribute splices that have the following type: + +< type AttrSplice m = Text -> m [(Text, Text)] + +An attribute splice is a computation in the runtime monad that takes the value +of the attribute it is bound to as its argument and returns a list of +attributes to substitute back into the tag. Here's how we might implement a +splice to solve the above problem. + +> autocheckedSplice :: Text -> StateT Text IO [(Text, Text)] +> autocheckedSplice v = do +> val <- get -- app-specific retrieval of the appropriate value here +> let checked = if v == val +> then [("checked","")] +> else [] +> return $ ("value", v) : checked + +In this toy example we are using `StateT Text IO` as our "runtime" monad where +the Text state holds the value of the radio button that should be checked. We +assume that the current value we're checking against is passed as the bound +attribute's value, so we compare that against the value to be checked. Then +we return a list with the appropriate value and the checked attribute if +necessary. We bind this splice to the "autocheck" attribute by adding it to +the hcAttributeSplices list in HeistConfig. + +To make everything work we use the following markup for our radio buttons: + + Red + Green + Blue + diff --git a/test/suite/Heist/Tutorial/CompiledSplices.lhs b/test/suite/Heist/Tutorial/CompiledSplices.lhs new file mode 100644 --- /dev/null +++ b/test/suite/Heist/Tutorial/CompiledSplices.lhs @@ -0,0 +1,269 @@ +Introduction to Compiled Heist +============================== + +Before version 0.10, Heist has essentially been an interpreter. It loads your +templates and "runs" them whenever a page is served. This is relatively +inefficient since a lot of document transformations happen every time the +template is requested. For Heist version 0.10 we completely rethought +everything with performance in mind. We call it "compiled Heist". The main +idea is to do most of your splice processing up front at load time. There is +still a mechanism for rendering dynamic information at runtime, but it is +faster than the fully interpreted approach that Heist started with. + +It should also be mentioned that the old "interpreted Heist" is not gone. You +can still use the old approach where all the transformations happen at +render time. This allows you to upgrade without making sweeping changes to +your code, and gradually convert your application to the more performant +compiled approach as you see fit. + +Before we continue it should be mentioned that you are reading real live +literate Haskell code from our test suite. All the code you see here is +compiled into our test suite and the results automatically checked by our +buildbot. So first we need to get some boilerplate and imports out of the way. + +> {-# LANGUAGE NoMonomorphismRestriction #-} +> module Heist.Tutorial.CompiledSplices where +> import Heist +> import qualified Heist.Compiled as C +> import Heist.Tutorial.Imports + +As a review, normal (interpreted) Heist splices are defined like this. + +< type Splice m = HeistT m m [Node] + +The type parameter `m` is the runtime execution monad (in a Snap application +this will usually be `Handler` or `Snap`). Don't worry about why the `m` is +there twice right now. We'll get to that later. The splice's return value is +a list of nodes that is substituted back into the document wherever the +spliced node was. + +This kind of splice proccessing involves traversing the DOM, which is +inefficient. Compiled Heist is designed so that all the DOM traversals happen +once at load time in the IO monad. This is the "compile" phase. The type +signature for compiled splices is this. + +< type Splice n = HeistT n IO (DList (Chunk n)) + +We see that where Heist splices ran in the m monad, compiled splices run in the +IO monad. This also explains why HeistT now has two monad type parameters. +The first parameter is a placeholder for the runtime monad and the second +parameter is the monad that we're actually running in now. + +But the key point of the compiled splice type signature is the return value. +They return a DList of Chunks. DList is a list that supports efficient +insertion to both the front and back of the list. The Chunk type is not +exposed publicly, but there are three ways to construct a Chunk. + +< yieldPure :: Builder -> DList (Chunk m) +< yieldRuntime :: RuntimeSplice m Builder -> DList (Chunk m) +< yieldRuntimeEffect :: Monad m => RuntimeSplice m () -> DList (Chunk m) + +If your splice output can be calculated at load time, then you should use +`yieldPure` or one of its variants. When you do this, Heist can concatenate +all adjacent pure chunks into a single precalculated ByteString that can be +rendered very efficiently. If your template needs a value that has to be +calculated at runtime, then you should use the `yieldRuntime` constructor and +supply a computation in the RuntimeSplice monad transformer that is +parameterized by `m` which we saw above is the runtime monad. Occasionally +you might want to run a runtime side effect that doesn't actually insert any +data into your template. The `yieldRuntimeEffect` function gives you that +capability. + +An Example +========== + +With that background, let's get to a real example. + +> stateSplice :: C.Splice (StateT Int IO) +> stateSplice = return $ C.yieldRuntimeText $ do +> val <- lift get +> return $ pack $ show (val+1) + +Here we see that our splice's runtime monad is `StateT Int IO`. This makes +for a simple example that can clearly demonstrate the different contexts that +we are operating in. To make things more clear, here's a version with some +print statements that clarify the details of which monad is executed when. + +> stateSplice2 :: C.Splice (StateT Int IO) +> stateSplice2 = do +> -- :: C.Splice (StateT Int IO) +> lift $ putStrLn "This executed at load time" +> let res = C.yieldRuntimeText $ do +> -- :: RuntimeSplice (StateT Int IO) a +> lift $ lift $ putStrLn "This executed at run/render time" +> val <- lift get +> return $ pack $ show (val+1) +> lift $ putStrLn "This also executed at load time" +> return res + +Note here that even though the type parameter to C.Splice is a monad, it is not +a monad transformer. RuntimeSplice, however, is. Now let's look at a simple +load function that sets up a default HeistState and loads templates from a +directory with compiled splices. + +> load :: MonadIO n +> => FilePath +> -> [(Text, C.Splice n)] +> -> IO (HeistState n) +> load baseDir splices = do +> tmap <- runEitherT $ do +> templates <- loadTemplates baseDir +> let hc = HeistConfig [] defaultLoadTimeSplices splices [] templates +> initHeist hc +> either (error . concat) return tmap + +Here's a function demonstrating all of this in action. + +> runWithStateSplice :: FilePath +> -> IO ByteString +> runWithStateSplice baseDir = do +> hs <- load baseDir [ ("div", stateSplice) ] +> let runtime = fromJust $ C.renderTemplate hs "index" +> builder <- evalStateT (fst runtime) 2 +> return $ toByteString builder + +First this function loads the templates with the above compiled splice. You +have to specify all the compiled splices in the call to loadTemplates because +loadTemplates takes care of compiling all the templates up front. If you were +able to bind compiled splices later, then all the templates would have to be +recompiled, a potentially expensive operation. Next, the function renders the +template called "index" using a runtime (StateT Int IO) seeded with a value of +2 and returns the resulting ByteString. + +Now let's look at a more complicated example. We want to render a data +structure with a compiled splice. + +> data Person = Person +> { pFirstName :: Text +> , pLastName :: Text +> , pAge :: Int +> } +> +> personSplice :: (Monad n) +> => C.Promise Person +> -> HeistT n IO (RuntimeSplice n Builder) +> personSplice = C.promiseChildrenWithText +> [ ("firstName", pFirstName) +> , ("lastName", pLastName) +> , ("age", pack . show . pAge) +> ] +> +> peopleSplice :: (Monad n) +> => n [Person] +> -> C.Splice n +> peopleSplice getPeople = C.mapPromises personSplice getPeople +> +> allPeopleSplice :: C.Splice (StateT [Person] IO) +> allPeopleSplice = peopleSplice get +> +> personListTest :: FilePath +> -> IO ByteString +> personListTest baseDir = do +> hs <- load baseDir [ ("people", allPeopleSplice) ] +> let runtime = fromJust $ C.renderTemplate hs "people" +> builder <- evalStateT (fst runtime) +> [ Person "John" "Doe" 42 +> , Person "Jane" "Smith" 21 +> ] +> return $ toByteString builder + + +Disadvantages of Compiled Heist +=============================== + +Compiled Heist is faster than the original interpreted approach, but as with +most things in computing there is a tradeoff. Compiled Heist is strictly less +powerful than interpreted Heist. There are two things that compiled Heist +loses: the ability to bind new splices on the fly at runtime and splice +recursion/composability. + +The first point follows immediately from the definition of compiled Heist. +When you decide to do all your splice DOM traversals once at load time you're +unavoidably limited to only those splices that you defined at load time. But +this seems to be a good pattern to use in general because debugging your +splices will be easier if you don't have to consider the possibility that +the handler that binds them didn't run. + +The loss of recursion/composability happens because of the change in the type +signature of splices. Interpreted splices are a essentially function `[Node] +-> m [Node]`. This means that the output of one splice can be the input of +another splice (including itself). Compiled splices are a function `[Node] -> +IO (DList (Chunk m))`. Therefore, once a splice processes some nodes, the +output is no longer something that can be passed into other splices. + +This composability turns out to be a very powerful feature. Head merging is +one feature that can't be done without it. Head merging allows you to put + tags anyhere in any template and have them all merged into a single + tag at the top of your HTML document. This is useful because it allows +you to keep concerns localized. For instance, you can have a template +represent a small piece of functionality that uses a less common javascript or +CSS file. Instead of having to depend on that resource being included in the +top-level tag, you can include it in a tag right where you're +using it. Then it will only be included on your pages when you are using the +markup that needs it. + +Our implementation of head merging uses a splice bound to the tag. +This splice removes all the nodes from its children, combines them, and +inserts them as its first child. This won't work unless the splice +first runs all its children to make sure all and tags have +happened first. And that is impossible to do with compiled splices. + +To get around this problem we added the concept of load time splices. Load +time splices are just interpreted splices that are completely executed at load +time. If interpreted splices have type `[Node] -> m [Node]` where m is the +runtime monad, then load time splices have type `[Node] -> IO [Node]`, where +IO is the monad being executed at load time. Load time splices give you the +power and composability of interpreted splices as long as they are performing +transformations that don't require runtime data. All of the built-in splices +that we ship with Heist work as load time splices. So you can still have head +merging by including our html splice in the load time splice list in your +HeistConfig. + + +A More Involved Example +======================= + +The person example above is a very common and useful pattern for using dynamic +data in splices. But it has the simplification that it always generates +output the same way. Sometimes you might want a splice's output to have one +form in some cases and a different form in other cases. A simple example is a +splice that reads some kind of a key from a request parameter then looks that +key up in some kind of map. If the key is present the splice uses its child +nodes as a view for the retrieved value, otherwise it outputs an error message. + +This pattern is a little tricky because you're making decisions about what to +render based on runtime data, but the actual rendering of child nodes has to +be done at load time. To bridge the gap and allow communication between load +time and runtime processing we provide the Promise data type. A Promise is +kind of like an IORef except that operations on them are restricted to the +appropriate Heist context. You create a new empty promise in the HeistT n IO +(load time) monad, and you operate on it in the RuntimeSplice monad. + +Here's an example of how to use a promise manually to render a splice +differently in the case of failure. + +< failingSplice :: MonadSnap m => C.Splice m +< failingSplice = do +< children <- childNodes <$> getParamNode +< promise <- C.newEmptyPromise +< outputChildren <- C.promiseChildrenWithNodes splices promise +< return $ C.yieldRuntime $ do +< -- :: RuntimeSplice m Builder +< mname <- lift $ getParam "username" +< let err = return $ fromByteString "Must supply a username" +< single name = do +< euser <- liftIO $ lookupUser $ decodeUtf8 name +< either (return . fromByteString . encodeUtf8 . T.pack) +< doUser euser +< where +< doUser value = do +< C.putPromise promise (name, value) +< outputChildren +< maybe err single mname +< +< +< splices :: [(Text, (Text, Text) -> [Node])] +< splices = [ ("user", (:[]) . TextNode . T.pack . fst) +< , ("value", (:[]) . TextNode . T.pack . snd) +< ] + diff --git a/test/suite/Heist/Tutorial/Imports.hs b/test/suite/Heist/Tutorial/Imports.hs new file mode 100644 --- /dev/null +++ b/test/suite/Heist/Tutorial/Imports.hs @@ -0,0 +1,25 @@ +module Heist.Tutorial.Imports + ( module Blaze.ByteString.Builder + , module Control.Monad + , module Control.Monad.Trans + , module Data.Maybe + , module Data.Monoid + , ST.get + , ST.StateT(..) + , ST.evalStateT + , T.Text + , T.pack + , ByteString + , runEitherT + ) where + +import Blaze.ByteString.Builder +import Control.Error (runEitherT) +import Control.Monad +import Control.Monad.Trans +import qualified Control.Monad.Trans.State as ST +import Data.ByteString.Char8 (ByteString) +import Data.Maybe +import Data.Monoid +import qualified Data.Text as T + diff --git a/test/suite/TestSuite.hs b/test/suite/TestSuite.hs --- a/test/suite/TestSuite.hs +++ b/test/suite/TestSuite.hs @@ -2,10 +2,16 @@ import Test.Framework (defaultMain, testGroup) -import qualified Text.Templating.Heist.Tests +import qualified Heist.Interpreted.Tests +import qualified Heist.Compiled.Tests +import qualified Heist.Tests + main :: IO () main = defaultMain tests - where tests = [ - testGroup "Text.Templating.Heist.Tests" - Text.Templating.Heist.Tests.tests + where tests = [ testGroup "Heist.Interpreted.Tests" + Heist.Interpreted.Tests.tests + , testGroup "Heist.Compiled.Tests" + Heist.Compiled.Tests.tests + , testGroup "Heist.Tests" + Heist.Tests.tests ] diff --git a/test/suite/Text/Templating/Heist/Tests.hs b/test/suite/Text/Templating/Heist/Tests.hs deleted file mode 100644 --- a/test/suite/Text/Templating/Heist/Tests.hs +++ /dev/null @@ -1,692 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Text.Templating.Heist.Tests - ( tests - , quickRender - ) where - ------------------------------------------------------------------------------- -import Blaze.ByteString.Builder -import Control.Monad.State -import Data.Aeson -import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Lazy.Char8 as L -import qualified Data.HashMap.Strict as Map -import Data.Maybe -import Data.Monoid -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Data.Text (Text) -import System.IO.Unsafe -import Test.Framework (Test) -import Test.Framework.Providers.HUnit -import Test.Framework.Providers.QuickCheck2 -import qualified Test.HUnit as H -import Test.QuickCheck -import Test.QuickCheck.Monadic - - ------------------------------------------------------------------------------- -import Text.Templating.Heist -import Text.Templating.Heist.Internal -import Text.Templating.Heist.Types -import Text.Templating.Heist.Splices.Apply -import Text.Templating.Heist.Splices.Ignore -import Text.Templating.Heist.Splices.Json -import Text.Templating.Heist.Splices.Markdown -import qualified Text.XmlHtml as X -import qualified Text.XmlHtml.Cursor as X - - ------------------------------------------------------------------------------- -tests :: [Test] -tests = [ testProperty "heist/simpleBind" simpleBindTest - , testProperty "heist/simpleApply" simpleApplyTest - , testCase "heist/stateMonoid" monoidTest - , testCase "heist/templateAdd" addTest - , testCase "heist/hasTemplate" hasTemplateTest - , testCase "heist/getDoc" getDocTest - , testCase "heist/load" loadTest - , testCase "heist/fsLoad" fsLoadTest - , testCase "heist/renderNoName" renderNoNameTest - , testCase "heist/doctype" doctypeTest - , testCase "heist/attributeSubstitution" attrSubstTest - , testCase "heist/bindAttribute" bindAttrTest - , testCase "heist/markdown" markdownTest - , testCase "heist/title_expansion" titleExpansion - , testCase "heist/textarea_expansion" textareaExpansion - , testCase "heist/div_expansion" divExpansion - , testCase "heist/bind_param" bindParam - , testCase "heist/markdownText" markdownTextTest - , testCase "heist/apply" applyTest - , testCase "heist/ignore" ignoreTest - , testCase "heist/lookupTemplateContext" lookupTemplateTest - , testCase "heist/attrSpliceContext" attrSpliceContext - , testCase "heist/json/values" jsonValueTest - , testCase "heist/json/object" jsonObjectTest - ] - - ------------------------------------------------------------------------------- -simpleBindTest :: Property -simpleBindTest = monadicIO $ forAllM arbitrary prop - where - prop :: Bind -> PropertyM IO () - prop bind = do - let template = buildBindTemplate bind - let result = buildResult bind - - spliceResult <- run $ evalHeistT (runNodeList template) - (X.TextNode "") - defaultHeistState - assert $ result == spliceResult - - ------------------------------------------------------------------------------- -simpleApplyTest :: Property -simpleApplyTest = monadicIO $ forAllM arbitrary prop - where - prop :: Apply -> PropertyM IO () - prop apply = do - let correct = calcCorrect apply - result <- run $ calcResult apply - assert $ correct == result - - ------------------------------------------------------------------------------- -monoidTest :: IO () -monoidTest = do - H.assertBool "left monoid identity" $ mempty `mappend` es == es - H.assertBool "right monoid identity" $ es `mappend` mempty == es - where es = defaultHeistState :: HeistState IO - - ------------------------------------------------------------------------------- -addTest :: IO () -addTest = do - H.assertEqual "lookup test" (Just []) $ - fmap (X.docContent . dfDoc . fst) $ lookupTemplate "aoeu" ts - - H.assertEqual "splice touched" 0 $ Map.size (_spliceMap ts) - - where - ts = addTemplate "aoeu" [] Nothing (mempty::HeistState IO) - - ------------------------------------------------------------------------------- -hasTemplateTest :: H.Assertion -hasTemplateTest = do - ets <- loadT "templates" - let tm = either (error "Error loading templates") _templateMap ets - let ts = setTemplates tm defaultHeistState :: HeistState IO - H.assertBool "hasTemplate ts" (hasTemplate "index" ts) - - ------------------------------------------------------------------------------- -getDocTest :: H.Assertion -getDocTest = do - d <- getDoc "bkteoar" - H.assertBool "non-existent doc" $ isLeft d - f <- getDoc "templates/index.tpl" - H.assertBool "index doc" $ not $ isLeft f - - ------------------------------------------------------------------------------- -loadTest :: H.Assertion -loadTest = do - ets <- loadT "templates" - either (error "Error loading templates") - (\ts -> do let tm = _templateMap ts - H.assertBool "loadTest size" $ Map.size tm == 26 - ) ets - - ------------------------------------------------------------------------------- -fsLoadTest :: H.Assertion -fsLoadTest = do - ets <- loadT "templates" - let tm = either (error "Error loading templates") _templateMap ets - let ts = setTemplates tm defaultHeistState :: HeistState IO - let f = g ts - - f isNothing "abc/def/xyz" - f isJust "a" - f isJust "bar/a" - f isJust "/bar/a" - - where - g ts p n = H.assertBool ("loading template " ++ n) $ p $ - lookupTemplate (B.pack n) ts - ------------------------------------------------------------------------------- -renderNoNameTest :: H.Assertion -renderNoNameTest = do - ets <- loadT "templates" - either (error "Error loading templates") - (\ts -> do t <- renderTemplate ts "" - H.assertBool "renderNoName" $ isNothing t - ) ets - - ------------------------------------------------------------------------------- -doctypeTest :: H.Assertion -doctypeTest = do - ets <- loadT "templates" - let ts = either (error "Error loading templates") id ets - Just (indexDoc, indexMIME) <- renderTemplate ts "index" - H.assertBool "doctype test index" $ isJust $ X.docType $ - fromRight $ (X.parseHTML "index") $ toByteString $ indexDoc - Just (iocDoc, iocMIME) <- renderTemplate ts "ioc" - H.assertBool "doctype test ioc" $ isJust $ X.docType $ - fromRight $ (X.parseHTML "index") $ toByteString $ iocDoc - where fromRight (Right x) = x - fromRight (Left s) = error s - ------------------------------------------------------------------------------- -attrSubstTest :: H.Assertion -attrSubstTest = do - ets <- loadT "templates" - let ts = either (error "Error loading templates") id ets - check (setTs "meaning_of_everything" ts) "pre_meaning_of_everything_post" - check ts "pre__post" - - where - setTs val = bindSplice "foo" (return [X.TextNode val]) - check ts str = do - Just (resDoc, resMIME) <- renderTemplate ts "attrs" - H.assertBool ("attr subst " ++ (show str)) $ not $ B.null $ - snd $ B.breakSubstring str $ toByteString $ resDoc - H.assertBool ("attr subst foo") $ not $ B.null $ - snd $ B.breakSubstring "${foo}" $ toByteString $ resDoc - - ------------------------------------------------------------------------------- -bindAttrTest :: H.Assertion -bindAttrTest = do - ets <- loadT "templates" - let ts = either (error "Error loading templates") id ets - check ts "
    <b>ok</b>1" - , "falsefoo" ] - jsonExpected2 = "ok1falsefoo" - - ------------------------------------------------------------------------------- -jsonObjectTest :: H.Assertion -jsonObjectTest = do - renderTest "json_object" jsonExpected - where - jsonExpected = B.concat [ "1ok12quuxquux1ok" ] - - ------------------------------------------------------------------------------- --- | Render a template and assert that it matches an expected result -renderTest :: ByteString -- ^ template name - -> ByteString -- ^ expected result - -> H.Assertion -renderTest templateName expectedResult = do - ets <- loadT "templates" - let ts = either (error "Error loading templates") id ets - - check ts expectedResult - - where - bind txt = bindJson v - where - v :: Value - v = fromJust $ decode txt - - check ts0 str = do - let ts = bindSplices [ - ("json", bind "[\"ok\", 1, null, false, \"foo\"]") - , ("jsonObject", - bind $ mconcat [ - "{\"foo\": 1, \"bar\": \"ok\", " - , "\"baz\": { \"baz1\": 1, \"baz2\": 2 }, " - , "\"quux\": \"quux\" }" - ]) - ] ts0 - Just (doc, _) <- renderTemplate ts templateName - let result = B.filter (/= '\n') (toByteString doc) - H.assertEqual ("Should match " ++ (show str)) str result - - ------------------------------------------------------------------------------- --- | Expansion of a bound name inside a title-tag -titleExpansion :: H.Assertion -titleExpansion = renderTest "title_expansion" "foo" - - ------------------------------------------------------------------------------- --- | Expansion of a bound name inside a textarea-tag -textareaExpansion :: H.Assertion -textareaExpansion = renderTest "textarea_expansion" "" - - ------------------------------------------------------------------------------- --- | Expansion of a bound name inside a div-tag -divExpansion :: H.Assertion -divExpansion = renderTest "div_expansion" "
    foo
    " - - ------------------------------------------------------------------------------- --- | Handling of and bound parameters in a bound tag. -bindParam :: H.Assertion -bindParam = renderTest "bind_param" "
  • Hi there world
    • " - - ------------------------------------------------------------------------------- --- | Handling of and bound parameters in a bound tag. -attrSpliceContext :: H.Assertion -attrSpliceContext = renderTest "attrsubtest2" "linkfoo" - - ------------------------------------------------------------------------------- --- | Markdown test on supplied text -markdownTextTest :: H.Assertion -markdownTextTest = do - result <- evalHeistT markdownSplice - (X.TextNode "This *is* a test.") - defaultHeistState - H.assertEqual "Markdown text" htmlExpected - (B.filter (/= '\n') $ toByteString $ - X.render (X.HtmlDocument X.UTF8 Nothing result)) - - ------------------------------------------------------------------------------- -applyTest :: H.Assertion -applyTest = do - let es = defaultHeistState :: HeistState IO - res <- evalHeistT applyImpl - (X.Element "apply" [("template", "nonexistant")] []) es - - H.assertEqual "apply nothing" [] res - - ------------------------------------------------------------------------------- -ignoreTest :: H.Assertion -ignoreTest = do - let es = defaultHeistState :: HeistState IO - res <- evalHeistT ignoreImpl - (X.Element "ignore" [("tag", "ignorable")] - [X.TextNode "This should be ignored"]) es - H.assertEqual " tag" [] res - - ---localTSTest :: H.Assertion ---localTSTest = do --- let es = defaultHeistState :: HeistState IO - -lookupTemplateTest = do - ts <- loadTS "templates" - let k = do - setContext ["foo"] - getsTS $ lookupTemplate "/user/menu" - res <- runHeistT k (X.TextNode "") ts - H.assertBool "lookup context test" $ isJust $ fst res - - ------------------------------------------------------------------------------- --- Utility functions - -isLeft :: Either a b -> Bool -isLeft (Left _) = True -isLeft (Right _) = False - - ------------------------------------------------------------------------------- -loadT :: String -> IO (Either String (HeistState IO)) -loadT s = loadTemplates s defaultHeistState - - ------------------------------------------------------------------------------- -loadTS :: FilePath -> IO (HeistState IO) -loadTS baseDir = do - etm <- loadTemplates baseDir defaultHeistState - return $ either error id etm - - -testTemplate tname = do - ts <- loadTS "templates" - Just (resDoc, _) <- renderTemplate ts tname - return $ toByteString resDoc - - -testTemplateEval tname = do - ts <- loadTS "templates" - evalHeistT (evalWithHooks tname) (X.TextNode "") ts - - ------------------------------------------------------------------------------- -identStartChar :: [Char] -identStartChar = ['a'..'z'] - - ------------------------------------------------------------------------------- -identChar :: [Char] -identChar = '_' : identStartChar - - ------------------------------------------------------------------------------- -textGen :: Gen [Char] -textGen = listOf $ elements ((replicate 5 ' ') ++ identStartChar) - - ------------------------------------------------------------------------------- -limitedDepth :: Int -> Gen X.Node -limitedDepth 0 = liftM (X.TextNode . T.pack) textGen -limitedDepth n = - oneof [ liftM (X.TextNode . T.pack) textGen - , liftM3 X.Element arbitrary - (liftM (take 2) arbitrary) - (liftM (take 3) $ listOf $ limitedDepth (n - 1)) - ] - - ------------------------------------------------------------------------------- --- | Returns the number of unique insertion points in the tree. --- If h = insertAt f n g", the following property holds: --- insSize h == (insSize f) + (insSize g) - 1 -insSize :: [X.Node] -> Int -insSize ns = 1 + (sum $ map nodeSize ns) - where nodeSize (X.TextNode _) = 1 - nodeSize (X.Element _ _ c) = 1 + (insSize c) - - ------------------------------------------------------------------------------- -insertAt :: [X.Node] -> Int -> [X.Node] -> [X.Node] -insertAt elems 0 ns = elems ++ ns -insertAt elems _ [] = elems -insertAt elems n list = maybe [] X.topNodes $ - evalState (processNode elems $ fromJust $ X.fromNodes list) n - - ------------------------------------------------------------------------------- -move :: Insert () -move = modify (\x -> x - 1) - - ------------------------------------------------------------------------------- -processNode :: [X.Node] -> X.Cursor -> Insert (Maybe X.Cursor) -processNode elems loc = - liftM2 mplus (move >> goDown loc) (move >> goRight loc) - - where - goDown l = - case X.current l of - X.TextNode _ -> modify (+1) >> return Nothing - X.Element _ _ _ -> doneCheck (X.insertManyFirstChild elems) - X.firstChild - l - - goRight = doneCheck (Just . X.insertManyRight elems) X.right - - doneCheck insertFunc next l = do - s <- get - if s == 0 - then return $ insertFunc l - else maybe (return Nothing) (processNode elems) $ next l - - ------------------------------------------------------------------------------- --- | Reloads the templates from disk and renders the specified --- template. (Old convenience code.) -quickRender :: FilePath -> ByteString -> IO (Maybe ByteString) -quickRender baseDir name = do - ts <- loadTS baseDir - res <- renderTemplate ts name - return (fmap (toByteString . fst) res) - - ------------------------------------------------------------------------------- -newtype Name = Name { unName :: Text } deriving (Show) - -instance Arbitrary Name where - arbitrary = do - x <- elements identStartChar - n <- choose (4,10) - rest <- vectorOf n $ elements identChar - return $ Name $ T.pack (x:rest) - -instance Arbitrary X.Node where - arbitrary = limitedDepth 3 - shrink (X.TextNode _) = [] - shrink (X.Element _ [] []) = [] - shrink (X.Element n [] (_:cs)) = [X.Element n [] cs] - shrink (X.Element n (_:as) []) = [X.Element n as []] - shrink (X.Element n as cs) = [X.Element n as (tail cs), X.Element n (tail as) cs] - -instance Arbitrary T.Text where - arbitrary = liftM unName arbitrary - --- --- Code for inserting nodes into any point of a tree --- -type Insert a = State Int a - - ------------------------------------------------------------------------------- --- tests - --- Data type encapsulating the parameters for a bind operation -data Bind = Bind - { _bindElemName :: Name - , _bindChildren :: [X.Node] - , _bindDoc :: [X.Node] - , _bindPos :: Int - , _bindRefPos :: Int - } -- deriving (Show) - - -instance Arbitrary Bind where - arbitrary = do - name <- arbitrary - kids <- liftM (take 3) arbitrary - doc <- liftM (take 5) arbitrary - let s = insSize doc - loc <- choose (0, s - 1) - loc2 <- choose (0, s - loc - 1) - return $ Bind name kids doc loc loc2 - shrink (Bind e [c] (_:ds) p r) = [Bind e [c] ds p r] - shrink (Bind e (_:cs) d p r) = [Bind e cs d p r] - shrink _ = [] - - -instance Show Bind where - show b@(Bind e c d p r) = unlines - [ "\n" - , "Bind element name: " ++ (show e) - , "Bind pos: " ++ (show p) - , "Bind ref pos: " ++ (show r) - , "Bind document:" - , L.unpack $ L.concat $ map formatNode d - , "Bind children:" - , L.unpack $ L.concat $ map formatNode c - , "Result:" - , L.unpack $ L.concat $ map formatNode $ buildResult b - , "Splice result:" - , L.unpack $ L.concat $ map formatNode $ unsafePerformIO $ - evalHeistT (runNodeList $ buildBindTemplate b) - (X.TextNode "") defaultHeistState - , "Template:" - , L.unpack $ L.concat $ map formatNode $ buildBindTemplate b - ] - where - formatNode n = toLazyByteString $ X.render - $ X.HtmlDocument X.UTF8 Nothing [n] - ------------------------------------------------------------------------------- -buildNode :: Text -> Text -> Bind -> X.Node -buildNode tag attr (Bind s c _ _ _) = X.Element tag [(attr, unName s)] c - - ------------------------------------------------------------------------------- -buildBind :: Bind -> X.Node -buildBind = buildNode "bind" "tag" - - ------------------------------------------------------------------------------- -empty :: Text -> X.Node -empty n = X.Element n [] [] - - ------------------------------------------------------------------------------- -buildBindTemplate :: Bind -> [X.Node] -buildBindTemplate s@(Bind n _ d b r) = - insertAt [empty $ unName $ n] pos $ withBind - where bind = [buildBind s] - bindSize = insSize bind - withBind = insertAt bind b d - pos = b + bindSize - 1 + r - - ------------------------------------------------------------------------------- -buildResult :: Bind -> [X.Node] -buildResult (Bind _ c d b r) = insertAt c (b + r) d - - ------------------------------------------------------------------------------- --- tests - -data Apply = Apply - { _applyName :: Name - , _applyCaller :: [X.Node] - , _applyCallee :: Template - , _applyChildren :: [X.Node] - , _applyPos :: Int - } deriving (Show) - - -instance Arbitrary Apply where - arbitrary = do - name <- arbitrary - kids <- liftM (take 3) $ listOf $ limitedDepth 2 - caller <- liftM (take 5) arbitrary - callee <- liftM (take 1) $ listOf $ limitedDepth 3 - let s = insSize caller - loc <- choose (0, s - 1) - return $ Apply name caller callee kids loc - - ------------------------------------------------------------------------------- -buildApplyCaller :: Apply -> [X.Node] -buildApplyCaller (Apply name caller _ kids pos) = - insertAt [X.Element "apply" [("template", unName name)] kids] pos caller - - ------------------------------------------------------------------------------- -calcCorrect :: Apply -> [X.Node] -calcCorrect (Apply _ caller callee _ pos) = insertAt callee pos caller - - ------------------------------------------------------------------------------- -calcResult :: (MonadIO m) => Apply -> m [X.Node] -calcResult apply@(Apply name _ callee _ _) = - evalHeistT (runNodeList $ buildApplyCaller apply) - (X.TextNode "") ts - - where ts = setTemplates (Map.singleton [T.encodeUtf8 $ unName name] - (DocumentFile (X.HtmlDocument X.UTF8 Nothing callee) - Nothing)) - defaultHeistState - - - -{- --- The beginning of some future tests for hook functions. - -p :: ByteString -> Node -p t = X.Element "p" [] [X.Text t] - -hookG :: Monad m => ByteString -> Template -> m Template -hookG str t = return $ (p str) : t - -onLoad = hookG "Inserted on load" -preRun = hookG "Inserted on preRun" -postRun = hookG "Inserted on postRun" - -ts :: IO (Either String (HeistState IO)) -ts = loadTemplates "test/templates" $ - foldr ($) (defaultHeistState ".") - [setOnLoadHook onLoad - ,setPreRunHook preRun - ,setPostRunHook postRun - ] - -r name etm = do - let ts = either (error "Danger Will Robinson!") id etm - ns <- runNodeList ts name - return $ (Just . formatList') =<< ns --} - - -{- - - Convenience code for manual ghci experimentation - -} - ---html :: [Node] -> Node ---html c = X.Element "html" [] [hhead, body c] ---hhead :: Node ---hhead = X.Element "head" [] [title, X.Element "script" [] []] ---title :: Node ---title = X.Element "title" [] [X.Text "Test Page"] ---body :: [Node] -> Node ---body = X.Element "body" [] --- ---para :: Int -> Node ---para n = X.Element "p" [] [X.Text $ B.pack $ "This is paragraph " ++ show n] ---para2 :: B.ByteString -> Node ---para2 c = X.Element "p" [] [X.Text c] ---para3 :: Node ---para3 = X.Element "p" [] [X.Text "AHA!"] --- ---foo :: Int -> [Node] ---foo n = insertAt [X.Element "NEW" [] []] n [html [para 1, para 2]] --- ---tdoc :: [Node] ---tdoc = [para 1, para 2, para 3, para 4] --- ---bindElem :: [Node] -> Int -> Int -> Bind ---bindElem = Bind (Name "mytag") [para2 "bound paragraph"] --- ---addBind :: Bind -> [Node] -> [Node] ---addBind b = insertAt [buildBind b] 0 . insertAt [empty $ unName $ _bindElemName b] 2 --- ---prn :: Node -> IO () ---prn = L.putStrLn . formatNode ---runTests :: IO () ---runTests = defaultMain tests - diff --git a/test/templates-bad/apply-missing-attr.tpl b/test/templates-bad/apply-missing-attr.tpl new file mode 100644 --- /dev/null +++ b/test/templates-bad/apply-missing-attr.tpl @@ -0,0 +1,3 @@ + +noroot + diff --git a/test/templates-bad/apply-template-not-found.tpl b/test/templates-bad/apply-template-not-found.tpl new file mode 100644 --- /dev/null +++ b/test/templates-bad/apply-template-not-found.tpl @@ -0,0 +1,3 @@ + +This template is missing + diff --git a/test/templates-bad/bind-infinite-loop.tpl b/test/templates-bad/bind-infinite-loop.tpl new file mode 100644 --- /dev/null +++ b/test/templates-bad/bind-infinite-loop.tpl @@ -0,0 +1,2 @@ +

    line

     + diff --git a/test/templates-bad/bind-missing-attr.tpl b/test/templates-bad/bind-missing-attr.tpl new file mode 100644 --- /dev/null +++ b/test/templates-bad/bind-missing-attr.tpl @@ -0,0 +1,2 @@ +

    line

     + diff --git a/test/templates/attr_splice.tpl b/test/templates/attr_splice.tpl new file mode 100644 --- /dev/null +++ b/test/templates/attr_splice.tpl @@ -0,0 +1,2 @@ + + diff --git a/test/templates/attrsubtest1.tpl b/test/templates/attrsubtest1.tpl new file mode 100644 --- /dev/null +++ b/test/templates/attrsubtest1.tpl @@ -0,0 +1,1 @@ + diff --git a/test/templates/attrsubtest2.tpl b/test/templates/attrsubtest2.tpl new file mode 100644 --- /dev/null +++ b/test/templates/attrsubtest2.tpl @@ -0,0 +1,1 @@ +asdflinkfoo diff --git a/test/templates/bind-apply-interaction/_outer.tpl b/test/templates/bind-apply-interaction/_outer.tpl new file mode 100644 --- /dev/null +++ b/test/templates/bind-apply-interaction/_outer.tpl @@ -0,0 +1,6 @@ +====== +This is a test. +bind content +Another test line. + +Last test line. diff --git a/test/templates/bind-apply-interaction/caller.tpl b/test/templates/bind-apply-interaction/caller.tpl new file mode 100644 --- /dev/null +++ b/test/templates/bind-apply-interaction/caller.tpl @@ -0,0 +1,1 @@ +apply content diff --git a/test/templates/bind_param.tpl b/test/templates/bind_param.tpl new file mode 100644 --- /dev/null +++ b/test/templates/bind_param.tpl @@ -0,0 +1,1 @@ +
    • worldHi therehello diff --git a/test/templates/cache.tpl b/test/templates/cache.tpl new file mode 100644 --- /dev/null +++ b/test/templates/cache.tpl @@ -0,0 +1,3 @@ + + + diff --git a/test/templates/div_expansion.tpl b/test/templates/div_expansion.tpl new file mode 100644 --- /dev/null +++ b/test/templates/div_expansion.tpl @@ -0,0 +1,1 @@ +foo
    diff --git a/test/templates/etc.tpl b/test/templates/etc.tpl deleted file mode 100644 --- a/test/templates/etc.tpl +++ /dev/null @@ -1,3 +0,0 @@ -/etc -

    line

     - diff --git a/test/templates/foo/markdown-chdir.tpl b/test/templates/foo/markdown-chdir.tpl new file mode 100644 --- /dev/null +++ b/test/templates/foo/markdown-chdir.tpl @@ -0,0 +1,5 @@ +Different directory markdown + +This file doesn't have any actual test code referring to it because compiled +Heist will automatically fail the whole test suite if the case tested by this +template isn't tested correctly. diff --git a/test/templates/foo/markdown-origdir.tpl b/test/templates/foo/markdown-origdir.tpl new file mode 100644 --- /dev/null +++ b/test/templates/foo/markdown-origdir.tpl @@ -0,0 +1,3 @@ + + + diff --git a/test/templates/foo/test2.md b/test/templates/foo/test2.md new file mode 100644 --- /dev/null +++ b/test/templates/foo/test2.md @@ -0,0 +1,1 @@ +This *is* another test. diff --git a/test/templates/head_merge/index.tpl b/test/templates/head_merge/index.tpl new file mode 100644 --- /dev/null +++ b/test/templates/head_merge/index.tpl @@ -0,0 +1,6 @@ + + + + +
    index page
    +     diff --git a/test/templates/head_merge/nav.tpl b/test/templates/head_merge/nav.tpl new file mode 100644 --- /dev/null +++ b/test/templates/head_merge/nav.tpl @@ -0,0 +1,4 @@ + + + +
    nav bar
    diff --git a/test/templates/head_merge/wrap.tpl b/test/templates/head_merge/wrap.tpl new file mode 100644 --- /dev/null +++ b/test/templates/head_merge/wrap.tpl @@ -0,0 +1,9 @@ + + + + + + + + + diff --git a/test/templates/ioc.tpl b/test/templates/ioc.tpl --- a/test/templates/ioc.tpl +++ b/test/templates/ioc.tpl @@ -1,6 +1,3 @@ - -Apply with no parameter. - Inversion of control content diff --git a/test/templates/noroot.tpl b/test/templates/noroot.tpl deleted file mode 100644 --- a/test/templates/noroot.tpl +++ /dev/null @@ -1,3 +0,0 @@ - -noroot - diff --git a/test/templates/page.tpl b/test/templates/page.tpl --- a/test/templates/page.tpl +++ b/test/templates/page.tpl @@ -1,5 +1,5 @@ - + diff --git a/test/templates/people.tpl b/test/templates/people.tpl new file mode 100644 --- /dev/null +++ b/test/templates/people.tpl @@ -0,0 +1,3 @@ + +

    , : years old

    +     diff --git a/test/templates/post.tpl b/test/templates/post.tpl new file mode 100644 --- /dev/null +++ b/test/templates/post.tpl @@ -0,0 +1,4 @@ + +

    +

    +     diff --git a/test/templates/textarea_expansion.tpl b/test/templates/textarea_expansion.tpl new file mode 100644 --- /dev/null +++ b/test/templates/textarea_expansion.tpl @@ -0,0 +1,1 @@ +foo diff --git a/test/templates/title_expansion.tpl b/test/templates/title_expansion.tpl new file mode 100644 --- /dev/null +++ b/test/templates/title_expansion.tpl @@ -0,0 +1,1 @@ +foo<mytext/> diff --git a/test/templates/user/admin/main.tpl b/test/templates/user/admin/main.tpl --- a/test/templates/user/admin/main.tpl +++ b/test/templates/user/admin/main.tpl @@ -1,6 +1,4 @@ Admin Page - -