circuit-breaker (empty) → 0.1.0.0
raw patch · 10 files changed
+552/−0 lines, 10 filesdep +QuickCheckdep +basedep +circuit-breakersetup-changed
Dependencies added: QuickCheck, base, circuit-breaker, mtl, quickcheck-instances, random, tasty, tasty-hunit, tasty-quickcheck, text, time, transformers, unliftio, unliftio-core, unordered-containers
Files
- ChangeLog.md +3/−0
- LICENSE +30/−0
- README.md +52/−0
- Setup.hs +2/−0
- app/Main.hs +35/−0
- circuit-breaker.cabal +98/−0
- src/Lib.hs +8/−0
- src/System/CircuitBreaker.hs +216/−0
- src/System/CircuitBreaker/Management.hs +1/−0
- test/Spec.hs +107/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for circuit-breaker++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2019++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * 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.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"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 COPYRIGHT+OWNER 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.
+ README.md view
@@ -0,0 +1,52 @@+# circuit-breaker+Circuit breakers are an error handling machine inspired by the circuit breakers used in electrical systems. Just+like their namesake, software circuit breakers prevent pushing traffic through a failing component+until it has recovered.++As of the current version, all `CircuitBreaker`s use a "leaky bucket" approach to backoffs.+In the definition of a circuit breaker, the first `Natural` argument is the number of milliseconds that need to pass before an error is expunged.+Coupled with an error threshold argument, this provides a surprising amount of flexibility for cirucit breakers in the wild, although you'll want to monitor and tune them over time.++### Using a circuit breaker+The following short example illustrates how to define a circuit breaker & use it.++```haskell+testBreaker :: CircuitBreaker "Test" 1000 4+testBreaker = undefined++main :: IO ()+main = do+ -- Initializes the empty storage for all circuit breakers+ cbConf <- initialBreakerState+ -- Perform a bunch of "work". Because we have a 50% failure rate and trigger the breaker after four+ -- errors, this will cause the breaker to disable additional calls.+ forM_ [1..30] $ const . noteError . flip runReaderT cbConf $ withBreaker testBreaker computation++ -- simulating a backoff long enough to decrement the accumulated errors.+ threadDelay 5000000++ noteError . flip runReaderT cbConf $ withBreaker testBreaker computation+ where+ noteError action = print =<< catchAny action (const $ pure (Left Failed))++++-- | This computation fails 50% of the time+computation :: ReaderT CircuitBreakerConf IO Int+computation = do+ shouldFail <- liftIO randomIO+ when shouldFail $ error "Failed"+ pure 42+```++The first thing to notice is that the `CircuitBreaker` definition exists entirely at the type level.+This guarantees that the definition of a particular `CircuitBreaker` can't somehow change at runtime.++All calls to `withBreaker` require a `CircuitBreakerConf` to be present in a reader environment.+`initialBreakerState` simply initializes an empty `CircuitBreakerConf` to save you the trouble of creating one yourself.++### Contributing+PRs and issues are welcome! Please let me know what you think could be improved or submit the patch yourself.++### License+MIT
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,35 @@+module Main where++import System.CircuitBreaker (CircuitBreaker, withBreaker, initialBreakerState,+ CircuitBreakerConf, CircutBreakerError(..))++import Control.Monad(forM_)+import Control.Monad.Trans (liftIO)+import Control.Monad.Reader (ReaderT, runReaderT)+import Control.Concurrent(threadDelay)+import Control.Monad (when, forever)+import UnliftIO.Exception (catchAny)+import System.Random (randomIO)++testBreaker :: CircuitBreaker "Test" 1000 4+testBreaker = undefined++main :: IO ()+main = do+ cbConf <- initialBreakerState+ -- TODO the api for calling withBreaker kinda sucks. It'd be great to drop the 'undefined'++ forM_ [1..30] $ const . noteError . flip runReaderT cbConf $ withBreaker testBreaker computation+ threadDelay 5000000+ noteError . flip runReaderT cbConf $ withBreaker testBreaker computation+ where+ noteError action = print =<< catchAny action (const $ pure (Left Failed))++++-- | This computation fails 50% of the time+computation :: ReaderT CircuitBreakerConf IO Int+computation = do+ shouldFail <- liftIO randomIO+ when shouldFail $ error "Failed"+ pure 42
+ circuit-breaker.cabal view
@@ -0,0 +1,98 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.1.+--+-- see: https://github.com/sol/hpack+--+-- hash: b70b09864192ada221e36052b2e656f25c7d31214c5eaacd042f183f5efb13b1++name: circuit-breaker+version: 0.1.0.0+synopsis: An implementation of the "circuit breaker" pattern to disable repeated calls to a failing system+description: Please see the README on GitHub at <https://github.com/ChrisCoffey/circuit-breaker#readme>+category: System+homepage: https://github.com/ChrisCoffey/circuit-breaker#readme+bug-reports: https://github.com/ChrisCoffey/circuit-breaker/issues+author: Chris Coffey+maintainer: chris@foldl.io+copyright: 2019 Chris Coffey+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md++source-repository head+ type: git+ location: https://github.com/ChrisCoffey/circuit-breaker++library+ exposed-modules:+ Lib+ System.CircuitBreaker+ System.CircuitBreaker.Management+ other-modules:+ Paths_circuit_breaker+ hs-source-dirs:+ src+ default-extensions: GADTs FlexibleInstances DataKinds MultiParamTypeClasses FunctionalDependencies TypeApplications KindSignatures ScopedTypeVariables TypeFamilies ExistentialQuantification OverloadedStrings+ build-depends:+ base >=4.7 && <5+ , mtl+ , random+ , text+ , time+ , transformers+ , unliftio+ , unliftio-core+ , unordered-containers+ default-language: Haskell2010++executable circuit-breaker-exe+ main-is: Main.hs+ other-modules:+ Paths_circuit_breaker+ hs-source-dirs:+ app+ default-extensions: GADTs FlexibleInstances DataKinds MultiParamTypeClasses FunctionalDependencies TypeApplications KindSignatures ScopedTypeVariables TypeFamilies ExistentialQuantification OverloadedStrings+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , circuit-breaker+ , mtl+ , random+ , text+ , time+ , transformers+ , unliftio+ , unliftio-core+ , unordered-containers+ default-language: Haskell2010++test-suite circuit-breaker-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Paths_circuit_breaker+ hs-source-dirs:+ test+ default-extensions: GADTs FlexibleInstances DataKinds MultiParamTypeClasses FunctionalDependencies TypeApplications KindSignatures ScopedTypeVariables TypeFamilies ExistentialQuantification OverloadedStrings+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ QuickCheck+ , base >=4.7 && <5+ , circuit-breaker+ , mtl+ , quickcheck-instances+ , random+ , tasty+ , tasty-hunit+ , tasty-quickcheck+ , text+ , time+ , transformers+ , unliftio+ , unliftio-core+ , unordered-containers+ default-language: Haskell2010
+ src/Lib.hs view
@@ -0,0 +1,8 @@+module Lib+ ( someFunc+ ) where++someFunc :: IO ()+someFunc = putStrLn "someFunc"++
+ src/System/CircuitBreaker.hs view
@@ -0,0 +1,216 @@+-- |+-- Module: System.CircuitBreaker+-- Copyright: (c) 2019 Chris Coffey+-- License: MIT+-- Maintainer: chris@foldl.io+-- Stability: experimental+-- Portability: portable+--+-- This is a batteries mostly-included circuit breaker library. It provides automatic backoff behavior by+-- preventing calls to a failing resource. For example, if a particular service is currently overloaded and+-- begins failing to respond to requests, then the circuit breaker will detect those errors and prevent+-- further calls from actually hitting the server in question. Once the service has had a chance to stabilize+-- the circuit breaker will allow a "testing" call to pass through. If it succeeds, then all other calls are+-- allowed to flow through. If it fails then it waits a bit longer before testing again.++module System.CircuitBreaker (+ CircuitBreaker,+ CircuitBreakerConf(..),+ withBreaker,++ CircutBreakerError(..),+ HasCircuitConf(..),+ CircuitState(..),+ CircuitAction(..),+ ErrorThreshold(..),+ CBCondition(..),++ initialBreakerState,+ -- | Exported for testing+ breakerTransitionGuard,+ breakerTryPerformAction,+ decrementErrorCount+) where++import Control.Monad (forever, void)+import Control.Monad.Trans (liftIO)+import Control.Monad.IO.Unlift (MonadUnliftIO)+import Control.Monad.Reader (MonadReader, asks, ReaderT, ask)+import Data.Maybe (fromMaybe, isNothing)+import Numeric.Natural (Natural)+import GHC.TypeLits (Symbol, KnownSymbol, symbolVal, Nat, KnownNat, natVal)+import Data.Proxy (Proxy(..))+import UnliftIO.Concurrent (forkIO, threadDelay)+import UnliftIO.Exception (bracketOnError, catchDeep)+import UnliftIO.MVar (MVar, putMVar, takeMVar, newMVar, swapMVar)+import qualified Data.Text as T+import qualified Data.HashMap.Strict as M++newtype CircuitBreakerConf = CBConf {+ cbBreakers :: MVar (M.HashMap T.Text (MVar CircuitState))+ }++-- | Initialize the storage for the process' circuit breakers+initialBreakerState :: MonadUnliftIO m => m CircuitBreakerConf+initialBreakerState = do+ mv <- newMVar M.empty+ pure CBConf {cbBreakers = mv}++-- | The current condition of a CircutBreaker may be Active, Testing, or Waiting for the+-- timeout to elapse.+data CBCondition+ = Active+ | Testing+ | Waiting+ deriving (Show, Eq, Ord, Bounded, Enum)++data CircuitState = CircuitState {+ errorCount :: Natural+ , currentState :: !CBCondition+ } deriving (Show)++-- | A constraint that allows pullng the circuit breaker+class HasCircuitConf env where+ getCircuitState :: env -> CircuitBreakerConf++instance HasCircuitConf CircuitBreakerConf where+ getCircuitState = id++newtype ErrorThreshold = ET Natural+newtype DripFreq = DF Natural++-- | Access a Circut Breaker's label at runtime+reifyCircuitBreaker :: forall label df et. (KnownSymbol label, KnownNat df, KnownNat et) =>+ CircuitBreaker label df et+ -> (T.Text, DripFreq, ErrorThreshold)+reifyCircuitBreaker _ = (l, df, et)+ where+ l = T.pack $ symbolVal (Proxy :: Proxy label)+ df = DF . (* 1000) . fromIntegral $ natVal (Proxy :: Proxy df)+ et = ET . fromIntegral $ natVal (Proxy :: Proxy et)++-- | The definition of a particular circuit breaker+data CircuitBreaker (label :: Symbol) (dripFreq :: Nat) (errorThreshold :: Nat)++data CircutBreakerError+ = Failed+ | CircuitBreakerClosed T.Text+ deriving (Show, Eq, Ord)++data CircuitAction+ = SkipClosed+ | Run+ deriving (Eq, Show)+++-- | Brackets a computation with short-circuit logic. If an uncaught error occurs, then the+-- circuit breaker opens, which causes all additional threads entering the wrapped code to fail+-- until the specified timeout has expired. Once the timeout expires, a single thread may enter+-- the protected region. If the call succeeds, then the circuit breaker allows all other traffic+-- through. Otherwise, it resets the timeout, after which the above algorithm repeats.+--+-- Important Note: This does not catch errors. If an IO error is thrown, it will bubble up from+-- this function. Internally, if the breaker is tripped, it will prevent further calls+withBreaker :: (KnownSymbol label, KnownNat df, KnownNat et, Monad m,+ MonadUnliftIO m, MonadReader env m, HasCircuitConf env) =>+ CircuitBreaker label df et+ -> m a+ -> m (Either CircutBreakerError a)+withBreaker breakerDefinition action = do+ -- Get the current circut breaker+ breakerCell <- cbBreakers <$> asks getCircuitState+ breakers <- takeMVar breakerCell+ let mbs = label `M.lookup` breakers+ newBreaker = CircuitState {+ errorCount = 0,+ currentState = Active+ }+ bs <- maybe (newMVar newBreaker) pure mbs++ -- If it happens to be the first time this block has been called, store the new breakers state.+ -- Also initialize a monitor thread to drip errors+ if isNothing mbs+ then do+ putMVar breakerCell $ M.insert label bs breakers+ monitor bs+ else putMVar breakerCell breakers+ -- bracketOnError the action+ -- Read the current status & determine whether to perform the action+ -- 0) Get the current time+ -- 1) Try to read the MVar+ -- 2) If it is Nothing, then there is a test underway & we're still closed+ -- 3) If it is a Just, check if we're 'Waiting' & the timeout has not elapsed+ -- 4) If the timeout has elapsed, enter 'Testing' state+ -- 5) Otherwise, run the computation+ -- 6) If the computation fails, set the error time and enter 'Waiting' state+ bracketOnError (breakerTransitionGuard bs (ET et)) (onError bs) (breakerTryPerformAction label action bs)+ where+ (label, DF dripFreq, ET et) = reifyCircuitBreaker breakerDefinition++ -- In the event of an uncaught error during the bracketed computation, flip the circuit breaker to 'Waiting'+ onError bs Run = do+ bs' <- takeMVar bs+ let ec' = 1 + errorCount bs'+ state = if ec' >= et then Waiting else Active+ putMVar bs $ CircuitState {errorCount = ec', currentState = state}++ -- Run a+ monitor bs =+ void . forkIO . forever $ do+ threadDelay $ fromIntegral dripFreq+ decrementErrorCount bs++-- | Given the current state of the circuit breaker, determine what action should+-- be taken during the body of the 'bracket'.+--+-- Condition rules:+-- 1) If the circuit breaker is in 'Active' then pass the call on+-- 2) If the circuit breaker is in 'Testing' then fail the call+-- 3) If the circuit breaker is in 'Waiting' and the timeout has not elapsed then fail the call+-- 4) If the circuit breaker is in 'Waiting' and the timeout has elapsed then convert to 'Testing' and try the call+breakerTransitionGuard :: (MonadUnliftIO m) =>+ MVar CircuitState+ -> ErrorThreshold+ -> m CircuitAction+breakerTransitionGuard bs (ET et) = do+ cb <- takeMVar bs+ let elapsed = errorCount cb < fromIntegral et+ case currentState cb of+ Waiting | elapsed -> do+ putMVar bs $ cb {currentState = Testing}+ pure Run+ Active -> do+ putMVar bs cb+ pure Run+ Waiting -> do+ putMVar bs cb+ pure SkipClosed+ Testing -> do+ putMVar bs cb+ pure SkipClosed++-- | Conditionally performs an action with in a circuit breaker, as determined by the current breaker state.+breakerTryPerformAction :: MonadUnliftIO m =>+ T.Text -- ^ label+ -> m a -- ^ Action to perform+ -> MVar CircuitState -- ^ Pointer to the breaker state+ -> CircuitAction+ -> m (Either CircutBreakerError a)+breakerTryPerformAction label _ _ SkipClosed =+ pure . Left $ CircuitBreakerClosed label+breakerTryPerformAction label action bs Run = do+ res <- Right <$> action+ bs' <- takeMVar bs+ putMVar bs (bs' {currentState = Active})+ pure res++-- | Decrements a counter+decrementErrorCount :: MonadUnliftIO m =>+ MVar CircuitState+ -> m ()+decrementErrorCount breaker = do+ rawState <- takeMVar breaker+ let ec = errorCount rawState+ if ec == 0+ then putMVar breaker rawState+ else putMVar breaker $ rawState {errorCount = ec -1}
+ src/System/CircuitBreaker/Management.hs view
@@ -0,0 +1,1 @@+module System.CircuitBreaker.Management where
+ test/Spec.hs view
@@ -0,0 +1,107 @@+module Main (main) where++import System.CircuitBreaker++import Control.Concurrent.MVar+import Data.Either+import Numeric.Natural+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck++main :: IO ()+main = defaultMain $ testGroup "System.CircuitBreaker" [+ decrementProperties+ , evaluationProperties+ , transitionProperties+ ]++transitionProperties :: TestTree+transitionProperties = testGroup "transition guard" [+ testCase "Waiting -> SkipClosed iff errors remain" $ do+ bs <- newMVar $ CircuitState {errorCount = 1, currentState = Waiting}+ action <- breakerTransitionGuard bs (ET 1)+ action @=? SkipClosed+ , testCase "Respects the error threshold" $ do+ bs <- newMVar $ CircuitState {errorCount = 9, currentState = Waiting}+ action <- breakerTransitionGuard bs (ET 10)+ bs' <- readMVar bs+ action @=? Run+ currentState bs' @=? Testing+ , testCase "Testing is a serialized state" $ do+ bs <- newMVar $ CircuitState {errorCount = 0, currentState = Testing}+ action <- breakerTransitionGuard bs (ET 1)+ action @=? SkipClosed+ , testCase "Active always -> Run" $ do+ bs <- newMVar $ CircuitState {errorCount = 5, currentState = Active}+ action <- breakerTransitionGuard bs (ET 1)+ action @=? Run+ ]++evaluationProperties :: TestTree+evaluationProperties = testGroup "evaluation" [+ testProperty "never evaluates if SkipClosed is provided" $ \(CircState rawBS, ca) ->+ cover 35 (ca == SkipClosed) "Skip Closed" .+ cover 35 (ca == Run) "Run" . ioProperty $ do+ bs <- newMVar rawBS+ cell <- newMVar False+ res <- breakerTryPerformAction "test" (swapMVar cell True) bs ca+ cellV <- readMVar cell+ pure $ if isLeft res+ then not cellV+ else cellV+ , testProperty "always sets status to active if it runs" $ \(CircState rawBS, ca) ->+ cover 35 (ca == SkipClosed) "Skip Closed" .+ cover 35 (ca == Run ) "Run" . ioProperty $ do+ bs <- newMVar rawBS+ cell <- newMVar False+ res <- breakerTryPerformAction "test" (swapMVar cell True) bs ca+ cellV <- readMVar cell+ ba' <- readMVar bs+ pure $ if cellV+ then currentState ba' == Active+ else isLeft res+ ]++decrementProperties :: TestTree+decrementProperties = testGroup "error decrement" [+ testProperty "decrements, but not through zero" $ \(CircState rawBS) ->+ cover 5 (errorCount rawBS < 2) "Minimum Boundary" . ioProperty $ do+ bs <- newMVar rawBS+ decrementErrorCount bs+ val <- readMVar bs+ pure $ if errorCount rawBS == 0+ then errorCount rawBS == errorCount val+ else errorCount val == errorCount rawBS - 1++ , testProperty "never changes state" $ \(CircState rawBS) -> ioProperty $ do+ bs <- newMVar rawBS+ decrementErrorCount bs+ val <- readMVar bs+ pure $ currentState val == currentState rawBS++ , testProperty "Always >= 0" $ \(CircState rawBS) ->+ cover 2 (errorCount rawBS == 0) "Minimum Boundary" . ioProperty $ do+ bs <- newMVar rawBS+ decrementErrorCount bs+ val <- readMVar bs+ pure $ errorCount val >= 0+ ]++newtype CircState = CircState CircuitState deriving Show+instance Arbitrary CircState where+ arbitrary = do+ st <- elements [Active, Testing, Waiting]+ ec <- arbitrary+ pure . CircState $ CircuitState {+ errorCount = ec+ , currentState = st+ }++instance Arbitrary CircuitAction where+ arbitrary = elements [Run, SkipClosed]+++instance Arbitrary Natural where+ arbitrary = fromIntegral . abs <$> (arbitrary :: Gen Int)+