Markdown.hs

{-# LANGUAGE CPP                #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE RecordWildCards    #-}
{-| The \"markdown\" splice formats markdown content as HTML and inserts
it into the document.

If the file attribute is present the contents of the tag is ignored and
the file specified is converted to HTML.

Otherwise the non-markup children of the tag are processed as markdown
and converted to HTML.

This splice requires that the \"pandoc\" executable is in your path.

You can add custom pandoc splice with 'pandocSplice'. It is not limited to
markdown input, and can process anything pandoc can.

For example you can create a page with generated table of contents, using
heist template as pandoc template.

>  <!-- _wrap.tpl -->
>  <html>
>    <head> <title> <pageTitle/> </title> </head>
>
>    <div class="nav"> <pageToc/> </div>
>    <apply-content/>
>  </html>

And pandoc template, which would bind @pageTitle@ and @pageToc@ splices and
applies "_wrap" template.

>  <!-- _pandoc.tpl -->
>  <apply template="_wrap.tpl">
>    <bind tag="pageTitle"> $title$</bind>
>    <bind tag="pageToc"> $toc$</bind>
>    $body$
>  </apply>

Bind splice pandoc splice. Set it to not wrap in div, or it will break html
from _wrap.tpl

>  splices = "docmarkdown" ## pandocSplice opts
>    where
>      opts = setPandocArgs  ["-S", "--no-wrap", "--toc"
>                            , "--standalone"
>                            , "--template", "_pandoc.tpl"
>                            , "--html5"]
>             $ setPandocWrapDiv Nothing
>             $ defaultPandocOptions
>

And then use it to render your markdown file


>  <!-- apidocs.tpl -->
>  <DOCTYPE html>
>  <html lang="en">
>  <head>
>    <link href="/static/css/site.css rel="stylesheet">
>  </head>
>  <body>
>    <apply template="_navbar.tpl" />
>    <docmarkdown file="apidocs.md"/>
>  </body>

-}
module Heist.Splices.Markdown
  (
  -- * Exceptions
    PandocMissingException
  , MarkdownException
  , NoMarkdownFileException
  -- * Markdown Splice
  , markdownTag
  , markdownSplice
  -- * Generic pandoc splice
  , pandocSplice
  -- ** Pandoc Options
  , PandocOptions
  , defaultPandocOptions
  , setPandocExecutable
  , setPandocArgs
  , setPandocBaseDir
  , setPandocWrapDiv
  -- ** Lens for 'PandocOptions'
  , pandocExecutable
  , pandocArgs
  , pandocBaseDir
  , pandocWrapDiv
  ) where

------------------------------------------------------------------------------
import           Control.Concurrent
import           Control.Exception.Lifted
import           Control.Monad
import           Control.Monad.Trans
import           Data.ByteString                 (ByteString)
import qualified Data.ByteString                 as B
import qualified Data.ByteString.Char8           as BC
import           Data.Maybe                      (fromMaybe)
import           Data.Text                       (Text)
import qualified Data.Text                       as T
import qualified Data.Text.Encoding              as T
import           Data.Typeable
import           System.Directory
import           System.Exit
import           System.FilePath.Posix
import           System.IO
import           System.Process
import           Text.XmlHtml

#if !MIN_VERSION_base(4,8,0)
import           Control.Applicative             ((<$>))
#endif

------------------------------------------------------------------------------
import           Heist.Common
import           Heist.Internal.Types.HeistState
import           Heist.Interpreted.Internal

data PandocMissingException = PandocMissingException
   deriving (Typeable)

instance Show PandocMissingException where
    show PandocMissingException =
        "Cannot find the \"pandoc\" executable.  If you have Haskell, then install it with \"cabal install\".  Otherwise you can download it from http://johnmacfarlane.net/pandoc/installing.html.  Then make sure it is in 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


data NoMarkdownFileException = NoMarkdownFileException
    deriving (Typeable)

instance Show NoMarkdownFileException where
    show NoMarkdownFileException =
        "Markdown error: no file or template in context" ++
        " during processing of markdown tag"

instance Exception NoMarkdownFileException where

--------------------------------------------------------------------------------

data PandocOptions = PandocOptions
     { _pandocExecutable :: FilePath
     , _pandocArgs       :: [String]         -- ^ Arguments to pandoc
     , _pandocBaseDir    :: Maybe FilePath   -- ^ Base directory for input files
                                             --   defaults to template path
     , _pandocWrapDiv    :: Maybe Text       -- ^ Wrap content in div with class
     } deriving (Eq, Ord, Show)

-- | Default options
defaultPandocOptions :: PandocOptions
defaultPandocOptions = PandocOptions "pandoc"
                                     []
                                     Nothing
                                     (Just "markdown")

-- | Name of pandoc executable
setPandocExecutable :: FilePath -> PandocOptions -> PandocOptions
setPandocExecutable e opt = opt { _pandocExecutable = e }

-- | Arguments passed to pandoc
setPandocArgs :: [String] -> PandocOptions -> PandocOptions
setPandocArgs args opt = opt { _pandocArgs = args }

-- | Base directory for input files, defaults to current template dir
setPandocBaseDir :: Maybe FilePath -> PandocOptions -> PandocOptions
setPandocBaseDir bd opt = opt { _pandocBaseDir = bd }

-- | Wrap pandoc output in div with class. Appends node attributes to
--   div and appends class to ones specified on node.
setPandocWrapDiv :: Maybe Text -> PandocOptions -> PandocOptions
setPandocWrapDiv wd opt = opt { _pandocWrapDiv = wd }

pandocExecutable :: Functor f =>
     (FilePath -> f FilePath) -> PandocOptions -> f PandocOptions
pandocExecutable f po = (\e -> po { _pandocExecutable = e})
                       <$> f (_pandocExecutable po)

pandocArgs :: Functor f =>
     ([String] -> f [String]) -> PandocOptions -> f PandocOptions
pandocArgs f po = (\a -> po { _pandocArgs = a}) <$> f (_pandocArgs po)

pandocBaseDir :: Functor f =>
     (Maybe FilePath -> f (Maybe FilePath)) -> PandocOptions -> f PandocOptions
pandocBaseDir f po = (\b -> po {_pandocBaseDir = b }) <$> f (_pandocBaseDir po)

pandocWrapDiv :: Functor f =>
     (Maybe Text -> f (Maybe Text)) -> PandocOptions -> f PandocOptions
pandocWrapDiv f po = (\w -> po {_pandocWrapDiv = w}) <$> f (_pandocWrapDiv po)

------------------------------------------------------------------------------
-- | Default name for the markdown splice.
markdownTag :: Text
markdownTag = "markdown"

------------------------------------------------------------------------------
-- | Default markdown splice with executable "pandoc"
markdownSplice :: MonadIO m => Splice m
markdownSplice= pandocSplice defaultPandocOptions

-- | Implementation of the markdown splice.
pandocSplice :: MonadIO m => PandocOptions -> Splice m
pandocSplice PandocOptions{..} = do
    templateDir <- liftM (fmap takeDirectory) getTemplateFilePath
    pdMD <- liftIO $ findExecutable _pandocExecutable

    pandocExe <- case pdMD of
       Nothing -> liftIO $ throwIO PandocMissingException
       Just pd -> return pd
    let withDir tp = fromMaybe tp _pandocBaseDir
        pandocFile f tp = pandocWith pandocExe _pandocArgs (withDir tp) f
    tree <- getParamNode
    (source,markup) <- liftIO $
        case getAttribute "file" tree of
            Just f  -> do
                m <- maybe (liftIO $ throwIO NoMarkdownFileException )
                           (pandocFile (T.unpack f))
                           templateDir
                return (T.unpack f,m)
            Nothing -> do
                m <- pandocWithBS pandocExe _pandocArgs $ T.encodeUtf8 $ nodeText tree
                return ("inline_splice",m)

    let ee = parseHTML source markup
        nodeAttrs = case tree of
          Element _ a _ -> a
          _ -> []
        nodeClass = lookup "class" nodeAttrs
        attrs = filter (\(name, _) -> name /= "class" && name /= "file") nodeAttrs
    case ee of
      Left e  -> throw $ MarkdownException
                       $ BC.pack ("Error parsing markdown output: " ++ e)
      Right d -> return $ wrapResult nodeClass attrs (docContent d)

  where
    wrapResult nodeClass attrs body = case _pandocWrapDiv of
        Nothing -> body
        Just cls -> let finalAttrs = ("class", appendClass nodeClass cls):attrs
                    in [Element "div" finalAttrs  body]
    appendClass Nothing cls = cls
    appendClass (Just orig) cls = T.concat [orig, " ", cls]


pandocWith :: FilePath -> [String] -> FilePath -> FilePath -> IO ByteString
pandocWith path args templateDir inputFile = do
    (ex, sout, serr) <- readProcessWithExitCode' path args' ""

    when (isFail ex) $ throw $ MarkdownException serr
    return sout

  where
    isFail ExitSuccess = False
    isFail _           = True

    args' = args ++ [templateDir </> inputFile ]

pandocWithBS :: FilePath -> [String] -> ByteString -> IO ByteString
pandocWithBS pandocPath args s = do
    -- using the crummy string functions for convenience here
    (ex, sout, serr) <- readProcessWithExitCode' pandocPath args s

    when (isFail ex) $ throw $ MarkdownException serr
    return sout

  where
    isFail ExitSuccess = False
    isFail _           = True


-- a version of readProcessWithExitCode that does I/O properly
readProcessWithExitCode'
    :: FilePath                 -- ^ command to run
    -> [String]                 -- ^ any arguments
    -> ByteString               -- ^ standard input
    -> IO (ExitCode,ByteString,ByteString) -- ^ exitcode, stdout, stderr
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

    -- fork off a thread to start consuming stdout
    _ <- forkIO $ do
        out <- B.hGetContents outh
        putMVar outM out
        putMVar outMVar ()

    -- fork off a thread to start consuming stderr
    _ <- forkIO $ do
        err  <- B.hGetContents errh
        putMVar errM err
        putMVar outMVar ()

    -- now write and flush any input
    when (not (B.null input)) $ do B.hPutStr inh input; hFlush inh
    hClose inh -- done with stdin

    -- wait on the output
    takeMVar outMVar
    takeMVar outMVar
    hClose outh

    -- wait on the process
    ex <- waitForProcess pid

    out <- readMVar outM
    err <- readMVar errM

    return (ex, out, err)