Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

289 lines (231 sloc) 11.266 kb
{-# 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"
Jump to Line
Something went wrong with that request. Please try again.