module Trigger
( run
) where
import Console
import qualified Control.Arrow as A
import qualified Control.Monad.Catch as C
import qualified Data.List as L
import qualified Data.Text as T
import Parser
import Protolude
import qualified System.Clock as C
import qualified System.FSNotify as FS
import qualified System.Process as P
import Watcher
data RunningProcess = RunningProcess
{ cmd :: Text
, processHandle :: P.ProcessHandle
}
type RunningProcesses = [RunningProcess]
run :: [Config] -> IO ()
run configs = do
runningState <- newMVar []
managers <- mapM (runConfig runningState) configs
putStrLn "Waiting..."
_ <- getLine
mapM_ FS.stopManager managers
runConfig :: MVar RunningProcesses -> Config -> IO FS.WatchManager
runConfig runningState config = do
modifyMVar_ runningState (initialStartProcesses config)
watch config (handleFileChange runningState config)
handleFileChange :: MVar RunningProcesses -> Config -> FilePath -> IO ()
handleFileChange runningState config file = do
printFileChanged file
modifyMVar_ runningState (restartProcesses config)
initialStartProcesses :: Config -> RunningProcesses -> IO RunningProcesses
initialStartProcesses Config {..} _ = mapM startProcess (concat _run)
restartProcesses :: Config -> RunningProcesses -> IO RunningProcesses
restartProcesses config runningProcesses = do
start <- C.getTime C.Monotonic
mapM_ terminate runningProcesses
processes <- attemptStart config
end <- C.getTime C.Monotonic
printCompleted start end
threadDelay 200000
return processes
attemptStart :: Config -> IO RunningProcesses
attemptStart Config {..} =
swallowErrors $ do
runTasks _tasks
mapM startProcess (concat _run)
where
swallowErrors :: IO RunningProcesses -> IO RunningProcesses
swallowErrors = C.handleAll (\_ -> return [])
runTasks :: Maybe [Text] -> IO ()
runTasks tasks = mapM_ runTask (concat tasks)
runTask :: Text -> IO ()
runTask cmd = do
printRunningTask cmd
exitCode <- P.system $ toS cmd
printTaskFinished exitCode
case exitCode of
ExitSuccess -> return ()
ExitFailure _ -> throwIO exitCode
startProcess :: RunConfig -> IO RunningProcess
startProcess RunConfig {..} = do
(_, _, _, processHandle) <- P.createProcess_ (toS _command) $ process _workingDir _env _command
printStartingRunTask _command
return $ RunningProcess _command processHandle
terminate :: RunningProcess -> IO ()
terminate RunningProcess {..} = do
printTerminatingRunTask cmd
exit <- P.getProcessExitCode processHandle
case exit of
Nothing -> do
P.terminateProcess processHandle
exitCode <- P.waitForProcess processHandle
printTerminated cmd exitCode
Just exitCode -> printAlreadyTerminated cmd exitCode
process :: Maybe Text -> Maybe [(Text, Text)] -> Text -> P.CreateProcess
process workingDir env command =
P.CreateProcess
{ cmdspec = splitCommand command
, cwd = map toS workingDir
, env = map (map (toS A.*** toS)) env
, std_in = P.Inherit
, std_out = P.Inherit
, std_err = P.Inherit
, close_fds = False
, create_group = False
, delegate_ctlc = False
, detach_console = False
, create_new_console = False
, new_session = False
, child_group = Nothing
, child_user = Nothing
, use_process_jobs = True
}
splitCommand :: Text -> P.CmdSpec
splitCommand command =
let cmdAndArgs = T.words command
cmd = fromMaybe T.empty (head cmdAndArgs)
args = L.tail cmdAndArgs
in P.RawCommand (toS cmd) (map toS args)