diff --git a/Control/Watchdog.hs b/Control/Watchdog.hs new file mode 100644 --- /dev/null +++ b/Control/Watchdog.hs @@ -0,0 +1,281 @@ +-- | +-- 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 + , watch + , watchImpatiently + , setInitialDelay + , setMaximumDelay + , setMaximumRetries + , setResetDuration + , setLoggingAction + , defaultLogger + , silentLogger + , formatWatchdogError + , WatchdogLogger + , WatchdogAction + ) where + +import Control.Concurrent +import Control.Monad.State.Strict +import Data.Time + +data WatchdogState = WatchdogState { wcInitialDelay :: Int + , wcMaximumDelay :: Int + , wcResetDuration :: Int + , wcMaximumRetries :: Integer + , wcLoggingAction :: WatchdogLogger + } + +data WatchdogTaskStatus a = FailedImmediately String + | FailedAfterAWhile String + | CompletedSuccessfully a + +newtype WatchdogAction a = WA { runWA :: StateT WatchdogState IO a } + deriving (Monad, MonadIO, MonadState WatchdogState) + +-- | Type synonym for a watchdog logger. +type WatchdogLogger = String -- ^ Error message returned by the task. + -> Maybe Int -- ^ Waiting time - if any - before trying again. + -> IO () + +defaultConf :: WatchdogState +defaultConf = WatchdogState { wcInitialDelay = 1 * 10 ^ (6::Integer) + , wcMaximumDelay = 300 * 10 ^ (6::Integer) + , wcMaximumRetries = 10 + , wcResetDuration = 30 * 10 ^ (6::Integer) + , wcLoggingAction = defaultLogger + } + +-- | The Watchdog monad. Used to configure and eventually run a watchdog. +watchdog :: WatchdogAction a -> IO a +watchdog action = evalStateT (runWA action) defaultConf + +-- | 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 () +setInitialDelay delay = do + conf <- get + put conf { wcInitialDelay = 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 () +setMaximumDelay delay = do + conf <- get + put conf { wcMaximumDelay = 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 () +setResetDuration duration = do + conf <- get + put conf { wcResetDuration = 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 () +setMaximumRetries retries = do + conf <- get + put conf { wcMaximumRetries = 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 -> WatchdogAction () +setLoggingAction f = do + conf <- get + put conf { wcLoggingAction = 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 String a) -> WatchdogAction a +watch task = do + conf <- get + liftIO $ go conf (wcInitialDelay conf) + where + go conf errorDelay = do + status <- timeTask (wcResetDuration conf) task + case status of + CompletedSuccessfully result -> return result + FailedAfterAWhile err -> do + let errorDelay' = wcInitialDelay conf + loggingAction = wcLoggingAction conf + loggingAction err Nothing -- log that we will retry immediately + go conf errorDelay' + FailedImmediately err -> do + let errorDelay' = + min (errorDelay * 2) (wcMaximumDelay conf) + loggingAction = wcLoggingAction conf + loggingAction err (Just errorDelay) -- log that we will + -- retry after a delay + threadDelay errorDelay + go conf 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 String b) -> WatchdogAction (Either String b) +watchImpatiently task = do + conf <- get + liftIO $ go conf 0 "" (wcInitialDelay conf) + where + go conf retries lastError errorDelay = do + status <- timeTask (wcResetDuration conf) task + case status of + CompletedSuccessfully result -> return $ Right result + FailedAfterAWhile err -> + if retries >= wcMaximumRetries conf + then return $ Left lastError + else do + let errorDelay' = wcInitialDelay conf + loggingAction = wcLoggingAction conf + loggingAction err Nothing + go conf (retries + 1) err errorDelay' + FailedImmediately err -> + if retries >= wcMaximumRetries conf + then return $ Left lastError + else do + let errorDelay' = + min (errorDelay * 2) (wcMaximumDelay conf) + loggingAction = wcLoggingAction conf + loggingAction err (Just errorDelay) + threadDelay errorDelay + go conf (retries + 1) err errorDelay' + +-- | The default logging action. It will call 'formatWatchdogError' and display +-- the result on STDOUT. +defaultLogger :: WatchdogLogger +defaultLogger taskErr delay = putStrLn $ formatWatchdogError taskErr delay + +-- | Disable logging by passing this function to 'setLoggingAction'. +silentLogger :: WatchdogLogger +silentLogger _ _ = 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 :: String -- ^ Error message returned by the task. + -> Maybe Int -- ^ Waiting time - if any - before trying again. + -> String +formatWatchdogError taskErr Nothing = + "Watchdog: Error executing task (" ++ taskErr ++ ") - trying again immediately." +formatWatchdogError taskErr (Just delay) = + let asNominalDiffTime :: NominalDiffTime -- just to display it properly + asNominalDiffTime = fromIntegral delay / 10 ^ (6 :: Integer) + in "Watchdog: Error executing task (" ++ taskErr ++ ") - waiting" + ++ " " ++ show asNominalDiffTime ++ " 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 String a) -> IO (WatchdogTaskStatus a) +timeTask resetDuration task = do + start <- getCurrentTime + status <- task + stop <- getCurrentTime + case status of + Right result -> return $ CompletedSuccessfully result + Left err -> + let cutOff = fromIntegral resetDuration / 10 ^ (6 :: Integer) + in if diffUTCTime stop start < cutOff + then return $ FailedImmediately err + else return $ FailedAfterAWhile err diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) 2014, Jan Vornberger +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/watchdog.cabal b/watchdog.cabal new file mode 100644 --- /dev/null +++ b/watchdog.cabal @@ -0,0 +1,25 @@ +name: watchdog +version: 0.2.2 +author: Jan Vornberger +maintainer: Jan Vornberger +synopsis: Simple control structure to re-try an action with exponential backoff +description: See Control.Watchdog for documentation. +category: blub +build-type: Simple +cabal-version: >= 1.8 +license: BSD3 +license-file: LICENSE + +source-repository head + type: git + location: https://github.com/javgh/watchdog + +library + build-depends: base == 4.* + -- Wheezy: 4.5.0.0 (ghc) + , time == 1.4.* + -- Wheezy: 1.4.1 (ghc) + , mtl == 2.1.* + -- Wheezy: 2.1.1 (libghc-mtl-dev) + exposed-modules: Control.Watchdog + ghc-options: -Wall