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.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
markdownTag :: Text
markdownTag = "markdown"
markdownSplice :: MonadIO m => FilePath -> Splice m
markdownSplice templatePath = do
pdMD <- liftIO $ findExecutable "pandoc"
when (isNothing pdMD) $ liftIO $ throwIO PandocMissingException
tree <- getParamNode
(source,markup) <- liftIO $
case getAttribute "file" tree of
Just f -> do
m <- pandoc (fromJust pdMD) templatePath $ T.unpack f
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 templatePath inputFile = do
(ex, sout, serr) <- readProcessWithExitCode' pandocPath args ""
when (isFail ex) $ throw $ MarkdownException serr
return $ BC.concat [ "<div class=\"markdown\">\n"
, sout
, "\n</div>" ]
where
isFail ExitSuccess = False
isFail _ = True
args = [ "-S", "--no-wrap", templatePath </> inputFile ]
pandocBS :: FilePath -> ByteString -> IO ByteString
pandocBS pandocPath s = do
(ex, sout, serr) <- readProcessWithExitCode' pandocPath args s
when (isFail ex) $ throw $ MarkdownException serr
return $ BC.concat [ "<div class=\"markdown\">\n"
, sout
, "\n</div>" ]
where
isFail ExitSuccess = False
isFail _ = True
args = [ "-S", "--no-wrap" ]
readProcessWithExitCode'
:: FilePath
-> [String]
-> ByteString
-> IO (ExitCode,ByteString,ByteString)
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
forkIO $ do
out <- B.hGetContents outh
putMVar outM out
putMVar outMVar ()
forkIO $ do
err <- B.hGetContents errh
putMVar errM err
putMVar outMVar ()
when (not (B.null input)) $ do B.hPutStr inh input; hFlush inh
hClose inh
takeMVar outMVar
takeMVar outMVar
hClose outh
ex <- waitForProcess pid
out <- readMVar outM
err <- readMVar errM
return (ex, out, err)