{-# LANGUAGE OverloadedStrings #-}
-- |
-- How to use:
--
-- > import Control.Watchdog
-- > import Data.Time
-- >
-- > errorProneTask :: IO (Either String ())
-- > errorProneTask = do
-- >     getCurrentTime >>= print
-- >     return $ Left "some error"
-- >
-- > main = watchdog $ watch errorProneTask
--
-- Result:
--
-- @
-- 2012-07-09 21:48:19.592252 UTC
-- Watchdog: Error executing task (some error) - waiting 1s before trying again.
-- 2012-07-09 21:48:20.594381 UTC
-- Watchdog: Error executing task (some error) - waiting 2s before trying again.
-- 2012-07-09 21:48:22.597069 UTC
-- Watchdog: Error executing task (some error) - waiting 4s before trying again.
-- ...
-- @
--
-- Alternatively the watchdog can stop after a certain number of attempts:
--
-- > import Control.Watchdog
-- > import Data.Time
-- >
-- > errorProneTask :: IO (Either String ())
-- > errorProneTask = do
-- >     getCurrentTime >>= print
-- >     return $ Left "some error"
-- >
-- > main = do
-- >     result <- watchdog $ do
-- >         setMaximumRetries 2
-- >         watchImpatiently errorProneTask
-- >     print result
--
-- Result:
--
-- @
-- 2012-07-09 21:55:41.046432 UTC
-- Watchdog: Error executing task (some error) - waiting 1s before trying again.
-- 2012-07-09 21:55:42.047246 UTC
-- Watchdog: Error executing task (some error) - waiting 2s before trying again.
-- 2012-07-09 21:55:44.049993 UTC
-- Left \"some error\"
-- @
--
-- The watchdog will execute the task and check the return value, which should
-- be an 'Either' value where 'Left' signals an error and 'Right' signals success.
--
-- The watchdog will backoff exponentially (up to a maximum delay) in case of
-- persisting errors, but will reset after the task has been running for a while
-- without problems (see 'setResetDuration') and start a new cycle of
-- exponential backoff should new errors arise.
--
-- The module is intended to be used in different watchdog settings. For example
-- to keep an eye on a server process (use 'watch' and only return a succesful
-- result when the server is doing a clean shutdown) or to retry an action
-- multiple times, if necessary, before giving up (use 'watchImpatiently').  A
-- monadic approach is used to modify the various settings. Below is a code
-- sample with all possible configuration options and their default values:
--
-- > import Control.Watchdog
-- > import Data.Time
-- >
-- > errorProneTask :: IO (Either String ())
-- > errorProneTask = do
-- >     getCurrentTime >>= print
-- >     return $ Left "some error"
-- >
-- > main = watchdog $ do
-- >         setInitialDelay $ 1 * 10^6      -- 1 second
-- >         setMaximumDelay $ 300 * 10^6    -- 300 seconds
-- >         setMaximumRetries 10            -- has no effect when using 'watch'
-- >         setResetDuration $ 30 * 10^6    -- 30 seconds
-- >         setLoggingAction defaultLogger
-- >         watch errorProneTask
--

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Control.Watchdog
    ( watchdog
    , watchdogBlank
    , watch
    , watchImpatiently
    , setInitialDelay
    , setMaximumDelay
    , setMaximumRetries
    , setResetDuration
    , setLoggingAction
    , defaultLogger
    , showLogger
    , silentLogger
    , formatWatchdogError
    , WatchdogLogger
    , WatchdogAction
    ) where

import Control.Applicative
import Control.Concurrent
import Control.Monad.State.Strict
import Data.Semigroup             (Semigroup, (<>))
import Data.String                (IsString, fromString)
import Data.Time

data WatchdogState e = WatchdogState { WatchdogState e -> Int
wcInitialDelay   :: Int
                                     , WatchdogState e -> Int
wcMaximumDelay   :: Int
                                     , WatchdogState e -> Int
wcResetDuration  :: Int
                                     , WatchdogState e -> Integer
wcMaximumRetries :: Integer
                                     , WatchdogState e -> WatchdogLogger e
wcLoggingAction  :: WatchdogLogger e
                                     }

data WatchdogTaskStatus e a = FailedImmediately e
                            | FailedAfterAWhile e
                            | CompletedSuccessfully a

newtype WatchdogAction e a = WA { WatchdogAction e a -> StateT (WatchdogState e) IO a
runWA :: StateT (WatchdogState e) IO a }
                             deriving ( a -> WatchdogAction e b -> WatchdogAction e a
(a -> b) -> WatchdogAction e a -> WatchdogAction e b
(forall a b. (a -> b) -> WatchdogAction e a -> WatchdogAction e b)
-> (forall a b. a -> WatchdogAction e b -> WatchdogAction e a)
-> Functor (WatchdogAction e)
forall a b. a -> WatchdogAction e b -> WatchdogAction e a
forall a b. (a -> b) -> WatchdogAction e a -> WatchdogAction e b
forall e a b. a -> WatchdogAction e b -> WatchdogAction e a
forall e a b. (a -> b) -> WatchdogAction e a -> WatchdogAction e b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> WatchdogAction e b -> WatchdogAction e a
$c<$ :: forall e a b. a -> WatchdogAction e b -> WatchdogAction e a
fmap :: (a -> b) -> WatchdogAction e a -> WatchdogAction e b
$cfmap :: forall e a b. (a -> b) -> WatchdogAction e a -> WatchdogAction e b
Functor, Functor (WatchdogAction e)
a -> WatchdogAction e a
Functor (WatchdogAction e)
-> (forall a. a -> WatchdogAction e a)
-> (forall a b.
    WatchdogAction e (a -> b)
    -> WatchdogAction e a -> WatchdogAction e b)
-> (forall a b c.
    (a -> b -> c)
    -> WatchdogAction e a -> WatchdogAction e b -> WatchdogAction e c)
-> (forall a b.
    WatchdogAction e a -> WatchdogAction e b -> WatchdogAction e b)
-> (forall a b.
    WatchdogAction e a -> WatchdogAction e b -> WatchdogAction e a)
-> Applicative (WatchdogAction e)
WatchdogAction e a -> WatchdogAction e b -> WatchdogAction e b
WatchdogAction e a -> WatchdogAction e b -> WatchdogAction e a
WatchdogAction e (a -> b)
-> WatchdogAction e a -> WatchdogAction e b
(a -> b -> c)
-> WatchdogAction e a -> WatchdogAction e b -> WatchdogAction e c
forall e. Functor (WatchdogAction e)
forall a. a -> WatchdogAction e a
forall e a. a -> WatchdogAction e a
forall a b.
WatchdogAction e a -> WatchdogAction e b -> WatchdogAction e a
forall a b.
WatchdogAction e a -> WatchdogAction e b -> WatchdogAction e b
forall a b.
WatchdogAction e (a -> b)
-> WatchdogAction e a -> WatchdogAction e b
forall e a b.
WatchdogAction e a -> WatchdogAction e b -> WatchdogAction e a
forall e a b.
WatchdogAction e a -> WatchdogAction e b -> WatchdogAction e b
forall e a b.
WatchdogAction e (a -> b)
-> WatchdogAction e a -> WatchdogAction e b
forall a b c.
(a -> b -> c)
-> WatchdogAction e a -> WatchdogAction e b -> WatchdogAction e c
forall e a b c.
(a -> b -> c)
-> WatchdogAction e a -> WatchdogAction e b -> WatchdogAction e c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: WatchdogAction e a -> WatchdogAction e b -> WatchdogAction e a
$c<* :: forall e a b.
WatchdogAction e a -> WatchdogAction e b -> WatchdogAction e a
*> :: WatchdogAction e a -> WatchdogAction e b -> WatchdogAction e b
$c*> :: forall e a b.
WatchdogAction e a -> WatchdogAction e b -> WatchdogAction e b
liftA2 :: (a -> b -> c)
-> WatchdogAction e a -> WatchdogAction e b -> WatchdogAction e c
$cliftA2 :: forall e a b c.
(a -> b -> c)
-> WatchdogAction e a -> WatchdogAction e b -> WatchdogAction e c
<*> :: WatchdogAction e (a -> b)
-> WatchdogAction e a -> WatchdogAction e b
$c<*> :: forall e a b.
WatchdogAction e (a -> b)
-> WatchdogAction e a -> WatchdogAction e b
pure :: a -> WatchdogAction e a
$cpure :: forall e a. a -> WatchdogAction e a
$cp1Applicative :: forall e. Functor (WatchdogAction e)
Applicative, Applicative (WatchdogAction e)
WatchdogAction e a
Applicative (WatchdogAction e)
-> (forall a. WatchdogAction e a)
-> (forall a.
    WatchdogAction e a -> WatchdogAction e a -> WatchdogAction e a)
-> (forall a. WatchdogAction e a -> WatchdogAction e [a])
-> (forall a. WatchdogAction e a -> WatchdogAction e [a])
-> Alternative (WatchdogAction e)
WatchdogAction e a -> WatchdogAction e a -> WatchdogAction e a
WatchdogAction e a -> WatchdogAction e [a]
WatchdogAction e a -> WatchdogAction e [a]
forall e. Applicative (WatchdogAction e)
forall a. WatchdogAction e a
forall a. WatchdogAction e a -> WatchdogAction e [a]
forall a.
WatchdogAction e a -> WatchdogAction e a -> WatchdogAction e a
forall e a. WatchdogAction e a
forall e a. WatchdogAction e a -> WatchdogAction e [a]
forall e a.
WatchdogAction e a -> WatchdogAction e a -> WatchdogAction e a
forall (f :: * -> *).
Applicative f
-> (forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
many :: WatchdogAction e a -> WatchdogAction e [a]
$cmany :: forall e a. WatchdogAction e a -> WatchdogAction e [a]
some :: WatchdogAction e a -> WatchdogAction e [a]
$csome :: forall e a. WatchdogAction e a -> WatchdogAction e [a]
<|> :: WatchdogAction e a -> WatchdogAction e a -> WatchdogAction e a
$c<|> :: forall e a.
WatchdogAction e a -> WatchdogAction e a -> WatchdogAction e a
empty :: WatchdogAction e a
$cempty :: forall e a. WatchdogAction e a
$cp1Alternative :: forall e. Applicative (WatchdogAction e)
Alternative
                                      , Applicative (WatchdogAction e)
a -> WatchdogAction e a
Applicative (WatchdogAction e)
-> (forall a b.
    WatchdogAction e a
    -> (a -> WatchdogAction e b) -> WatchdogAction e b)
-> (forall a b.
    WatchdogAction e a -> WatchdogAction e b -> WatchdogAction e b)
-> (forall a. a -> WatchdogAction e a)
-> Monad (WatchdogAction e)
WatchdogAction e a
-> (a -> WatchdogAction e b) -> WatchdogAction e b
WatchdogAction e a -> WatchdogAction e b -> WatchdogAction e b
forall e. Applicative (WatchdogAction e)
forall a. a -> WatchdogAction e a
forall e a. a -> WatchdogAction e a
forall a b.
WatchdogAction e a -> WatchdogAction e b -> WatchdogAction e b
forall a b.
WatchdogAction e a
-> (a -> WatchdogAction e b) -> WatchdogAction e b
forall e a b.
WatchdogAction e a -> WatchdogAction e b -> WatchdogAction e b
forall e a b.
WatchdogAction e a
-> (a -> WatchdogAction e b) -> WatchdogAction e b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> WatchdogAction e a
$creturn :: forall e a. a -> WatchdogAction e a
>> :: WatchdogAction e a -> WatchdogAction e b -> WatchdogAction e b
$c>> :: forall e a b.
WatchdogAction e a -> WatchdogAction e b -> WatchdogAction e b
>>= :: WatchdogAction e a
-> (a -> WatchdogAction e b) -> WatchdogAction e b
$c>>= :: forall e a b.
WatchdogAction e a
-> (a -> WatchdogAction e b) -> WatchdogAction e b
$cp1Monad :: forall e. Applicative (WatchdogAction e)
Monad, Monad (WatchdogAction e)
Monad (WatchdogAction e)
-> (forall a. IO a -> WatchdogAction e a)
-> MonadIO (WatchdogAction e)
IO a -> WatchdogAction e a
forall e. Monad (WatchdogAction e)
forall a. IO a -> WatchdogAction e a
forall e a. IO a -> WatchdogAction e a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> WatchdogAction e a
$cliftIO :: forall e a. IO a -> WatchdogAction e a
$cp1MonadIO :: forall e. Monad (WatchdogAction e)
MonadIO, MonadState (WatchdogState e))

-- | Type synonym for a watchdog logger.
type WatchdogLogger e = e          -- ^ Error value returned by the task.
                      -> Maybe Int -- ^ Waiting time - if any - before trying again.
                      -> IO ()

defaultConf :: WatchdogState String
defaultConf :: WatchdogState String
defaultConf = WatchdogState Any
forall e. WatchdogState e
blankConf { wcLoggingAction :: WatchdogLogger String
wcLoggingAction = WatchdogLogger String
defaultLogger }

blankConf :: WatchdogState e
blankConf :: WatchdogState e
blankConf = WatchdogState :: forall e.
Int -> Int -> Int -> Integer -> WatchdogLogger e -> WatchdogState e
WatchdogState { wcInitialDelay :: Int
wcInitialDelay   = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10 Int -> Integer -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ (Integer
6::Integer)
                          , wcMaximumDelay :: Int
wcMaximumDelay   = Int
300 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10 Int -> Integer -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ (Integer
6::Integer)
                          , wcMaximumRetries :: Integer
wcMaximumRetries = Integer
10
                          , wcResetDuration :: Int
wcResetDuration  = Int
30 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10 Int -> Integer -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ (Integer
6::Integer)
                          , wcLoggingAction :: WatchdogLogger e
wcLoggingAction  = WatchdogLogger e
forall e. WatchdogLogger e
silentLogger
                          }

-- | The Watchdog monad. Used to configure and eventually run a watchdog.
watchdog :: WatchdogAction String a -> IO a
watchdog :: WatchdogAction String a -> IO a
watchdog = WatchdogState String -> WatchdogAction String a -> IO a
forall e a. WatchdogState e -> WatchdogAction e a -> IO a
watchdogWith WatchdogState String
defaultConf

-- | As with 'watchdog', but don't specify a default logging action to
--   allow it to be polymorphic.
watchdogBlank :: WatchdogAction e a -> IO a
watchdogBlank :: WatchdogAction e a -> IO a
watchdogBlank = WatchdogState e -> WatchdogAction e a -> IO a
forall e a. WatchdogState e -> WatchdogAction e a -> IO a
watchdogWith WatchdogState e
forall e. WatchdogState e
blankConf

watchdogWith :: WatchdogState e -> WatchdogAction e a -> IO a
watchdogWith :: WatchdogState e -> WatchdogAction e a -> IO a
watchdogWith WatchdogState e
conf WatchdogAction e a
action = StateT (WatchdogState e) IO a -> WatchdogState e -> IO a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (WatchdogAction e a -> StateT (WatchdogState e) IO a
forall e a. WatchdogAction e a -> StateT (WatchdogState e) IO a
runWA WatchdogAction e a
action) WatchdogState e
conf

-- | Set the initial delay in microseconds. The first time the watchdog pauses
-- will be for this amount of time. The default is 1 second.
setInitialDelay :: Int -> WatchdogAction e ()
setInitialDelay :: Int -> WatchdogAction e ()
setInitialDelay Int
delay = (WatchdogState e -> WatchdogState e) -> WatchdogAction e ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\WatchdogState e
conf -> WatchdogState e
conf { wcInitialDelay :: Int
wcInitialDelay = Int
delay })

-- | Set the maximum delay in microseconds. When a task fails to execute
-- properly multiple times in quick succession, the delay is doubled each time
-- until it stays constant at the maximum delay. The default is 300 seconds.
setMaximumDelay :: Int -> WatchdogAction e ()
setMaximumDelay :: Int -> WatchdogAction e ()
setMaximumDelay Int
delay = (WatchdogState e -> WatchdogState e) -> WatchdogAction e ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\WatchdogState e
conf -> WatchdogState e
conf { wcMaximumDelay :: Int
wcMaximumDelay = Int
delay })

-- | If a task has been running for some time, the watchdog will consider
-- the next failure to be something unrelated and reset the waiting time
-- back to the initial delay. This function sets the amount of time in
-- microseconds that needs to pass before the watchdog will consider a task to
-- be successfully running. The default is 30 seconds.
setResetDuration :: Int -> WatchdogAction e ()
setResetDuration :: Int -> WatchdogAction e ()
setResetDuration Int
duration = (WatchdogState e -> WatchdogState e) -> WatchdogAction e ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\WatchdogState e
conf -> WatchdogState e
conf { wcResetDuration :: Int
wcResetDuration = Int
duration })

-- | Set the number of retries after which the watchdog will give up and
-- return with a permanent error. This setting is only used in combination with
-- 'watchImpatiently'. The default is 10.
setMaximumRetries :: Integer -> WatchdogAction e ()
setMaximumRetries :: Integer -> WatchdogAction e ()
setMaximumRetries Integer
retries = (WatchdogState e -> WatchdogState e) -> WatchdogAction e ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\WatchdogState e
conf -> WatchdogState e
conf { wcMaximumRetries :: Integer
wcMaximumRetries = Integer
retries })

-- | Set the logging action that will be called by the watchdog. The supplied
-- function of type 'WatchdogLogger' will be provided with the error message of
-- the task and either 'Nothing' if the watchdog will retry immediately or 'Just
-- delay' if the watchdog will now pause for the specified amount of time before
-- trying again.  The default is 'defaultLogger'.
setLoggingAction :: WatchdogLogger e -> WatchdogAction e ()
setLoggingAction :: WatchdogLogger e -> WatchdogAction e ()
setLoggingAction WatchdogLogger e
f = (WatchdogState e -> WatchdogState e) -> WatchdogAction e ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\WatchdogState e
conf -> WatchdogState e
conf { wcLoggingAction :: WatchdogLogger e
wcLoggingAction = WatchdogLogger e
f })

-- | Watch a task, restarting it potentially forever or until it returns with a
-- result. The task should return an 'Either', where 'Left' in combination with
-- an error message signals an error and 'Right' with an arbitrary result
-- signals success.
watch :: IO (Either e a) -> WatchdogAction e a
watch :: IO (Either e a) -> WatchdogAction e a
watch IO (Either e a)
task = do
    WatchdogState e
conf <- WatchdogAction e (WatchdogState e)
forall s (m :: * -> *). MonadState s m => m s
get
    IO a -> WatchdogAction e a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> WatchdogAction e a) -> IO a -> WatchdogAction e a
forall a b. (a -> b) -> a -> b
$ WatchdogState e -> Int -> IO a
go WatchdogState e
conf (WatchdogState e -> Int
forall e. WatchdogState e -> Int
wcInitialDelay WatchdogState e
conf)
  where
    go :: WatchdogState e -> Int -> IO a
go WatchdogState e
conf Int
errorDelay = do
        WatchdogTaskStatus e a
status <- Int -> IO (Either e a) -> IO (WatchdogTaskStatus e a)
forall e a. Int -> IO (Either e a) -> IO (WatchdogTaskStatus e a)
timeTask (WatchdogState e -> Int
forall e. WatchdogState e -> Int
wcResetDuration WatchdogState e
conf) IO (Either e a)
task
        case WatchdogTaskStatus e a
status of
            CompletedSuccessfully a
result -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result
            FailedAfterAWhile e
err -> do
                let errorDelay' :: Int
errorDelay' = WatchdogState e -> Int
forall e. WatchdogState e -> Int
wcInitialDelay WatchdogState e
conf
                    loggingAction :: WatchdogLogger e
loggingAction = WatchdogState e -> WatchdogLogger e
forall e. WatchdogState e -> WatchdogLogger e
wcLoggingAction WatchdogState e
conf
                WatchdogLogger e
loggingAction e
err Maybe Int
forall a. Maybe a
Nothing -- log that we will retry immediately
                WatchdogState e -> Int -> IO a
go WatchdogState e
conf Int
errorDelay'
            FailedImmediately e
err -> do
                let errorDelay' :: Int
errorDelay' =
                        Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
errorDelay Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2) (WatchdogState e -> Int
forall e. WatchdogState e -> Int
wcMaximumDelay WatchdogState e
conf)
                    loggingAction :: WatchdogLogger e
loggingAction = WatchdogState e -> WatchdogLogger e
forall e. WatchdogState e -> WatchdogLogger e
wcLoggingAction WatchdogState e
conf
                WatchdogLogger e
loggingAction e
err (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
errorDelay) -- log that we will
                                                    -- retry after a delay
                Int -> IO ()
threadDelay Int
errorDelay
                WatchdogState e -> Int -> IO a
go WatchdogState e
conf Int
errorDelay'

-- | Watch a task, but only restart it a limited number of times (see
-- 'setMaximumRetries'). If the failure persists, it will be returned as a 'Left',
-- otherwise it will be 'Right' with the result of the task.
watchImpatiently :: IO (Either e b) -> WatchdogAction e (Either e b)
watchImpatiently :: IO (Either e b) -> WatchdogAction e (Either e b)
watchImpatiently IO (Either e b)
task = do
    WatchdogState e
conf <- WatchdogAction e (WatchdogState e)
forall s (m :: * -> *). MonadState s m => m s
get
    IO (Either e b) -> WatchdogAction e (Either e b)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either e b) -> WatchdogAction e (Either e b))
-> IO (Either e b) -> WatchdogAction e (Either e b)
forall a b. (a -> b) -> a -> b
$ WatchdogState e -> Integer -> Int -> IO (Either e b)
go WatchdogState e
conf Integer
0 (WatchdogState e -> Int
forall e. WatchdogState e -> Int
wcInitialDelay WatchdogState e
conf)
  where
    go :: WatchdogState e -> Integer -> Int -> IO (Either e b)
go WatchdogState e
conf Integer
retries Int
errorDelay = do
        WatchdogTaskStatus e b
status <- Int -> IO (Either e b) -> IO (WatchdogTaskStatus e b)
forall e a. Int -> IO (Either e a) -> IO (WatchdogTaskStatus e a)
timeTask (WatchdogState e -> Int
forall e. WatchdogState e -> Int
wcResetDuration WatchdogState e
conf) IO (Either e b)
task
        case WatchdogTaskStatus e b
status of
            CompletedSuccessfully b
result -> Either e b -> IO (Either e b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either e b -> IO (Either e b)) -> Either e b -> IO (Either e b)
forall a b. (a -> b) -> a -> b
$ b -> Either e b
forall a b. b -> Either a b
Right b
result
            FailedAfterAWhile e
err ->
                if Integer
retries Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= WatchdogState e -> Integer
forall e. WatchdogState e -> Integer
wcMaximumRetries WatchdogState e
conf
                    then Either e b -> IO (Either e b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either e b -> IO (Either e b)) -> Either e b -> IO (Either e b)
forall a b. (a -> b) -> a -> b
$ e -> Either e b
forall a b. a -> Either a b
Left e
err
                    else do
                        let errorDelay' :: Int
errorDelay' = WatchdogState e -> Int
forall e. WatchdogState e -> Int
wcInitialDelay WatchdogState e
conf
                            loggingAction :: WatchdogLogger e
loggingAction = WatchdogState e -> WatchdogLogger e
forall e. WatchdogState e -> WatchdogLogger e
wcLoggingAction WatchdogState e
conf
                        WatchdogLogger e
loggingAction e
err Maybe Int
forall a. Maybe a
Nothing
                        WatchdogState e -> Integer -> Int -> IO (Either e b)
go WatchdogState e
conf (Integer
retries Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) Int
errorDelay'
            FailedImmediately e
err ->
                if Integer
retries Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= WatchdogState e -> Integer
forall e. WatchdogState e -> Integer
wcMaximumRetries WatchdogState e
conf
                    then Either e b -> IO (Either e b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either e b -> IO (Either e b)) -> Either e b -> IO (Either e b)
forall a b. (a -> b) -> a -> b
$ e -> Either e b
forall a b. a -> Either a b
Left e
err
                    else do
                        let errorDelay' :: Int
errorDelay' =
                                Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
errorDelay Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2) (WatchdogState e -> Int
forall e. WatchdogState e -> Int
wcMaximumDelay WatchdogState e
conf)
                            loggingAction :: WatchdogLogger e
loggingAction = WatchdogState e -> WatchdogLogger e
forall e. WatchdogState e -> WatchdogLogger e
wcLoggingAction WatchdogState e
conf
                        WatchdogLogger e
loggingAction e
err (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
errorDelay)
                        Int -> IO ()
threadDelay Int
errorDelay
                        WatchdogState e -> Integer -> Int -> IO (Either e b)
go WatchdogState e
conf (Integer
retries Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) Int
errorDelay'

-- | The default logging action. It will call 'formatWatchdogError' and display
-- the result on STDOUT.
defaultLogger :: WatchdogLogger String
defaultLogger :: WatchdogLogger String
defaultLogger String
taskErr Maybe Int
delay = String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Maybe Int -> String
forall str.
(IsString str, Semigroup str) =>
str -> Maybe Int -> str
formatWatchdogError String
taskErr Maybe Int
delay

-- | As with 'defaultLogger', but calls 'show' on the value provided.
showLogger :: (Show e) => WatchdogLogger e
showLogger :: WatchdogLogger e
showLogger e
err = WatchdogLogger String
defaultLogger (e -> String
forall a. Show a => a -> String
show e
err)

-- | Disable logging by passing this function to 'setLoggingAction'.
silentLogger :: WatchdogLogger e
silentLogger :: WatchdogLogger e
silentLogger e
_ Maybe Int
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Format the watchdog status report. Will produce output like this:
--
-- @
-- Watchdog: Error executing task (some error) - trying again immediately.
-- Watchdog: Error executing task (some error) - waiting 1s before trying again.
-- @
formatWatchdogError :: (IsString str, Semigroup str)
                       => str       -- ^ Error message returned by the task.
                       -> Maybe Int -- ^ Waiting time - if any - before trying again.
                       -> str
formatWatchdogError :: str -> Maybe Int -> str
formatWatchdogError str
taskErr Maybe Int
Nothing =
    str
"Watchdog: Error executing task (" str -> str -> str
forall a. Semigroup a => a -> a -> a
<> str
taskErr str -> str -> str
forall a. Semigroup a => a -> a -> a
<> str
") - trying again immediately."
formatWatchdogError str
taskErr (Just Int
delay) =
    let asNominalDiffTime :: NominalDiffTime    -- just to display it properly
        asNominalDiffTime :: NominalDiffTime
asNominalDiffTime = Int -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
delay NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Fractional a => a -> a -> a
/ NominalDiffTime
10 NominalDiffTime -> Integer -> NominalDiffTime
forall a b. (Num a, Integral b) => a -> b -> a
^ (Integer
6 :: Integer)
    in str
"Watchdog: Error executing task (" str -> str -> str
forall a. Semigroup a => a -> a -> a
<> str
taskErr str -> str -> str
forall a. Semigroup a => a -> a -> a
<> str
") - waiting"
        str -> str -> str
forall a. Semigroup a => a -> a -> a
<> str
" " str -> str -> str
forall a. Semigroup a => a -> a -> a
<> String -> str
forall a. IsString a => String -> a
fromString (NominalDiffTime -> String
forall a. Show a => a -> String
show NominalDiffTime
asNominalDiffTime) str -> str -> str
forall a. Semigroup a => a -> a -> a
<> str
" before trying again."

-- | Helper class which can be wrapped around a task.
-- The task should return an 'Either', where Left in combination
-- with an error message signals an error and Right with an arbitrary
-- result signals success. In case of failure, the wrapper will check whether
-- the function ran less than 30 seconds and then return 'FailedImmediately'
-- or 'FailedAfterAWhile' accordingly.
timeTask :: Int -> IO (Either e a) -> IO (WatchdogTaskStatus e a)
timeTask :: Int -> IO (Either e a) -> IO (WatchdogTaskStatus e a)
timeTask Int
resetDuration IO (Either e a)
task = do
    UTCTime
start <- IO UTCTime
getCurrentTime
    Either e a
status <- IO (Either e a)
task
    UTCTime
stop <- IO UTCTime
getCurrentTime
    case Either e a
status of
        Right a
result -> WatchdogTaskStatus e a -> IO (WatchdogTaskStatus e a)
forall (m :: * -> *) a. Monad m => a -> m a
return (WatchdogTaskStatus e a -> IO (WatchdogTaskStatus e a))
-> WatchdogTaskStatus e a -> IO (WatchdogTaskStatus e a)
forall a b. (a -> b) -> a -> b
$ a -> WatchdogTaskStatus e a
forall e a. a -> WatchdogTaskStatus e a
CompletedSuccessfully a
result
        Left e
err ->
            let cutOff :: NominalDiffTime
cutOff = Int -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
resetDuration NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Fractional a => a -> a -> a
/ NominalDiffTime
10 NominalDiffTime -> Integer -> NominalDiffTime
forall a b. (Num a, Integral b) => a -> b -> a
^ (Integer
6 :: Integer)
            in if UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
stop UTCTime
start NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< NominalDiffTime
cutOff
                        then WatchdogTaskStatus e a -> IO (WatchdogTaskStatus e a)
forall (m :: * -> *) a. Monad m => a -> m a
return (WatchdogTaskStatus e a -> IO (WatchdogTaskStatus e a))
-> WatchdogTaskStatus e a -> IO (WatchdogTaskStatus e a)
forall a b. (a -> b) -> a -> b
$ e -> WatchdogTaskStatus e a
forall e a. e -> WatchdogTaskStatus e a
FailedImmediately e
err
                        else WatchdogTaskStatus e a -> IO (WatchdogTaskStatus e a)
forall (m :: * -> *) a. Monad m => a -> m a
return (WatchdogTaskStatus e a -> IO (WatchdogTaskStatus e a))
-> WatchdogTaskStatus e a -> IO (WatchdogTaskStatus e a)
forall a b. (a -> b) -> a -> b
$ e -> WatchdogTaskStatus e a
forall e a. e -> WatchdogTaskStatus e a
FailedAfterAWhile e
err