{-# 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
        out <- Handle -> IO String
hGetContents Handle
handle
        deepseq out (return 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
    out <- Handle -> IO ByteString
LB.hGetContents Handle
handle
    LB.length out `seq` return 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 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
programName)
    (output, err, 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
    forM_ (lines err) debugCompiler
    case exitCode of
        ExitCode
ExitSuccess   -> o -> Compiler o
forall a. a -> Compiler a
forall (m :: * -> *) a. Monad m => a -> m a
return o
output
        ExitFailure Int
e -> String -> Compiler o
forall a. String -> Compiler a
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 :: 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 inh, Just outh, Just errh, pid) <-
        CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
pr
                { std_in  = CreatePipe
                , std_out = CreatePipe
                , std_err = CreatePipe
                }

    -- Create boxes
    lock   <- newEmptyMVar
    outRef <- newIORef mempty
    errRef <- newIORef ""

    -- Write the input to the child pipe
    _ <- forkIO $ writer inh input >> hFlush inh >> hClose inh

    -- Read from stdout
    _ <- forkIO $ do
        out <- reader outh
        hClose outh
        writeIORef outRef out
        putMVar lock ()

    -- Read from stderr
    _ <- forkIO $ do
        hSetEncoding errh localeEncoding
        err <- hGetContents errh
        _   <- deepseq err (return err)
        hClose errh
        writeIORef errRef err
        putMVar lock ()

    -- Get exit code & return
    takeMVar lock
    takeMVar lock
    exitCode <- waitForProcess pid
    out      <- readIORef outRef
    err      <- readIORef errRef
    return (out, err, exitCode)