module Sos.Job
( Job(jobEvent, jobCommands)
, JobResult(..)
, ShellCommand
, newJob
, runJob
, restartJob
, unrestartJob
, shouldRestartJob
) where
import Sos.FileEvent
import Sos.Utils
import Control.Applicative
import Control.Concurrent.STM
import Control.Exception
import Control.Monad
import Data.List.NonEmpty (NonEmpty)
import Data.Monoid
import System.Exit
import System.Process
import Text.Printf
import qualified Data.List.NonEmpty as NonEmpty
type ShellCommand = String
data JobResult = JobSuccess | JobFailure
data Job = Job
{ jobEvent :: FileEvent
, jobCommands :: NonEmpty ShellCommand
, jobRestart :: TMVar ()
}
newJob :: FileEvent -> NonEmpty ShellCommand -> STM Job
newJob event cmds = do
tmvar <- newEmptyTMVar
pure (Job event cmds tmvar)
restartJob :: Job -> STM ()
restartJob job = void (tryPutTMVar (jobRestart job) ())
unrestartJob :: Job -> STM ()
unrestartJob = void . tryTakeTMVar . jobRestart
shouldRestartJob :: Job -> STM ()
shouldRestartJob = readTMVar . jobRestart
runJob :: Job -> IO JobResult
runJob (NonEmpty.toList . jobCommands -> cmds0) = go 1 cmds0
where
go :: Int -> [ShellCommand] -> IO JobResult
go _ [] = pure JobSuccess
go n (cmd:cmds) = do
putStrLn (magenta (printf "[%d/%d] " n (length cmds0)) <> cmd)
let acquire :: IO ProcessHandle
acquire = do
(_, _, _, ph) <- createProcess (shell cmd)
pure ph
try (bracket acquire terminateProcess waitForProcess) >>= \case
Left (ex :: SomeException) -> do
case fromException ex of
Just ThreadKilled ->
case length cmds0 of
1 -> putStrLn (yellow ("Restarting job: " ++ cmd))
_ -> do
let (xs, ys) = splitAt (n1) cmds0
putStrLn (yellow "Restarting job:")
mapM_ (putStrLn . yellow . printf "[✓] %s") xs
mapM_ (putStrLn . yellow . printf "[ ] %s") ys
_ -> putStrLn (red ("Exception: " ++ show ex))
pure JobFailure
Right ExitSuccess -> do
putStrLn (green "Success ✓")
go (n+1) cmds
Right (ExitFailure c) -> do
putStrLn (red (printf "Failure ✗ (%d)" c))
pure JobFailure