module Clckwrks.Markup.Markdown where

import           Clckwrks.Types                (Trust(..))
import           Control.Concurrent      (forkIO)
import           Control.Concurrent.MVar (newEmptyMVar, readMVar, putMVar)
import           Control.Monad.Trans     (MonadIO(liftIO))
import           Data.Text               (Text)
import qualified Data.Text               as T
import qualified Data.Text.IO            as T
import           Text.HTML.SanitizeXSS   (sanitizeBalance)
import           System.Exit             (ExitCode(ExitFailure, ExitSuccess))
import           System.IO               (hClose)
import           System.Process          (waitForProcess, runInteractiveProcess)

-- | run the text through the 'markdown' executable. If successful,
-- and the input is marked 'Untrusted', run the output through
-- xss-sanitize / sanitizeBalance to prevent injection attacks.
markdown :: (MonadIO m) =>
            Maybe [String]       -- ^ override command-line flags
         -> Trust                -- ^ do we trust the author
         -> Text                 -- ^ markdown text
         -> m (Either Text Text) -- ^ Left error, Right html
markdown :: Maybe [String] -> Trust -> Text -> m (Either Text Text)
markdown Maybe [String]
mArgs Trust
trust Text
txt = IO (Either Text Text) -> m (Either Text Text)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Text Text) -> m (Either Text Text))
-> IO (Either Text Text) -> m (Either Text Text)
forall a b. (a -> b) -> a -> b
$
    do let args :: [String]
args = case Maybe [String]
mArgs of
                    Maybe [String]
Nothing -> [String
"--html4tags"]
                    (Just [String]
a) -> [String]
a
       (Handle
inh, Handle
outh, Handle
errh, ProcessHandle
ph) <- String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> IO (Handle, Handle, Handle, ProcessHandle)
runInteractiveProcess String
"markdown" [String]
args Maybe String
forall a. Maybe a
Nothing Maybe [(String, String)]
forall a. Maybe a
Nothing
       ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do Handle -> Text -> IO ()
T.hPutStr Handle
inh Text
txt
                        Handle -> IO ()
hClose Handle
inh
       MVar Text
mvOut <- IO (MVar Text)
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 Text
c <- Handle -> IO Text
T.hGetContents Handle
outh
                        MVar Text -> Text -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Text
mvOut Text
c
       MVar Text
mvErr <- IO (MVar Text)
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 Text
c <- Handle -> IO Text
T.hGetContents Handle
errh
                        MVar Text -> Text -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Text
mvErr Text
c
       ExitCode
ec <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph
       case ExitCode
ec of
         (ExitFailure Int
_) ->
             do Text
e <- MVar Text -> IO Text
forall a. MVar a -> IO a
readMVar MVar Text
mvErr
                Either Text Text -> IO (Either Text Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Either Text Text
forall a b. a -> Either a b
Left Text
e)
         ExitCode
ExitSuccess ->
             do Text
m <- MVar Text -> IO Text
forall a. MVar a -> IO a
readMVar MVar Text
mvOut
                Text
e <- MVar Text -> IO Text
forall a. MVar a -> IO a
readMVar MVar Text
mvErr
                Either Text Text -> IO (Either Text Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Either Text Text
forall a b. b -> Either a b
Right ((if (Trust
trust Trust -> Trust -> Bool
forall a. Eq a => a -> a -> Bool
== Trust
Untrusted) then Text -> Text
sanitizeBalance else Text -> Text
forall a. a -> a
id) Text
m))