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