module Clckwrks.Markup.HsColour where

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 and, if
-- successful, run the output through xss-sanitize / sanitizeBalance
-- to prevent injection attacks.
hscolour :: (MonadIO m) =>
            Maybe [String] -- ^ override command-line flags
         -> Text -- ^ markdown text
         -> m (Either Text Text) -- ^ Left error, Right html
hscolour :: Maybe [String] -> Text -> m (Either Text Text)
hscolour Maybe [String]
mArgs 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
"-lit",String
"-partial",String
"-css"]
                    (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
"HsColour" [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
                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 ({- sanitizeBalance -} Text
m))