1 {-# LANGUAGE DeriveDataTypeable #-}
    2 
    3 module Text.Templating.Heist.Splices.Markdown where
    4 
    5 ------------------------------------------------------------------------------
    6 import           Data.ByteString (ByteString)
    7 import qualified Data.ByteString as B
    8 import qualified Data.ByteString.Char8 as BC
    9 import           Data.Text (Text)
   10 import qualified Data.Text as T
   11 import qualified Data.Text.Encoding as T
   12 import           Data.Maybe
   13 import           Control.Concurrent
   14 import           Control.Exception (throwIO)
   15 import           Control.Monad
   16 import           Control.Monad.CatchIO
   17 import           Control.Monad.Trans
   18 import           Data.Typeable
   19 import           Prelude hiding (catch)
   20 import           System.Directory
   21 import           System.Exit
   22 import           System.FilePath.Posix
   23 import           System.IO
   24 import           System.Process
   25 import           Text.XmlHtml
   26 
   27 ------------------------------------------------------------------------------
   28 import           Text.Templating.Heist.Internal
   29 import           Text.Templating.Heist.Types
   30 
   31 data PandocMissingException = PandocMissingException
   32    deriving (Typeable)
   33 
   34 instance Show PandocMissingException where
   35     show PandocMissingException =
   36         "Cannot find the \"pandoc\" executable; is it on your $PATH?"
   37 
   38 instance Exception PandocMissingException
   39 
   40 
   41 data MarkdownException = MarkdownException ByteString
   42    deriving (Typeable)
   43 
   44 instance Show MarkdownException where
   45     show (MarkdownException e) =
   46         "Markdown error: pandoc replied:\n\n" ++ BC.unpack e
   47 
   48 instance Exception MarkdownException
   49 
   50 
   51 data NoMarkdownFileException = NoMarkdownFileException
   52     deriving (Typeable)
   53 
   54 instance Show NoMarkdownFileException where
   55     show NoMarkdownFileException =
   56         "Markdown error: no file or template in context during processing of markdown tag"
   57 
   58 instance Exception NoMarkdownFileException where
   59 
   60 ------------------------------------------------------------------------------
   61 -- | Default name for the markdown splice.
   62 markdownTag :: Text
   63 markdownTag = "markdown"
   64 
   65 ------------------------------------------------------------------------------
   66 -- | Implementation of the markdown splice.
   67 markdownSplice :: MonadIO m => Splice m
   68 markdownSplice = do
   69     templateDir <- liftM (fmap takeDirectory) getTemplateFilePath
   70     pdMD <- liftIO $ findExecutable "pandoc"
   71 
   72     when (isNothing pdMD) $ liftIO $ throwIO PandocMissingException
   73 
   74     tree <- getParamNode
   75     (source,markup) <- liftIO $
   76         case getAttribute "file" tree of
   77             Just f  -> do
   78                 m <- maybe (liftIO $ throwIO NoMarkdownFileException )
   79                            (\tp -> pandoc (fromJust pdMD) tp $ T.unpack f)
   80                            templateDir
   81                 return (T.unpack f,m)
   82             Nothing -> do
   83                 m <- pandocBS (fromJust pdMD) $ T.encodeUtf8 $ nodeText tree
   84                 return ("inline_splice",m)
   85 
   86     let ee = parseHTML source markup
   87     case ee of
   88       Left e  -> throw $ MarkdownException
   89                        $ BC.pack ("Error parsing markdown output: " ++ e)
   90       Right d -> return (docContent d)
   91 
   92 
   93 pandoc :: FilePath -> FilePath -> FilePath -> IO ByteString
   94 pandoc pandocPath templateDir inputFile = do
   95     (ex, sout, serr) <- readProcessWithExitCode' pandocPath args ""
   96 
   97     when (isFail ex) $ throw $ MarkdownException serr
   98     return $ BC.concat [ "<div class=\"markdown\">\n"
   99                          , sout
  100                          , "\n</div>" ]
  101 
  102   where
  103     isFail ExitSuccess = False
  104     isFail _           = True
  105 
  106     args = [ "-S", "--no-wrap", templateDir </> inputFile ]
  107 
  108 
  109 pandocBS :: FilePath -> ByteString -> IO ByteString
  110 pandocBS pandocPath s = do
  111     -- using the crummy string functions for convenience here
  112     (ex, sout, serr) <- readProcessWithExitCode' pandocPath args s
  113 
  114     when (isFail ex) $ throw $ MarkdownException serr
  115     return $ BC.concat [ "<div class=\"markdown\">\n"
  116                        , sout
  117                        , "\n</div>" ]
  118 
  119   where
  120     isFail ExitSuccess = False
  121     isFail _           = True
  122     args = [ "-S", "--no-wrap" ]
  123 
  124 
  125 -- a version of readProcessWithExitCode that does I/O properly
  126 readProcessWithExitCode'
  127     :: FilePath                 -- ^ command to run
  128     -> [String]                 -- ^ any arguments
  129     -> ByteString               -- ^ standard input
  130     -> IO (ExitCode,ByteString,ByteString) -- ^ exitcode, stdout, stderr
  131 readProcessWithExitCode' cmd args input = do
  132     (Just inh, Just outh, Just errh, pid) <-
  133         createProcess (proc cmd args){ std_in  = CreatePipe,
  134                                        std_out = CreatePipe,
  135                                        std_err = CreatePipe }
  136     outMVar <- newEmptyMVar
  137 
  138     outM <- newEmptyMVar
  139     errM <- newEmptyMVar
  140 
  141     -- fork off a thread to start consuming stdout
  142     forkIO $ do
  143         out <- B.hGetContents outh
  144         putMVar outM out
  145         putMVar outMVar ()
  146 
  147     -- fork off a thread to start consuming stderr
  148     forkIO $ do
  149         err  <- B.hGetContents errh
  150         putMVar errM err
  151         putMVar outMVar ()
  152 
  153     -- now write and flush any input
  154     when (not (B.null input)) $ do B.hPutStr inh input; hFlush inh
  155     hClose inh -- done with stdin
  156 
  157     -- wait on the output
  158     takeMVar outMVar
  159     takeMVar outMVar
  160     hClose outh
  161 
  162     -- wait on the process
  163     ex <- waitForProcess pid
  164 
  165     out <- readMVar outM
  166     err <- readMVar errM
  167 
  168     return (ex, out, err)
  169 
  170 
  171 
  172