{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE RecordWildCards #-}
module Heist.Splices.Markdown
(
PandocMissingException
, MarkdownException
, NoMarkdownFileException
, markdownTag
, markdownSplice
, pandocSplice
, PandocOptions
, defaultPandocOptions
, setPandocExecutable
, setPandocArgs
, setPandocBaseDir
, setPandocWrapDiv
, 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 -> String
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 -> String
show (MarkdownException e :: ByteString
e) =
"Markdown error: pandoc replied:\n\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
BC.unpack ByteString
e
instance Exception MarkdownException
data NoMarkdownFileException = NoMarkdownFileException
deriving (Typeable)
instance Show NoMarkdownFileException where
show :: NoMarkdownFileException -> String
show NoMarkdownFileException =
"Markdown error: no file or template in context" String -> ShowS
forall a. [a] -> [a] -> [a]
++
" during processing of markdown tag"
instance Exception NoMarkdownFileException where
data PandocOptions = PandocOptions
{ PandocOptions -> String
_pandocExecutable :: FilePath
, PandocOptions -> [String]
_pandocArgs :: [String]
, PandocOptions -> Maybe String
_pandocBaseDir :: Maybe FilePath
, PandocOptions -> Maybe Text
_pandocWrapDiv :: Maybe Text
} deriving (PandocOptions -> PandocOptions -> Bool
(PandocOptions -> PandocOptions -> Bool)
-> (PandocOptions -> PandocOptions -> Bool) -> Eq PandocOptions
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PandocOptions -> PandocOptions -> Bool
$c/= :: PandocOptions -> PandocOptions -> Bool
== :: PandocOptions -> PandocOptions -> Bool
$c== :: PandocOptions -> PandocOptions -> Bool
Eq, Eq PandocOptions
Eq PandocOptions =>
(PandocOptions -> PandocOptions -> Ordering)
-> (PandocOptions -> PandocOptions -> Bool)
-> (PandocOptions -> PandocOptions -> Bool)
-> (PandocOptions -> PandocOptions -> Bool)
-> (PandocOptions -> PandocOptions -> Bool)
-> (PandocOptions -> PandocOptions -> PandocOptions)
-> (PandocOptions -> PandocOptions -> PandocOptions)
-> Ord PandocOptions
PandocOptions -> PandocOptions -> Bool
PandocOptions -> PandocOptions -> Ordering
PandocOptions -> PandocOptions -> PandocOptions
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PandocOptions -> PandocOptions -> PandocOptions
$cmin :: PandocOptions -> PandocOptions -> PandocOptions
max :: PandocOptions -> PandocOptions -> PandocOptions
$cmax :: PandocOptions -> PandocOptions -> PandocOptions
>= :: PandocOptions -> PandocOptions -> Bool
$c>= :: PandocOptions -> PandocOptions -> Bool
> :: PandocOptions -> PandocOptions -> Bool
$c> :: PandocOptions -> PandocOptions -> Bool
<= :: PandocOptions -> PandocOptions -> Bool
$c<= :: PandocOptions -> PandocOptions -> Bool
< :: PandocOptions -> PandocOptions -> Bool
$c< :: PandocOptions -> PandocOptions -> Bool
compare :: PandocOptions -> PandocOptions -> Ordering
$ccompare :: PandocOptions -> PandocOptions -> Ordering
$cp1Ord :: Eq PandocOptions
Ord, Int -> PandocOptions -> ShowS
[PandocOptions] -> ShowS
PandocOptions -> String
(Int -> PandocOptions -> ShowS)
-> (PandocOptions -> String)
-> ([PandocOptions] -> ShowS)
-> Show PandocOptions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PandocOptions] -> ShowS
$cshowList :: [PandocOptions] -> ShowS
show :: PandocOptions -> String
$cshow :: PandocOptions -> String
showsPrec :: Int -> PandocOptions -> ShowS
$cshowsPrec :: Int -> PandocOptions -> ShowS
Show)
defaultPandocOptions :: PandocOptions
defaultPandocOptions :: PandocOptions
defaultPandocOptions = String -> [String] -> Maybe String -> Maybe Text -> PandocOptions
PandocOptions "pandoc"
[]
Maybe String
forall a. Maybe a
Nothing
(Text -> Maybe Text
forall a. a -> Maybe a
Just "markdown")
setPandocExecutable :: FilePath -> PandocOptions -> PandocOptions
setPandocExecutable :: String -> PandocOptions -> PandocOptions
setPandocExecutable e :: String
e opt :: PandocOptions
opt = PandocOptions
opt { _pandocExecutable :: String
_pandocExecutable = String
e }
setPandocArgs :: [String] -> PandocOptions -> PandocOptions
setPandocArgs :: [String] -> PandocOptions -> PandocOptions
setPandocArgs args :: [String]
args opt :: PandocOptions
opt = PandocOptions
opt { _pandocArgs :: [String]
_pandocArgs = [String]
args }
setPandocBaseDir :: Maybe FilePath -> PandocOptions -> PandocOptions
setPandocBaseDir :: Maybe String -> PandocOptions -> PandocOptions
setPandocBaseDir bd :: Maybe String
bd opt :: PandocOptions
opt = PandocOptions
opt { _pandocBaseDir :: Maybe String
_pandocBaseDir = Maybe String
bd }
setPandocWrapDiv :: Maybe Text -> PandocOptions -> PandocOptions
setPandocWrapDiv :: Maybe Text -> PandocOptions -> PandocOptions
setPandocWrapDiv wd :: Maybe Text
wd opt :: PandocOptions
opt = PandocOptions
opt { _pandocWrapDiv :: Maybe Text
_pandocWrapDiv = Maybe Text
wd }
pandocExecutable :: Functor f =>
(FilePath -> f FilePath) -> PandocOptions -> f PandocOptions
pandocExecutable :: (String -> f String) -> PandocOptions -> f PandocOptions
pandocExecutable f :: String -> f String
f po :: PandocOptions
po = (\e :: String
e -> PandocOptions
po { _pandocExecutable :: String
_pandocExecutable = String
e})
(String -> PandocOptions) -> f String -> f PandocOptions
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> f String
f (PandocOptions -> String
_pandocExecutable PandocOptions
po)
pandocArgs :: Functor f =>
([String] -> f [String]) -> PandocOptions -> f PandocOptions
pandocArgs :: ([String] -> f [String]) -> PandocOptions -> f PandocOptions
pandocArgs f :: [String] -> f [String]
f po :: PandocOptions
po = (\a :: [String]
a -> PandocOptions
po { _pandocArgs :: [String]
_pandocArgs = [String]
a}) ([String] -> PandocOptions) -> f [String] -> f PandocOptions
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> f [String]
f (PandocOptions -> [String]
_pandocArgs PandocOptions
po)
pandocBaseDir :: Functor f =>
(Maybe FilePath -> f (Maybe FilePath)) -> PandocOptions -> f PandocOptions
pandocBaseDir :: (Maybe String -> f (Maybe String))
-> PandocOptions -> f PandocOptions
pandocBaseDir f :: Maybe String -> f (Maybe String)
f po :: PandocOptions
po = (\b :: Maybe String
b -> PandocOptions
po {_pandocBaseDir :: Maybe String
_pandocBaseDir = Maybe String
b }) (Maybe String -> PandocOptions)
-> f (Maybe String) -> f PandocOptions
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String -> f (Maybe String)
f (PandocOptions -> Maybe String
_pandocBaseDir PandocOptions
po)
pandocWrapDiv :: Functor f =>
(Maybe Text -> f (Maybe Text)) -> PandocOptions -> f PandocOptions
pandocWrapDiv :: (Maybe Text -> f (Maybe Text)) -> PandocOptions -> f PandocOptions
pandocWrapDiv f :: Maybe Text -> f (Maybe Text)
f po :: PandocOptions
po = (\w :: Maybe Text
w -> PandocOptions
po {_pandocWrapDiv :: Maybe Text
_pandocWrapDiv = Maybe Text
w}) (Maybe Text -> PandocOptions) -> f (Maybe Text) -> f PandocOptions
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text -> f (Maybe Text)
f (PandocOptions -> Maybe Text
_pandocWrapDiv PandocOptions
po)
markdownTag :: Text
markdownTag :: Text
markdownTag = "markdown"
markdownSplice :: MonadIO m => Splice m
markdownSplice :: Splice m
markdownSplice= PandocOptions -> Splice m
forall (m :: * -> *). MonadIO m => PandocOptions -> Splice m
pandocSplice PandocOptions
defaultPandocOptions
pandocSplice :: MonadIO m => PandocOptions -> Splice m
pandocSplice :: PandocOptions -> Splice m
pandocSplice PandocOptions{..} = do
Maybe String
templateDir <- (Maybe String -> Maybe String)
-> HeistT m m (Maybe String) -> HeistT m m (Maybe String)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (ShowS -> Maybe String -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ShowS
takeDirectory) HeistT m m (Maybe String)
forall (m :: * -> *) (n :: * -> *).
Monad m =>
HeistT n m (Maybe String)
getTemplateFilePath
Maybe String
pdMD <- IO (Maybe String) -> HeistT m m (Maybe String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> HeistT m m (Maybe String))
-> IO (Maybe String) -> HeistT m m (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
findExecutable String
_pandocExecutable
String
pandocExe <- case Maybe String
pdMD of
Nothing -> IO String -> HeistT m m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> HeistT m m String) -> IO String -> HeistT m m String
forall a b. (a -> b) -> a -> b
$ PandocMissingException -> IO String
forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO PandocMissingException
PandocMissingException
Just pd :: String
pd -> String -> HeistT m m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
pd
let withDir :: ShowS
withDir tp :: String
tp = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
tp Maybe String
_pandocBaseDir
pandocFile :: String -> String -> IO ByteString
pandocFile f :: String
f tp :: String
tp = String -> [String] -> String -> String -> IO ByteString
pandocWith String
pandocExe [String]
_pandocArgs (ShowS
withDir String
tp) String
f
Node
tree <- HeistT m m Node
forall (m :: * -> *) (n :: * -> *). Monad m => HeistT n m Node
getParamNode
(source :: String
source,markup :: ByteString
markup) <- IO (String, ByteString) -> HeistT m m (String, ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (String, ByteString) -> HeistT m m (String, ByteString))
-> IO (String, ByteString) -> HeistT m m (String, ByteString)
forall a b. (a -> b) -> a -> b
$
case Text -> Node -> Maybe Text
getAttribute "file" Node
tree of
Just f :: Text
f -> do
ByteString
m <- IO ByteString
-> (String -> IO ByteString) -> Maybe String -> IO ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO ByteString -> IO ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> IO ByteString) -> IO ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ NoMarkdownFileException -> IO ByteString
forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO NoMarkdownFileException
NoMarkdownFileException )
(String -> String -> IO ByteString
pandocFile (Text -> String
T.unpack Text
f))
Maybe String
templateDir
(String, ByteString) -> IO (String, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> String
T.unpack Text
f,ByteString
m)
Nothing -> do
ByteString
m <- String -> [String] -> ByteString -> IO ByteString
pandocWithBS String
pandocExe [String]
_pandocArgs (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Node -> Text
nodeText Node
tree
(String, ByteString) -> IO (String, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return ("inline_splice",ByteString
m)
let ee :: Either String Document
ee = String -> ByteString -> Either String Document
parseHTML String
source ByteString
markup
nodeAttrs :: [(Text, Text)]
nodeAttrs = case Node
tree of
Element _ a :: [(Text, Text)]
a _ -> [(Text, Text)]
a
_ -> []
nodeClass :: Maybe Text
nodeClass = Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "class" [(Text, Text)]
nodeAttrs
attrs :: [(Text, Text)]
attrs = ((Text, Text) -> Bool) -> [(Text, Text)] -> [(Text, Text)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(name :: Text
name, _) -> Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= "class" Bool -> Bool -> Bool
&& Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= "file") [(Text, Text)]
nodeAttrs
case Either String Document
ee of
Left e :: String
e -> MarkdownException -> Splice m
forall a e. Exception e => e -> a
throw (MarkdownException -> Splice m) -> MarkdownException -> Splice m
forall a b. (a -> b) -> a -> b
$ ByteString -> MarkdownException
MarkdownException
(ByteString -> MarkdownException)
-> ByteString -> MarkdownException
forall a b. (a -> b) -> a -> b
$ String -> ByteString
BC.pack ("Error parsing markdown output: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
e)
Right d :: Document
d -> [Node] -> Splice m
forall (m :: * -> *) a. Monad m => a -> m a
return ([Node] -> Splice m) -> [Node] -> Splice m
forall a b. (a -> b) -> a -> b
$ Maybe Text -> [(Text, Text)] -> [Node] -> [Node]
wrapResult Maybe Text
nodeClass [(Text, Text)]
attrs (Document -> [Node]
docContent Document
d)
where
wrapResult :: Maybe Text -> [(Text, Text)] -> [Node] -> [Node]
wrapResult nodeClass :: Maybe Text
nodeClass attrs :: [(Text, Text)]
attrs body :: [Node]
body = case Maybe Text
_pandocWrapDiv of
Nothing -> [Node]
body
Just cls :: Text
cls -> let finalAttrs :: [(Text, Text)]
finalAttrs = ("class", Maybe Text -> Text -> Text
appendClass Maybe Text
nodeClass Text
cls)(Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
:[(Text, Text)]
attrs
in [Text -> [(Text, Text)] -> [Node] -> Node
Element "div" [(Text, Text)]
finalAttrs [Node]
body]
appendClass :: Maybe Text -> Text -> Text
appendClass Nothing cls :: Text
cls = Text
cls
appendClass (Just orig :: Text
orig) cls :: Text
cls = [Text] -> Text
T.concat [Text
orig, " ", Text
cls]
pandocWith :: FilePath -> [String] -> FilePath -> FilePath -> IO ByteString
pandocWith :: String -> [String] -> String -> String -> IO ByteString
pandocWith path :: String
path args :: [String]
args templateDir :: String
templateDir inputFile :: String
inputFile = do
(ex :: ExitCode
ex, sout :: ByteString
sout, serr :: ByteString
serr) <- String
-> [String] -> ByteString -> IO (ExitCode, ByteString, ByteString)
readProcessWithExitCode' String
path [String]
args' ""
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExitCode -> Bool
isFail ExitCode
ex) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MarkdownException -> IO ()
forall a e. Exception e => e -> a
throw (MarkdownException -> IO ()) -> MarkdownException -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> MarkdownException
MarkdownException ByteString
serr
ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
sout
where
isFail :: ExitCode -> Bool
isFail ExitSuccess = Bool
False
isFail _ = Bool
True
args' :: [String]
args' = [String]
args [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
templateDir String -> ShowS
</> String
inputFile ]
pandocWithBS :: FilePath -> [String] -> ByteString -> IO ByteString
pandocWithBS :: String -> [String] -> ByteString -> IO ByteString
pandocWithBS pandocPath :: String
pandocPath args :: [String]
args s :: ByteString
s = do
(ex :: ExitCode
ex, sout :: ByteString
sout, serr :: ByteString
serr) <- String
-> [String] -> ByteString -> IO (ExitCode, ByteString, ByteString)
readProcessWithExitCode' String
pandocPath [String]
args ByteString
s
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExitCode -> Bool
isFail ExitCode
ex) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MarkdownException -> IO ()
forall a e. Exception e => e -> a
throw (MarkdownException -> IO ()) -> MarkdownException -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> MarkdownException
MarkdownException ByteString
serr
ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
sout
where
isFail :: ExitCode -> Bool
isFail ExitSuccess = Bool
False
isFail _ = Bool
True
readProcessWithExitCode'
:: FilePath
-> [String]
-> ByteString
-> IO (ExitCode,ByteString,ByteString)
readProcessWithExitCode' :: String
-> [String] -> ByteString -> IO (ExitCode, ByteString, ByteString)
readProcessWithExitCode' cmd :: String
cmd args :: [String]
args input :: ByteString
input = do
(Just inh :: Handle
inh, Just outh :: Handle
outh, Just errh :: Handle
errh, pid :: ProcessHandle
pid) <-
CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (String -> [String] -> CreateProcess
proc String
cmd [String]
args){ std_in :: StdStream
std_in = StdStream
CreatePipe,
std_out :: StdStream
std_out = StdStream
CreatePipe,
std_err :: StdStream
std_err = StdStream
CreatePipe }
MVar ()
outMVar <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
MVar ByteString
outM <- IO (MVar ByteString)
forall a. IO (MVar a)
newEmptyMVar
MVar ByteString
errM <- IO (MVar ByteString)
forall a. IO (MVar a)
newEmptyMVar
ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
ByteString
out <- Handle -> IO ByteString
B.hGetContents Handle
outh
MVar ByteString -> ByteString -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ByteString
outM ByteString
out
MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
outMVar ()
ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
ByteString
err <- Handle -> IO ByteString
B.hGetContents Handle
errh
MVar ByteString -> ByteString -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ByteString
errM ByteString
err
MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
outMVar ()
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (ByteString -> Bool
B.null ByteString
input)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do Handle -> ByteString -> IO ()
B.hPutStr Handle
inh ByteString
input; Handle -> IO ()
hFlush Handle
inh
Handle -> IO ()
hClose Handle
inh
MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
outMVar
MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
outMVar
Handle -> IO ()
hClose Handle
outh
ExitCode
ex <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
pid
ByteString
out <- MVar ByteString -> IO ByteString
forall a. MVar a -> IO a
readMVar MVar ByteString
outM
ByteString
err <- MVar ByteString -> IO ByteString
forall a. MVar a -> IO a
readMVar MVar ByteString
errM
(ExitCode, ByteString, ByteString)
-> IO (ExitCode, ByteString, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode
ex, ByteString
out, ByteString
err)