{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Glue.CircuitBreaker(
CircuitBreakerOptions
, CircuitBreakerState
, CircuitBreakerException(..)
, combineCircuitBreakerStates
, isCircuitBreakerOpen
, isCircuitBreakerClosed
, defaultCircuitBreakerOptions
, circuitBreaker
, maxBreakerFailures
, resetTimeoutSecs
, breakerDescription
) where
import Control.Exception.Lifted
import Control.Monad.Base
import Control.Monad.Trans.Control
import Data.IORef.Lifted
import Data.Time.Clock.POSIX
import Data.Typeable
import Glue.Types
data CircuitBreakerOptions = CircuitBreakerOptions {
maxBreakerFailures :: Int
, resetTimeoutSecs :: Int
, breakerDescription :: String
}
defaultCircuitBreakerOptions :: CircuitBreakerOptions
defaultCircuitBreakerOptions = CircuitBreakerOptions { maxBreakerFailures = 3, resetTimeoutSecs = 60, breakerDescription = "Circuit breaker open." }
data BreakerStatus = BreakerClosed Int | BreakerOpen Int deriving (Eq, Show)
data CircuitBreakerState = CircuitBreakerState [IORef BreakerStatus]
data CircuitBreakerException = CircuitBreakerException String deriving (Eq, Show, Typeable)
instance Exception CircuitBreakerException
combineCircuitBreakerStates :: (Foldable t) => t CircuitBreakerState -> CircuitBreakerState
combineCircuitBreakerStates states = CircuitBreakerState $ foldMap (\(CircuitBreakerState refs) -> refs) states
isStatusOpen :: BreakerStatus -> Bool
isStatusOpen (BreakerOpen _) = True
isStatusOpen (BreakerClosed _) = False
isStatusClosed :: BreakerStatus -> Bool
isStatusClosed (BreakerOpen _) = False
isStatusClosed (BreakerClosed _) = True
isCircuitBreakerOpen :: (MonadBaseControl IO m) => CircuitBreakerState -> m Bool
isCircuitBreakerOpen (CircuitBreakerState states) = fmap or $ traverse (\ref -> fmap isStatusOpen $ readIORef ref) states
isCircuitBreakerClosed :: (MonadBaseControl IO m) => CircuitBreakerState -> m Bool
isCircuitBreakerClosed (CircuitBreakerState states) = fmap and $ traverse (\ref -> fmap isStatusClosed $ readIORef ref) states
circuitBreaker :: (MonadBaseControl IO m, MonadBaseControl IO n)
=> CircuitBreakerOptions
-> BasicService m a b
-> n (CircuitBreakerState, BasicService m a b)
circuitBreaker options service =
let retrieveTime = liftBase $ round `fmap` getPOSIXTime
failureMax = maxBreakerFailures options
callIfClosed request ref = bracketOnError (return ()) (\_ -> incErrors ref) (\_ -> service request)
canaryCall request ref = do
result <- callIfClosed request ref
writeIORef ref $ BreakerClosed 0
return result
incErrors ref = do
currentTime <- retrieveTime
atomicModifyIORef' ref $ \status -> case status of
(BreakerClosed errorCount) -> (if errorCount >= failureMax then BreakerOpen (currentTime + (resetTimeoutSecs options)) else BreakerClosed (errorCount + 1), ())
other -> (other, ())
failingCall = throw $ CircuitBreakerException $ breakerDescription options
callIfOpen request ref = do
currentTime <- retrieveTime
canaryRequest <- atomicModifyIORef' ref $ \status -> case status of
(BreakerClosed _) -> (status, False)
(BreakerOpen time) -> if currentTime > time then ((BreakerOpen (currentTime + (resetTimeoutSecs options))), True) else (status, False)
if canaryRequest then canaryCall request ref else failingCall
breakerService ref request = do
status <- readIORef ref
case status of
(BreakerClosed _) -> callIfClosed request ref
(BreakerOpen _) -> callIfOpen request ref
in do
ref <- newIORef $ BreakerClosed 0
return (CircuitBreakerState [ref], breakerService ref)