module Network.JobQueue.Action (
JobActionState
, runActionState
, runAction
, getEnv
, next
, orNext
, fin
, none
, fork
, forkInTime
, forkOnTime
, abort
, commitIO
, liftIO
, yield
) where
import Control.Applicative
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State
import Control.Exception (SomeException(..), toException)
import Control.Exception.Base (PatternMatchFail(..))
import Control.Monad.Logger (runLoggingT)
import Control.Exception.Lifted (catch)
import Control.Monad.Base ()
import Data.Maybe
import Data.Time.Clock
import Data.Default (Default, def)
import Network.JobQueue.Class
import Network.JobQueue.AuxClass
import Network.JobQueue.Types
import Network.JobQueue.Logger
runActionState :: (Env e, Unit a) => JobActionState e a -> ActionFn e a
runActionState (JobActionState { jobActions = actions } ) env ju = runActionState' actions
where
runActionState' actions' = case actions' of
[] -> return $ Right Nothing
(act:acts) -> do
r <- act env ju
case r of
Right Nothing -> runActionState' acts
_ -> return r
runAction :: (Aux e, Env e, Unit a) =>
e -> a -> ActionT e a IO () -> IO (Either Break (Maybe (RuntimeState a)))
runAction env ju action = do
(e,r) <- flip runLoggingT (auxLogger env)
$ flip runStateT Nothing
$ flip runReaderT (ActionEnv env ju)
$ runExceptT
$ runAM $ do
when (toBeLogged ju) $ $(logWarn) "{}" [desc ju]
action `catch` handlePatternMatchFail `catch` handleSome
return $ either Left (const $ Right r) e
handlePatternMatchFail :: (Aux e, Env e, Unit a) => PatternMatchFail -> ActionT e a IO ()
handlePatternMatchFail e = do
s <- get
if getCommits (fromMaybe def s) > 0
then do
ju <- getJobUnit <$> ask
$(logError) "pattern match fail: ! ({})" [desc ju]
throwError $ Unhandled (toException e)
else none
handleSome :: (Aux e, Env e, Unit a) => SomeException -> ActionT e a IO b
handleSome e = do
$(logError) "unhandled exception: {}" [show e]
throwError $ Unhandled e
getEnv :: (Env e, Unit a) => ActionM e a e
getEnv = getJobEnv <$> ask
commitIO :: (Env e, Unit a) => IO b -> ActionM e a b
commitIO action = do
do s <- get
when (getCommits (fromMaybe def s) > 0) $ do
ju <- getJobUnit <$> ask
$(logWarn) "commitIO called twice! ({})" [desc ju]
modify $ \s -> Just $ incrementCommits $ fromMaybe def s
liftIO action
yield :: (Env e, Unit a) => ActionM e a ()
yield = do
ju <- getJobUnit <$> ask
forkWith ju Nothing
fork :: (Env e, Unit a)
=> a
-> ActionM e a ()
fork ju = forkWith ju Nothing
forkOnTime :: (Env e, Unit a)
=> UTCTime
-> a
-> ActionM e a ()
forkOnTime t ju = forkWith ju (Just t)
forkInTime :: (Env e, Unit a) => NominalDiffTime -> a -> ActionM e a ()
forkInTime tDiff ju = do
currentTime <- liftIO $ getCurrentTime
forkWith ju (Just (addUTCTime tDiff currentTime))
next :: (Env e, Unit a)
=> a
-> ActionM e a ()
next ju = modify $ \s -> Just $ setNextJob ju $ fromMaybe def s
orNext :: (Env e, Unit a)
=> a
-> ActionM e a ()
orNext ju = modify $ \s -> Just $ setNextJobIfEmpty ju $ fromMaybe def s
fin :: (Env e, Unit a) => ActionM e a ()
fin = modify $ \s -> Just $ emptyNextJob $ fromMaybe def s
none :: (Env e, Unit a) => ActionM e a ()
none = result Nothing
abort :: (Env e, Unit a) => ActionM e a b
abort = do
ju <- getJobUnit <$> ask
throwError $ Failure ("aborted on " ++ desc ju)
result :: (Env e, Unit a) => Maybe (RuntimeState a) -> ActionM e a ()
result = modify . setResult
forkWith :: (Env e, Unit a) => a -> Maybe UTCTime -> ActionM e a ()
forkWith ju mt = modify $ \s -> Just $ addForkJob (ju, mt) $ fromMaybe def s