{-# LANGUAGE CPP #-}

--------------------------------------------------------------------------------
-- | A Compiler that supports unix filters.
module Hakyll.Core.UnixFilter
    ( unixFilter
    , unixFilterLBS
    ) where


--------------------------------------------------------------------------------
import           Control.Concurrent      (forkIO)
import           Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
import           Control.DeepSeq         (deepseq)
import           Control.Monad           (forM_)
import           Data.ByteString.Lazy    (ByteString)
import qualified Data.ByteString.Lazy    as LB
import           Data.IORef              (newIORef, readIORef, writeIORef)
import           System.Exit             (ExitCode (..))
import           System.IO               (Handle, hClose, hFlush, hGetContents,
                                          hPutStr, hSetEncoding, localeEncoding)
import           System.Process

--------------------------------------------------------------------------------
import           Hakyll.Core.Compiler


--------------------------------------------------------------------------------
-- | Use a unix filter as compiler. For example, we could use the 'rev' program
-- as a compiler.
--
-- > rev :: Compiler (Item String)
-- > rev = getResourceString >>= withItemBody (unixFilter "rev" [])
--
-- A more realistic example: one can use this to call, for example, the sass
-- compiler on CSS files. More information about sass can be found here:
--
-- <http://sass-lang.com/>
--
-- The code is fairly straightforward, given that we use @.scss@ for sass:
--
-- > match "style.scss" $ do
-- >     route   $ setExtension "css"
-- >     compile $ getResourceString >>=
-- >         withItemBody (unixFilter "sass" ["-s", "--scss"]) >>=
-- >         return . fmap compressCss
unixFilter :: String           -- ^ Program name
           -> [String]         -- ^ Program args
           -> String           -- ^ Program input
           -> Compiler String  -- ^ Program output
unixFilter :: String -> [String] -> String -> Compiler String
unixFilter = (Handle -> String -> IO ())
-> (Handle -> IO String)
-> String
-> [String]
-> String
-> Compiler String
forall o i.
Monoid o =>
(Handle -> i -> IO ())
-> (Handle -> IO o) -> String -> [String] -> i -> Compiler o
unixFilterWith Handle -> String -> IO ()
writer Handle -> IO String
reader
  where
    writer :: Handle -> String -> IO ()
writer Handle
handle String
input = do
        Handle -> TextEncoding -> IO ()
hSetEncoding Handle
handle TextEncoding
localeEncoding
        Handle -> String -> IO ()
hPutStr Handle
handle String
input
    reader :: Handle -> IO String
reader Handle
handle = do
        Handle -> TextEncoding -> IO ()
hSetEncoding Handle
handle TextEncoding
localeEncoding
        String
out <- Handle -> IO String
hGetContents Handle
handle
        String -> IO String -> IO String
forall a b. NFData a => a -> b -> b
deepseq String
out (String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
out)


--------------------------------------------------------------------------------
-- | Variant of 'unixFilter' that should be used for binary files
--
-- > match "music.wav" $ do
-- >     route   $ setExtension "ogg"
-- >     compile $ getResourceLBS >>= withItemBody (unixFilterLBS "oggenc" ["-"])
unixFilterLBS :: String               -- ^ Program name
              -> [String]             -- ^ Program args
              -> ByteString           -- ^ Program input
              -> Compiler ByteString  -- ^ Program output
unixFilterLBS :: String -> [String] -> ByteString -> Compiler ByteString
unixFilterLBS = (Handle -> ByteString -> IO ())
-> (Handle -> IO ByteString)
-> String
-> [String]
-> ByteString
-> Compiler ByteString
forall o i.
Monoid o =>
(Handle -> i -> IO ())
-> (Handle -> IO o) -> String -> [String] -> i -> Compiler o
unixFilterWith Handle -> ByteString -> IO ()
LB.hPutStr ((Handle -> IO ByteString)
 -> String -> [String] -> ByteString -> Compiler ByteString)
-> (Handle -> IO ByteString)
-> String
-> [String]
-> ByteString
-> Compiler ByteString
forall a b. (a -> b) -> a -> b
$ \Handle
handle -> do
    ByteString
out <- Handle -> IO ByteString
LB.hGetContents Handle
handle
    ByteString -> Int64
LB.length ByteString
out Int64 -> IO ByteString -> IO ByteString
`seq` ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
out


--------------------------------------------------------------------------------
-- | Overloaded compiler
unixFilterWith :: Monoid o
               => (Handle -> i -> IO ())  -- ^ Writer
               -> (Handle -> IO o)        -- ^ Reader
               -> String                  -- ^ Program name
               -> [String]                -- ^ Program args
               -> i                       -- ^ Program input
               -> Compiler o              -- ^ Program output
unixFilterWith :: (Handle -> i -> IO ())
-> (Handle -> IO o) -> String -> [String] -> i -> Compiler o
unixFilterWith Handle -> i -> IO ()
writer Handle -> IO o
reader String
programName [String]
args i
input = do
    String -> Compiler ()
debugCompiler (String
"Executing external program " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
programName)
    (o
output, String
err, ExitCode
exitCode) <- IO (o, String, ExitCode) -> Compiler (o, String, ExitCode)
forall a. IO a -> Compiler a
unsafeCompiler (IO (o, String, ExitCode) -> Compiler (o, String, ExitCode))
-> IO (o, String, ExitCode) -> Compiler (o, String, ExitCode)
forall a b. (a -> b) -> a -> b
$
        (Handle -> i -> IO ())
-> (Handle -> IO o)
-> String
-> [String]
-> i
-> IO (o, String, ExitCode)
forall o i.
Monoid o =>
(Handle -> i -> IO ())
-> (Handle -> IO o)
-> String
-> [String]
-> i
-> IO (o, String, ExitCode)
unixFilterIO Handle -> i -> IO ()
writer Handle -> IO o
reader String
programName [String]
args i
input
    [String] -> (String -> Compiler ()) -> Compiler ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (String -> [String]
lines String
err) String -> Compiler ()
debugCompiler
    case ExitCode
exitCode of
        ExitCode
ExitSuccess   -> o -> Compiler o
forall (m :: * -> *) a. Monad m => a -> m a
return o
output
        ExitFailure Int
e -> String -> Compiler o
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Compiler o) -> String -> Compiler o
forall a b. (a -> b) -> a -> b
$
            String
"Hakyll.Core.UnixFilter.unixFilterWith: " String -> String -> String
forall a. [a] -> [a] -> [a]
++
            [String] -> String
unwords (String
programName String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
args) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" gave exit code " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
e String -> String -> String
forall a. [a] -> [a] -> [a]
++
            String
". (Error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"


--------------------------------------------------------------------------------
-- | Internally used function
unixFilterIO :: Monoid o
             => (Handle -> i -> IO ())
             -> (Handle -> IO o)
             -> String
             -> [String]
             -> i
             -> IO (o, String, ExitCode)
unixFilterIO :: (Handle -> i -> IO ())
-> (Handle -> IO o)
-> String
-> [String]
-> i
-> IO (o, String, ExitCode)
unixFilterIO Handle -> i -> IO ()
writer Handle -> IO o
reader String
programName [String]
args i
input = do
    -- The problem on Windows is that `proc` is unable to execute
    -- batch stubs (eg. anything created using 'gem install ...') even if its in
    -- `$PATH`. A solution to this issue is to execute the batch file explicitly
    -- using `cmd /c batchfile` but there is no rational way to know where said
    -- batchfile is on the system. Hence, we detect windows using the
    -- CPP and instead of using `proc` to create the process, use `shell`
    -- which will be able to execute everything `proc` can
    -- as well as batch files.
#ifdef mingw32_HOST_OS
    let pr = shell $ unwords (programName : args)
#else
    let pr :: CreateProcess
pr = String -> [String] -> CreateProcess
proc String
programName [String]
args
#endif

    (Just Handle
inh, Just Handle
outh, Just Handle
errh, ProcessHandle
pid) <-
        CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
pr
                { std_in :: StdStream
std_in  = StdStream
CreatePipe
                , std_out :: StdStream
std_out = StdStream
CreatePipe
                , std_err :: StdStream
std_err = StdStream
CreatePipe
                }

    -- Create boxes
    MVar ()
lock   <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
    IORef o
outRef <- o -> IO (IORef o)
forall a. a -> IO (IORef a)
newIORef o
forall a. Monoid a => a
mempty
    IORef String
errRef <- String -> IO (IORef String)
forall a. a -> IO (IORef a)
newIORef String
""

    -- Write the input to the child pipe
    ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Handle -> i -> IO ()
writer Handle
inh i
input IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
inh IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hClose Handle
inh

    -- Read from stdout
    ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
        o
out <- Handle -> IO o
reader Handle
outh
        Handle -> IO ()
hClose Handle
outh
        IORef o -> o -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef o
outRef o
out
        MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
lock ()

    -- Read from stderr
    ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
        Handle -> TextEncoding -> IO ()
hSetEncoding Handle
errh TextEncoding
localeEncoding
        String
err <- Handle -> IO String
hGetContents Handle
errh
        String
_   <- String -> IO String -> IO String
forall a b. NFData a => a -> b -> b
deepseq String
err (String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
err)
        Handle -> IO ()
hClose Handle
errh
        IORef String -> String -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef String
errRef String
err
        MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
lock ()

    -- Get exit code & return
    MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
lock
    MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
lock
    ExitCode
exitCode <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
pid
    o
out      <- IORef o -> IO o
forall a. IORef a -> IO a
readIORef IORef o
outRef
    String
err      <- IORef String -> IO String
forall a. IORef a -> IO a
readIORef IORef String
errRef
    (o, String, ExitCode) -> IO (o, String, ExitCode)
forall (m :: * -> *) a. Monad m => a -> m a
return (o
out, String
err, ExitCode
exitCode)