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