module Happstack.Util.AutoBuild (
autoBuild
) where
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)
import Control.Exception (bracket)
import System.Directory (getModificationTime)
import System.Exit (ExitCode(..), exitFailure)
import System.Process
import System.Time (ClockTime)
import System.IO
autoBuild :: String
-> String
-> [String]
-> IO ()
autoBuild buildCmd binPath binArgs = do
putStrLn "Performing the initial build. . ."
buildSuccess <- buildBin buildCmd
if buildSuccess
then do
mph <- newEmptyMVar
newMod <- getModificationTime binPath
forkIO (builder mph buildCmd binPath newMod)
runner mph binPath binArgs
else do
putStrLn "Initial build failed, see 'build.out.log' and 'build.err.log'."
exitFailure
builder :: MVar ProcessHandle -> String -> FilePath -> ClockTime -> IO ()
builder mph buildCmd binPath lastMod = do
threadDelay 5000000
buildSuccess <- buildBin buildCmd
newMod <- getModificationTime binPath
if buildSuccess && (newMod /= lastMod)
then do
putStrLn "A new binary has been built, killing the existing one. . ."
terminateProcess =<< takeMVar mph
else return ()
builder mph buildCmd binPath newMod
runner :: MVar ProcessHandle -> FilePath -> [String] -> IO ()
runner mph binPath binArgs = do
bracket
(runBin binPath binArgs)
(terminateProcess)
(\ph -> putMVar mph ph >> waitForProcess ph)
runner mph binPath binArgs
runBin :: String -> [String] -> IO ProcessHandle
runBin binPath binArgs = do
putStrLn $ "Running binary: " ++ (showCmd binPath binArgs)
ph <- runProcess binPath binArgs Nothing Nothing Nothing Nothing Nothing
return ph
where showCmd bp [] = bp
showCmd bp ba = bp ++ " " ++ unwords ba
buildBin :: String -> IO Bool
buildBin buildCmd = do
(_inp,out,err,ph) <- runInteractiveCommand buildCmd
appendFile "build.out.log" =<< hGetContents out
appendFile "build.err.log" =<< hGetContents err
waitForProcess ph
exitCode <- getProcessExitCode ph
return (exitCode == Just ExitSuccess)