Common.hs

{-# 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
                            idp <- identParser
                            dl' <- finish subDL
                            loop $! append dl' idp)

    gobbleText = AP.takeWhile1 (AP.notInClass "$")

    identParser = AP.char '$' *> (ident <|> return (Literal "$"))
    ident = (AP.char '{' *> (Ident <$> AP.takeWhile (/='}')) <* AP.string "}")


------------------------------------------------------------------------------
-- | 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 = do
    c <- loadTemplate' fname
    return $ map (fmap (\t -> (splitLocalPath $ BC.pack tName, t))) c
  where -- tName is path relative to the template root directory
    isHTMLTemplate = ".tpl"  `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


------------------------------------------------------------------------------
-- | Loads a template at the specified path, choosing the appropriate parser
-- based on the file extension.  The template is only loaded if it has a
-- \".tpl\" or \".xtpl\" extension.  Returns an empty list if the extension
-- doesn't match.
loadTemplate' :: String -> IO [Either String DocumentFile]
loadTemplate' fullDiskPath
    | isHTMLTemplate = liftM (:[]) $ getDoc fullDiskPath
    | isXMLTemplate = liftM (:[]) $ getXMLDoc fullDiskPath
    | otherwise = return []
  where
    isHTMLTemplate = ".tpl"  `isSuffixOf` fullDiskPath
    isXMLTemplate  = ".xtpl" `isSuffixOf` fullDiskPath


------------------------------------------------------------------------------
-- | Type 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"


------------------------------------------------------------------------------
-- | Binds a set of new splice declarations within a 'HeistState'.
bindAttributeSplices :: [(T.Text, AttrSplice n)] -- ^ splices to bind
                     -> HeistState n             -- ^ start state
                     -> HeistState n
bindAttributeSplices ss hs =
    hs { _attrSpliceMap = Map.union (Map.fromList ss) (_attrSpliceMap hs) }