{-# 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 = 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
        forall a b. NFData a => a -> b -> b
deepseq String
out (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 = forall o i.
Monoid o =>
(Handle -> i -> IO ())
-> (Handle -> IO o) -> String -> [String] -> i -> Compiler o
unixFilterWith Handle -> ByteString -> IO ()
LB.hPutStr 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 seq :: forall a b. a -> b -> b
`seq` 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 :: forall o i.
Monoid o =>
(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 " forall a. [a] -> [a] -> [a]
++ String
programName)
    (o
output, String
err, ExitCode
exitCode) <- forall a. IO a -> Compiler a
unsafeCompiler forall a b. (a -> b) -> a -> b
$
        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
    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   -> forall (m :: * -> *) a. Monad m => a -> m a
return o
output
        ExitFailure Int
e -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
            String
"Hakyll.Core.UnixFilter.unixFilterWith: " forall a. [a] -> [a] -> [a]
++
            [String] -> String
unwords (String
programName forall a. a -> [a] -> [a]
: [String]
args) forall a. [a] -> [a] -> [a]
++ String
" gave exit code " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
e forall a. [a] -> [a] -> [a]
++
            String
". (Error: " forall a. [a] -> [a] -> [a]
++ String
err 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 :: 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 = 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   <- forall a. IO (MVar a)
newEmptyMVar
    IORef o
outRef <- forall a. a -> IO (IORef a)
newIORef forall a. Monoid a => a
mempty
    IORef String
errRef <- forall a. a -> IO (IORef a)
newIORef String
""

    -- Write the input to the child pipe
    ThreadId
_ <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ Handle -> i -> IO ()
writer Handle
inh i
input forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
inh 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 forall a b. (a -> b) -> a -> b
$ do
        o
out <- Handle -> IO o
reader Handle
outh
        Handle -> IO ()
hClose Handle
outh
        forall a. IORef a -> a -> IO ()
writeIORef IORef o
outRef o
out
        forall a. MVar a -> a -> IO ()
putMVar MVar ()
lock ()

    -- Read from stderr
    ThreadId
_ <- IO () -> IO ThreadId
forkIO 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
_   <- forall a b. NFData a => a -> b -> b
deepseq String
err (forall (m :: * -> *) a. Monad m => a -> m a
return String
err)
        Handle -> IO ()
hClose Handle
errh
        forall a. IORef a -> a -> IO ()
writeIORef IORef String
errRef String
err
        forall a. MVar a -> a -> IO ()
putMVar MVar ()
lock ()

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