1 {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 {-# LANGUAGE PackageImports #-} 3 {-# LANGUAGE ScopedTypeVariables #-} 4 5 module Text.Templating.Heist.Internal where 6 7 ------------------------------------------------------------------------------ 8 import Blaze.ByteString.Builder 9 import Control.Applicative 10 import Control.Arrow 11 import Control.Exception (SomeException) 12 import Control.Monad 13 import Control.Monad.CatchIO 14 import Control.Monad.Trans 15 import qualified Data.Attoparsec.Text as AP 16 import Data.ByteString (ByteString) 17 import qualified Data.ByteString as B 18 import qualified Data.ByteString.Char8 as BC 19 import Data.Either 20 import qualified Data.Foldable as F 21 import Data.List 22 import qualified Data.Map as Map 23 import Data.Maybe 24 import Data.Monoid 25 import qualified Data.Text as T 26 import Data.Text (Text) 27 import Prelude hiding (catch) 28 import System.Directory.Tree hiding (name) 29 import System.FilePath 30 import qualified Text.XmlHtml as X 31 32 ------------------------------------------------------------------------------ 33 import Text.Templating.Heist.Types 34 35 36 ------------------------------------------------------------------------------ 37 -- | Mappends a doctype to the state. 38 addDoctype :: Monad m => [X.DocType] -> HeistT m () 39 addDoctype dt = do 40 modifyTS (\s -> s { _doctypes = _doctypes s `mappend` dt }) 41 42 43 ------------------------------------------------------------------------------ 44 -- TemplateState functions 45 ------------------------------------------------------------------------------ 46 47 48 ------------------------------------------------------------------------------ 49 -- | Adds an on-load hook to a `TemplateState`. 50 addOnLoadHook :: (Monad m) => 51 (Template -> IO Template) 52 -> TemplateState m 53 -> TemplateState m 54 addOnLoadHook hook ts = ts { _onLoadHook = _onLoadHook ts >=> hook } 55 56 57 ------------------------------------------------------------------------------ 58 -- | Adds a pre-run hook to a `TemplateState`. 59 addPreRunHook :: (Monad m) => 60 (Template -> m Template) 61 -> TemplateState m 62 -> TemplateState m 63 addPreRunHook hook ts = ts { _preRunHook = _preRunHook ts >=> hook } 64 65 66 ------------------------------------------------------------------------------ 67 -- | Adds a post-run hook to a `TemplateState`. 68 addPostRunHook :: (Monad m) => 69 (Template -> m Template) 70 -> TemplateState m 71 -> TemplateState m 72 addPostRunHook hook ts = ts { _postRunHook = _postRunHook ts >=> hook } 73 74 75 ------------------------------------------------------------------------------ 76 -- | Binds a new splice declaration to a tag name within a 'TemplateState'. 77 bindSplice :: Monad m => 78 Text -- ^ tag name 79 -> Splice m -- ^ splice action 80 -> TemplateState m -- ^ source state 81 -> TemplateState m 82 bindSplice n v ts = ts {_spliceMap = Map.insert n v (_spliceMap ts)} 83 84 85 ------------------------------------------------------------------------------ 86 -- | Binds a set of new splice declarations within a 'TemplateState'. 87 bindSplices :: Monad m => 88 [(Text, Splice m)] -- ^ splices to bind 89 -> TemplateState m -- ^ start state 90 -> TemplateState m 91 bindSplices ss ts = foldl' (flip id) ts acts 92 where 93 acts = map (uncurry bindSplice) ss 94 95 96 ------------------------------------------------------------------------------ 97 -- | Sets the current template file. 98 setCurTemplateFile :: Monad m 99 => Maybe FilePath -> TemplateState m -> TemplateState m 100 setCurTemplateFile fp ts = ts { _curTemplateFile = fp } 101 102 103 ------------------------------------------------------------------------------ 104 -- | Converts 'Text' to a splice returning a single 'TextNode'. 105 textSplice :: (Monad m) => Text -> Splice m 106 textSplice t = return [X.TextNode t] 107 108 109 ------------------------------------------------------------------------------ 110 -- | Runs the parameter node's children and returns the resulting node list. 111 -- By itself this function is a simple passthrough splice that makes the 112 -- spliced node disappear. In combination with locally bound splices, this 113 -- function makes it easier to pass the desired view into your splices. 114 runChildren :: Monad m => Splice m 115 runChildren = runNodeList . X.childNodes =<< getParamNode 116 117 118 ------------------------------------------------------------------------------ 119 -- | Binds a list of splices before using the children of the spliced node as 120 -- a view. 121 runChildrenWith :: (Monad m) 122 => [(Text, Splice m)] 123 -- ^ List of splices to bind before running the param nodes. 124 -> Splice m 125 -- ^ Returns the passed in view. 126 runChildrenWith splices = localTS (bindSplices splices) runChildren 127 128 129 ------------------------------------------------------------------------------ 130 -- | Wrapper around runChildrenWith that applies a transformation function to the 131 -- second item in each of the tuples before calling runChildrenWith. 132 runChildrenWithTrans :: (Monad m) 133 => (b -> Splice m) 134 -- ^ Splice generating function 135 -> [(Text, b)] 136 -- ^ List of tuples to be bound 137 -> Splice m 138 runChildrenWithTrans f = runChildrenWith . map (second f) 139 140 141 ------------------------------------------------------------------------------ 142 -- | Like runChildrenWith but using constant templates rather than dynamic 143 -- splices. 144 runChildrenWithTemplates :: (Monad m) => [(Text, Template)] -> Splice m 145 runChildrenWithTemplates = runChildrenWithTrans return 146 147 148 ------------------------------------------------------------------------------ 149 -- | Like runChildrenWith but using literal text rather than dynamic splices. 150 runChildrenWithText :: (Monad m) => [(Text, Text)] -> Splice m 151 runChildrenWithText = runChildrenWithTrans textSplice 152 153 154 ------------------------------------------------------------------------------ 155 -- | Maps a splice generating function over a list and concatenates the 156 -- results. 157 mapSplices :: (Monad m) 158 => (a -> Splice m) 159 -- ^ Splice generating function 160 -> [a] 161 -- ^ List of items to generate splices for 162 -> Splice m 163 -- ^ The result of all splices concatenated together. 164 mapSplices f vs = liftM concat $ mapM f vs 165 166 167 ------------------------------------------------------------------------------ 168 -- | Convenience function for looking up a splice. 169 lookupSplice :: Monad m => 170 Text 171 -> TemplateState m 172 -> Maybe (Splice m) 173 lookupSplice nm ts = Map.lookup nm $ _spliceMap ts 174 175 176 ------------------------------------------------------------------------------ 177 -- | Converts a path into an array of the elements in reverse order. If the 178 -- path is absolute, we need to remove the leading slash so the split doesn't 179 -- leave @\"\"@ as the last element of the TPath. 180 -- 181 -- FIXME @\"..\"@ currently doesn't work in paths, the solution is non-trivial 182 splitPathWith :: Char -> ByteString -> TPath 183 splitPathWith s p = if BC.null p then [] else (reverse $ BC.split s path) 184 where 185 path = if BC.head p == s then BC.tail p else p 186 187 -- | Converts a path into an array of the elements in reverse order using the 188 -- path separator of the local operating system. See 'splitPathWith' for more 189 -- details. 190 splitLocalPath :: ByteString -> TPath 191 splitLocalPath = splitPathWith pathSeparator 192 193 -- | Converts a path into an array of the elements in reverse order using a 194 -- forward slash (/) as the path separator. See 'splitPathWith' for more 195 -- details. 196 splitTemplatePath :: ByteString -> TPath 197 splitTemplatePath = splitPathWith '/' 198 199 200 ------------------------------------------------------------------------------ 201 -- | Does a single template lookup without cascading up. 202 singleLookup :: TemplateMap 203 -> TPath 204 -> ByteString 205 -> Maybe (DocumentFile, TPath) 206 singleLookup tm path name = fmap (\a -> (a,path)) $ Map.lookup (name:path) tm 207 208 209 ------------------------------------------------------------------------------ 210 -- | Searches for a template by looking in the full path then backing up into 211 -- each of the parent directories until the template is found. 212 traversePath :: TemplateMap 213 -> TPath 214 -> ByteString 215 -> Maybe (DocumentFile, TPath) 216 traversePath tm [] name = fmap (\a -> (a,[])) (Map.lookup [name] tm) 217 traversePath tm path name = 218 singleLookup tm path name `mplus` 219 traversePath tm (tail path) name 220 221 222 ------------------------------------------------------------------------------ 223 -- | Returns 'True' if the given template can be found in the template state. 224 hasTemplate :: Monad m => 225 ByteString 226 -> TemplateState m 227 -> Bool 228 hasTemplate nameStr ts = isJust $ lookupTemplate nameStr ts 229 230 231 ------------------------------------------------------------------------------ 232 -- | Convenience function for looking up a template. 233 lookupTemplate :: Monad m => 234 ByteString 235 -> TemplateState m 236 -> Maybe (DocumentFile, TPath) 237 lookupTemplate nameStr ts = 238 f (_templateMap ts) path name 239 where (name:p) = case splitTemplatePath nameStr of 240 [] -> [""] 241 ps -> ps 242 ctx = if B.isPrefixOf "/" nameStr then [] else _curContext ts 243 path = p ++ ctx 244 f = if '/' `BC.elem` nameStr 245 then singleLookup 246 else traversePath 247 248 249 ------------------------------------------------------------------------------ 250 -- | Sets the templateMap in a TemplateState. 251 setTemplates :: Monad m => TemplateMap -> TemplateState m -> TemplateState m 252 setTemplates m ts = ts { _templateMap = m } 253 254 255 ------------------------------------------------------------------------------ 256 -- | Adds a template to the template state. 257 insertTemplate :: Monad m => 258 TPath 259 -> DocumentFile 260 -> TemplateState m 261 -> TemplateState m 262 insertTemplate p t st = 263 setTemplates (Map.insert p t (_templateMap st)) st 264 265 266 ------------------------------------------------------------------------------ 267 -- | Adds an HTML format template to the template state. 268 addTemplate :: Monad m 269 => ByteString 270 -- ^ Path that the template will be referenced by 271 -> Template 272 -- ^ The template's DOM nodes 273 -> Maybe FilePath 274 -- ^ An optional path to the actual file on disk where the 275 -- template is stored 276 -> TemplateState m 277 -> TemplateState m 278 addTemplate n t mfp st = 279 insertTemplate (splitTemplatePath n) doc st 280 where 281 doc = DocumentFile (X.HtmlDocument X.UTF8 Nothing t) mfp 282 283 284 ------------------------------------------------------------------------------ 285 -- | Adds an XML format template to the template state. 286 addXMLTemplate :: Monad m 287 => ByteString 288 -- ^ Path that the template will be referenced by 289 -> Template 290 -- ^ The template's DOM nodes 291 -> Maybe FilePath 292 -- ^ An optional path to the actual file on disk where the 293 -- template is stored 294 -> TemplateState m 295 -> TemplateState m 296 addXMLTemplate n t mfp st = 297 insertTemplate (splitTemplatePath n) doc st 298 where 299 doc = DocumentFile (X.XmlDocument X.UTF8 Nothing t) mfp 300 301 302 ------------------------------------------------------------------------------ 303 -- | Stops the recursive processing of splices. Consider the following 304 -- example: 305 -- 306 -- > <foo> 307 -- > <bar> 308 -- > ... 309 -- > </bar> 310 -- > </foo> 311 -- 312 -- Assume that @\"foo\"@ is bound to a splice procedure. Running the @foo@ 313 -- splice will result in a list of nodes @L@. Normally @foo@ will recursively 314 -- scan @L@ for splices and run them. If @foo@ calls @stopRecursion@, @L@ 315 -- will be included in the output verbatim without running any splices. 316 stopRecursion :: Monad m => HeistT m () 317 stopRecursion = modifyTS (\st -> st { _recurse = False }) 318 319 320 ------------------------------------------------------------------------------ 321 -- | Sets the current context 322 setContext :: Monad m => TPath -> HeistT m () 323 setContext c = modifyTS (\st -> st { _curContext = c }) 324 325 326 ------------------------------------------------------------------------------ 327 -- | Gets the current context 328 getContext :: Monad m => HeistT m TPath 329 getContext = getsTS _curContext 330 331 332 ------------------------------------------------------------------------------ 333 -- | Gets the full path to the file holding the template currently being 334 -- processed. Returns Nothing if the template is not associated with a file 335 -- on disk or if there is no template being processed. 336 getTemplateFilePath :: Monad m => HeistT m (Maybe FilePath) 337 getTemplateFilePath = getsTS _curTemplateFile 338 339 340 ------------------------------------------------------------------------------ 341 -- | Performs splice processing on a single node. 342 runNode :: Monad m => X.Node -> Splice m 343 runNode (X.Element nm at ch) = do 344 newAtts <- mapM attSubst at 345 let n = X.Element nm newAtts ch 346 s <- liftM (lookupSplice nm) getTS 347 maybe (runKids newAtts) (recurseSplice n) s 348 where 349 runKids newAtts = do 350 newKids <- runNodeList ch 351 return [X.Element nm newAtts newKids] 352 runNode n = return [n] 353 354 355 ------------------------------------------------------------------------------ 356 -- | Helper function for substituting a parsed attribute into an attribute 357 -- tuple. 358 attSubst :: (Monad m) => (t, Text) -> HeistT m (t, Text) 359 attSubst (n,v) = do 360 v' <- parseAtt v 361 return (n,v') 362 363 364 ------------------------------------------------------------------------------ 365 -- | Parses an attribute for any identifier expressions and performs 366 -- appropriate substitution. 367 parseAtt :: (Monad m) => Text -> HeistT m Text 368 parseAtt bs = do 369 let ast = case AP.feed (AP.parse attParser bs) "" of 370 (AP.Fail _ _ _) -> [] 371 (AP.Done _ res) -> res 372 (AP.Partial _) -> [] 373 chunks <- mapM cvt ast 374 return $ T.concat chunks 375 where 376 cvt (Literal x) = return x 377 cvt (Ident x) = getAttributeSplice x 378 379 380 ------------------------------------------------------------------------------ 381 -- | AST to hold attribute parsing structure. This is necessary because 382 -- attoparsec doesn't support parsers running in another monad. 383 data AttAST = Literal Text | 384 Ident Text 385 deriving (Show) 386 387 388 ------------------------------------------------------------------------------ 389 -- | Parser for attribute variable substitution. 390 attParser :: AP.Parser [AttAST] 391 attParser = AP.many1 (identParser <|> litParser) 392 where 393 escChar = (AP.char '\\' *> AP.anyChar) <|> 394 AP.satisfy (AP.notInClass "\\$") 395 litParser = Literal <$> (T.pack <$> AP.many1 escChar) 396 identParser = AP.string "$(" *> 397 (Ident <$> AP.takeWhile (/=')')) <* AP.string ")" 398 399 400 ------------------------------------------------------------------------------ 401 -- | Gets the attribute value. If the splice's result list contains non-text 402 -- nodes, this will translate them into text nodes with nodeText and 403 -- concatenate them together. 404 -- 405 -- Originally, this only took the first node from the splices's result list, 406 -- and only if it was a text node. This caused problems when the splice's 407 -- result contained HTML entities, as they would split a text node. This was 408 -- then fixed to take the first consecutive bunch of text nodes, and return 409 -- their concatenation. This was seen as more useful than throwing an error, 410 -- and more intuitive than trying to render all the nodes as text. 411 -- 412 -- However, it was decided in the end to render all the nodes as text, and 413 -- then concatenate them. If a splice returned 414 -- \"some \<b\>text\<\/b\> foobar\", the user would almost certainly want 415 -- \"some text foobar\" to be rendered, and Heist would probably seem 416 -- annoyingly limited for not being able to do this. If the user really did 417 -- want it to render \"some \", it would probably be easier for them to 418 -- accept that they were silly to pass more than that to be substituted than 419 -- it would be for the former user to accept that 420 -- \"some \<b\>text\<\/b\> foobar\" is being rendered as \"some \" because 421 -- it's \"more intuitive\". 422 getAttributeSplice :: Monad m => Text -> HeistT m Text 423 getAttributeSplice name = do 424 s <- liftM (lookupSplice name) getTS 425 nodes <- maybe (return []) id s 426 return $ T.concat $ map X.nodeText nodes 427 428 ------------------------------------------------------------------------------ 429 -- | Performs splice processing on a list of nodes. 430 runNodeList :: Monad m => [X.Node] -> Splice m 431 runNodeList = mapSplices runNode 432 433 434 ------------------------------------------------------------------------------ 435 -- | The maximum recursion depth. (Used to prevent infinite loops.) 436 mAX_RECURSION_DEPTH :: Int 437 mAX_RECURSION_DEPTH = 50 438 439 440 ------------------------------------------------------------------------------ 441 -- | Checks the recursion flag and recurses accordingly. Does not recurse 442 -- deeper than mAX_RECURSION_DEPTH to avoid infinite loops. 443 recurseSplice :: Monad m => X.Node -> Splice m -> Splice m 444 recurseSplice node splice = do 445 result <- localParamNode (const node) splice 446 ts' <- getTS 447 if _recurse ts' && _recursionDepth ts' < mAX_RECURSION_DEPTH 448 then do modRecursionDepth (+1) 449 res <- runNodeList result 450 restoreTS ts' 451 return res 452 else return result 453 where 454 modRecursionDepth :: Monad m => (Int -> Int) -> HeistT m () 455 modRecursionDepth f = 456 modifyTS (\st -> st { _recursionDepth = f (_recursionDepth st) }) 457 458 459 ------------------------------------------------------------------------------ 460 -- | Looks up a template name runs a 'HeistT' computation on it. 461 lookupAndRun :: Monad m 462 => ByteString 463 -> ((DocumentFile, TPath) -> HeistT m (Maybe a)) 464 -> HeistT m (Maybe a) 465 lookupAndRun name k = do 466 ts <- getTS 467 let mt = lookupTemplate name ts 468 let curPath = join $ fmap (dfFile . fst) mt 469 modifyTS (setCurTemplateFile curPath) 470 maybe (return Nothing) k mt 471 472 473 ------------------------------------------------------------------------------ 474 -- | Looks up a template name evaluates it by calling runNodeList. 475 evalTemplate :: Monad m 476 => ByteString 477 -> HeistT m (Maybe Template) 478 evalTemplate name = lookupAndRun name 479 (\(t,ctx) -> localTS (\ts -> ts {_curContext = ctx}) 480 (liftM Just $ runNodeList $ X.docContent $ dfDoc t)) 481 482 483 ------------------------------------------------------------------------------ 484 -- | Sets the document type of a 'X.Document' based on the 'HeistT' 485 -- value. 486 fixDocType :: Monad m => X.Document -> HeistT m X.Document 487 fixDocType d = do 488 dts <- getsTS _doctypes 489 return $ d { X.docType = listToMaybe dts } 490 491 492 ------------------------------------------------------------------------------ 493 -- | Same as evalWithHooks, but returns the entire 'X.Document' rather than 494 -- just the nodes. This is the right thing to do if we are starting at the 495 -- top level. 496 evalWithHooksInternal :: Monad m 497 => ByteString 498 -> HeistT m (Maybe X.Document) 499 evalWithHooksInternal name = lookupAndRun name $ \(t,ctx) -> do 500 addDoctype $ maybeToList $ X.docType $ dfDoc t 501 ts <- getTS 502 nodes <- lift $ _preRunHook ts $ X.docContent $ dfDoc t 503 putTS (ts {_curContext = ctx}) 504 res <- runNodeList nodes 505 restoreTS ts 506 newNodes <- lift (_postRunHook ts res) 507 newDoc <- fixDocType $ (dfDoc t) { X.docContent = newNodes } 508 return (Just newDoc) 509 510 511 ------------------------------------------------------------------------------ 512 -- | Looks up a template name evaluates it by calling runNodeList. This also 513 -- executes pre- and post-run hooks and adds the doctype. 514 evalWithHooks :: Monad m 515 => ByteString 516 -> HeistT m (Maybe Template) 517 evalWithHooks name = liftM (liftM X.docContent) (evalWithHooksInternal name) 518 519 520 ------------------------------------------------------------------------------ 521 -- | Binds a list of constant string splices. 522 bindStrings :: Monad m 523 => [(Text, Text)] 524 -> TemplateState m 525 -> TemplateState m 526 bindStrings pairs ts = foldr (uncurry bindString) ts pairs 527 528 529 ------------------------------------------------------------------------------ 530 -- | Binds a single constant string splice. 531 bindString :: Monad m 532 => Text 533 -> Text 534 -> TemplateState m 535 -> TemplateState m 536 bindString n = bindSplice n . textSplice 537 538 539 ------------------------------------------------------------------------------ 540 -- | Renders a template with the specified parameters. This is the function 541 -- to use when you want to "call" a template and pass in parameters from 542 -- inside a splice. 543 callTemplate :: Monad m 544 => ByteString -- ^ The name of the template 545 -> [(Text, Text)] -- ^ Association list of 546 -- (name,value) parameter pairs 547 -> HeistT m (Maybe Template) 548 callTemplate name params = do 549 modifyTS $ bindStrings params 550 evalTemplate name 551 552 553 ------------------------------------------------------------------------------ 554 -- Gives the MIME type for a 'X.Document' 555 mimeType :: X.Document -> ByteString 556 mimeType d = case d of 557 (X.HtmlDocument e _ _) -> "text/html;charset=" `BC.append` enc e 558 (X.XmlDocument e _ _) -> "text/xml;charset=" `BC.append` enc e 559 where 560 enc X.UTF8 = "utf-8" 561 -- Should not include byte order designation for UTF-16 since 562 -- rendering will include a byte order mark. (RFC 2781, Sec. 3.3) 563 enc X.UTF16BE = "utf-16" 564 enc X.UTF16LE = "utf-16" 565 566 567 ------------------------------------------------------------------------------ 568 -- | Renders a template from the specified TemplateState to a 'Builder'. The 569 -- MIME type returned is based on the detected character encoding, and whether 570 -- the root template was an HTML or XML format template. It will always be 571 -- @text/html@ or @text/xml@. If a more specific MIME type is needed for a 572 -- particular XML application, it must be provided by the application. 573 renderTemplate :: Monad m 574 => TemplateState m 575 -> ByteString 576 -> m (Maybe (Builder, MIMEType)) 577 renderTemplate ts name = evalTemplateMonad tpl (X.TextNode "") ts 578 where tpl = do mt <- evalWithHooksInternal name 579 case mt of 580 Nothing -> return Nothing 581 Just doc -> return $ Just $ (X.render doc, mimeType doc) 582 583 584 ------------------------------------------------------------------------------ 585 -- | Renders a template with the specified arguments passed to it. This is a 586 -- convenience function for the common pattern of calling renderTemplate after 587 -- using bindString, bindStrings, or bindSplice to set up the arguments to the 588 -- template. 589 renderWithArgs :: Monad m 590 => [(Text, Text)] 591 -> TemplateState m 592 -> ByteString 593 -> m (Maybe (Builder, MIMEType)) 594 renderWithArgs args ts = renderTemplate (bindStrings args ts) 595 596 597 ------------------------------------------------------------------------------ 598 -- Template loading 599 ------------------------------------------------------------------------------ 600 601 602 ------------------------------------------------------------------------------ 603 -- | Type synonym for parsers. 604 type ParserFun = String -> ByteString -> Either String X.Document 605 606 607 ------------------------------------------------------------------------------ 608 -- | Reads an HTML or XML template from disk. 609 getDocWith :: ParserFun -> String -> IO (Either String DocumentFile) 610 getDocWith parser f = do 611 bs <- catch (liftM Right $ B.readFile f) 612 (\(e::SomeException) -> return $ Left $ show e) 613 614 let eitherDoc = either Left (parser f) bs 615 return $ either (\s -> Left $ f ++ " " ++ s) 616 (\d -> Right $ DocumentFile d (Just f)) eitherDoc 617 618 619 ------------------------------------------------------------------------------ 620 -- | Reads an HTML template from disk. 621 getDoc :: String -> IO (Either String DocumentFile) 622 getDoc = getDocWith X.parseHTML 623 624 625 ------------------------------------------------------------------------------ 626 -- | Reads an XML template from disk. 627 getXMLDoc :: String -> IO (Either String DocumentFile) 628 getXMLDoc = getDocWith X.parseHTML 629 630 631 ------------------------------------------------------------------------------ 632 -- | Loads a template with the specified path and filename. The 633 -- template is only loaded if it has a ".tpl" or ".xtpl" extension. 634 loadTemplate :: String -- ^ path of the template root 635 -> String -- ^ full file path (includes the template root) 636 -> IO [Either String (TPath, DocumentFile)] --TemplateMap 637 loadTemplate templateRoot fname 638 | isHTMLTemplate = do 639 c <- getDoc fname 640 return [fmap (\t -> (splitLocalPath $ BC.pack tName, t)) c] 641 | isXMLTemplate = do 642 c <- getXMLDoc fname 643 return [fmap (\t -> (splitLocalPath $ BC.pack tName, t)) c] 644 | otherwise = return [] 645 where -- tName is path relative to the template root directory 646 isHTMLTemplate = ".tpl" `isSuffixOf` fname 647 isXMLTemplate = ".xtpl" `isSuffixOf` fname 648 correction = if last templateRoot == '/' then 0 else 1 649 extLen = if isHTMLTemplate then 4 else 5 650 tName = drop ((length templateRoot)+correction) $ 651 -- We're only dropping the template root, not the whole path 652 take ((length fname) - extLen) fname 653 654 655 ------------------------------------------------------------------------------ 656 -- | Traverses the specified directory structure and builds a 657 -- TemplateState by loading all the files with a ".tpl" or ".xtpl" extension. 658 loadTemplates :: Monad m => FilePath -> TemplateState m 659 -> IO (Either String (TemplateState m)) 660 loadTemplates dir ts = do 661 d <- readDirectoryWith (loadTemplate dir) dir 662 let tlist = F.fold (free d) 663 errs = lefts tlist 664 case errs of 665 [] -> liftM Right $ foldM loadHook ts $ rights tlist 666 _ -> return $ Left $ unlines errs 667 668 669 ------------------------------------------------------------------------------ 670 -- | Runs a template modifying function on a DocumentFile. 671 runHook :: Monad m => (Template -> m Template) 672 -> DocumentFile 673 -> m DocumentFile 674 runHook f t = do 675 n <- f $ X.docContent $ dfDoc t 676 return $ t { dfDoc = (dfDoc t) { X.docContent = n } } 677 678 679 ------------------------------------------------------------------------------ 680 -- | Runs the onLoad hook on the template and returns the 'TemplateState' 681 -- with the result inserted. 682 loadHook :: Monad m => TemplateState m -> (TPath, DocumentFile) 683 -> IO (TemplateState m) 684 loadHook ts (tp, t) = do 685 t' <- runHook (_onLoadHook ts) t 686 return $ insertTemplate tp t' ts 687 688 689 ------------------------------------------------------------------------------ 690 -- | Adds a path prefix to all the templates in the 'TemplateState'. If you 691 -- want to add multiple levels of directories, separate them with slashes as 692 -- in "foo/bar". Using an empty string as a path prefix will leave the 693 -- 'TemplateState' unchanged. 694 addTemplatePathPrefix :: ByteString -> TemplateState m -> TemplateState m 695 addTemplatePathPrefix dir ts 696 | B.null dir = ts 697 | otherwise = ts { _templateMap = Map.mapKeys f $ _templateMap ts } 698 where 699 f ps = ps++splitTemplatePath dir 700