glue-core (empty) → 0.4.0
raw patch · 22 files changed
+919/−0 lines, 22 filesdep +QuickCheckdep +asyncdep +basesetup-changed
Dependencies added: QuickCheck, async, base, ekg-core, glue-common, hashable, hspec, lifted-base, monad-control, quickcheck-instances, text, time, transformers, transformers-base, unordered-containers
Files
- Setup.hs +2/−0
- glue-core.cabal +78/−0
- src/Glue/Batcher.hs +87/−0
- src/Glue/Caching.hs +49/−0
- src/Glue/CircuitBreaker.hs +80/−0
- src/Glue/DogpileProtection.hs +37/−0
- src/Glue/Failover.hs +37/−0
- src/Glue/Preload.hs +93/−0
- src/Glue/Retry.hs +49/−0
- src/Glue/Switching.hs +26/−0
- src/Glue/Timeout.hs +45/−0
- test/Glue/BatcherSpec.hs +24/−0
- test/Glue/CachingSpec.hs +76/−0
- test/Glue/CircuitBreakerSpec.hs +36/−0
- test/Glue/DogpileProtectionSpec.hs +45/−0
- test/Glue/FailoverSpec.hs +28/−0
- test/Glue/PreloadSpec.hs +44/−0
- test/Glue/RetrySpec.hs +38/−0
- test/Glue/Testing.hs +8/−0
- test/Glue/TimeoutSpec.hs +22/−0
- test/Main.hs +14/−0
- test/Spec.hs +1/−0
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ glue-core.cabal view
@@ -0,0 +1,78 @@+name: glue-core+version: 0.4.0+synopsis: Make better services.+description: Combinator library to enhance the general functionality of services.+license: BSD3+license-file: ../LICENSE+author: Sean Parsons+maintainer: github@futurenotfound.com+category: Network+build-type: Simple+cabal-version: >=1.10++source-repository head+ type: git+ location: git://github.com/seanparsons/glue.git++library+ exposed-modules: Glue.Failover+ Glue.Caching+ Glue.CircuitBreaker+ Glue.DogpileProtection+ Glue.Timeout+ Glue.Retry+ Glue.Batcher+ Glue.Preload+ Glue.Switching+ -- other-extensions:+ build-depends: base >=4.6 && <4.9,+ glue-common,+ transformers,+ transformers-base,+ lifted-base,+ time,+ monad-control,+ unordered-containers,+ hashable,+ text+ ghc-options: -rtsopts+ -Wall+ hs-source-dirs: src+ default-language: Haskell2010++test-suite glue-core-tests+ build-depends: base ==4.*,+ glue-common,+ QuickCheck -any,+ quickcheck-instances,+ hspec >=2.1.10,+ transformers,+ transformers-base,+ lifted-base,+ time,+ monad-control,+ unordered-containers,+ hashable,+ ekg-core,+ text,+ async+ other-modules: Glue.CachingSpec+ Glue.FailoverSpec+ Glue.RetrySpec+ Glue.DogpileProtectionSpec+ Glue.Testing+ Glue.TimeoutSpec+ Glue.CircuitBreakerSpec+ Glue.BatcherSpec+ Glue.PreloadSpec+ Spec+ ghc-options: -rtsopts+ -Wall+ -O2+ -threaded+ type: exitcode-stdio-1.0+ main-is: Main.hs+ buildable: True+ default-language: Haskell2010+ hs-source-dirs: test,+ src
+ src/Glue/Batcher.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Module for creating a service that batches calls across requests.+module Glue.Batcher(+ BatchingOptions+ , batchingService+ , defaultBatchingOptions+ , batchWindowMs+) where++import Control.Applicative+import Control.Concurrent.Lifted+import Control.Exception.Lifted+import Control.Monad+import Control.Monad.Trans.Control+import qualified Data.HashSet as S+import qualified Data.HashMap.Strict as M+import Data.Foldable+import Data.Hashable+import Data.IORef.Lifted+import Glue.Types++-- | Options for configuring the batching.+data BatchingOptions = BatchingOptions {+ batchWindowMs :: Int -- ^ Window in milliseconds over which to batch.+} deriving (Eq, Show)++-- | Default instance of 'BatchingOptions' with a batching window of 10ms.+defaultBatchingOptions :: BatchingOptions+defaultBatchingOptions = BatchingOptions {+ batchWindowMs = 10+}++-- | Cumulative request batch of all the outstanding calls.+data RequestBatch a b = RequestBatch [PendingRequest a b] (MultiGetRequest a)++-- | Individual request to satisfy, for either a single key or a multi request.+data PendingRequest a b =+ SingleRequest a (ResultVar (Maybe b)) |+ MultiRequest (MultiGetRequest a) (ResultVar (MultiGetResponse a b))++applyToPending :: (Eq a, Hashable a, MonadBaseControl IO m) => Either SomeException (M.HashMap a b) -> PendingRequest a b -> m ()+applyToPending (Left e) (SingleRequest _ var) = putMVar var $ Left e+applyToPending (Right results) (SingleRequest a var) = putMVar var $ Right $ M.lookup a results+applyToPending (Left e) (MultiRequest _ var) = putMVar var $ Left e+applyToPending (Right results) (MultiRequest as var) = putMVar var $ Right $ M.filterWithKey (\k -> \_ -> S.member k as) results++emptyBatch :: (Eq a, Hashable a) => RequestBatch a b+emptyBatch = RequestBatch [] S.empty++processCalls :: (Eq a, Hashable a, MonadBaseControl IO m) => MultiGetService m a b -> RequestBatch a b -> m ()+processCalls service (RequestBatch pendings requests) = do+ result <- makeCall service requests+ traverse_ (applyToPending result) pendings++startBatch :: (Eq a, Hashable a, MonadBaseControl IO m) => BatchingOptions -> MultiGetService m a b -> IORef (RequestBatch a b) -> m ()+startBatch options service ref = fmap (\_ -> ()) $ fork $ do+ threadDelay (1000 * batchWindowMs options)+ pendings <- atomicModifyIORef' ref (\p -> (emptyBatch, p))+ processCalls service pendings++addPending :: (Eq a, Hashable a, MonadBaseControl IO m) => BatchingOptions -> MultiGetService m a b -> IORef (RequestBatch a b) -> PendingRequest a b -> m ()+addPending options service ref p@(SingleRequest request _) = join $ atomicModifyIORef' ref (\(RequestBatch ps rs) -> (RequestBatch (p : ps) (S.insert request rs), if null ps then startBatch options service ref else return ()))+addPending options service ref p@(MultiRequest requests _) = join $ atomicModifyIORef' ref (\(RequestBatch ps rs) -> (RequestBatch (p : ps) (S.union rs requests), if null ps then startBatch options service ref else return ()))++singleService :: (Eq a, Hashable a, MonadBaseControl IO m) => BatchingOptions -> MultiGetService m a b -> IORef (RequestBatch a b) -> BasicService m a (Maybe b)+singleService options service ref request = do+ mvar <- newEmptyMVar+ let pending = SingleRequest request mvar+ addPending options service ref pending+ getResult mvar+multiService :: (Eq a, Hashable a, MonadBaseControl IO m) => BatchingOptions -> MultiGetService m a b -> IORef (RequestBatch a b) -> MultiGetService m a b+multiService options service ref requests = do+ mvar <- newEmptyMVar+ let pending = MultiRequest requests mvar+ addPending options service ref pending+ getResult mvar++-- | Function for constructing a batching service.+batchingService :: (Eq a, Hashable a, MonadBaseControl IO m, Applicative m, MonadBaseControl IO n)+ => BatchingOptions -- ^ Options to configure the batched service.+ -> MultiGetService m a b -- ^ Service around which to batch requests.+ -> n (BasicService m a (Maybe b), MultiGetService m a b)+batchingService options service = do+ ref <- newIORef emptyBatch+ return (singleService options service ref, multiService options service ref)
+ src/Glue/Caching.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Module supporting the caching of a service.+module Glue.Caching(+ cacheWithBasic+ , cacheWithMulti+) where++import Data.Hashable+import Glue.Types+import qualified Data.HashSet as S+import qualified Data.HashMap.Strict as M++-- | Caching of a `BasicService` instance, that defers to external functions for the actual caching.+-- | Note: Values within m will be lost for calls that hit the cache.+cacheWithBasic :: (Monad m) + => (a -> m (Maybe b)) -- ^ Cache lookup function, used before potentially invoking the fallback service.+ -> (a -> b -> m ()) -- ^ Cache write function, used after invoking the fallback service to populate the cache.+ -> BasicService m a b -- ^ The service to cache.+ -> BasicService m a b+cacheWithBasic lookupWith insertWith service = + let fallback request = do+ result <- service request+ insertWith request result+ return result + cachedService request = do+ fromCache <- lookupWith request+ maybe (fallback request) return fromCache+ in cachedService++-- | Caching of a `MultiGetService` instance, that defers to external functions for the actual caching.+-- | Partial responses will result in partial fallback calls that get just the missing keys.+-- | Values within m will be lost for calls that hit the cache.+cacheWithMulti :: (Monad m, Functor m, Eq a, Hashable a) + => ((MultiGetRequest a) -> m (MultiGetResponse a b)) -- ^ Cache lookup function, used before potentially invoking the fallback service.+ -> ((MultiGetResponse a b) -> m ()) -- ^ Cache write function, used after invoking the fallback service to populate the cache.+ -> MultiGetService m a b -- ^ The service to cache.+ -> MultiGetService m a b+cacheWithMulti lookupWith insertWith service = + let fallback request = do+ result <- service request+ insertWith result+ return result + cachedService request = do+ fromCache <- lookupWith request+ let uncachedKeys = S.difference request (S.fromList $ M.keys fromCache)+ if (S.null uncachedKeys) then (return fromCache) else (fmap (M.union fromCache) $ fallback uncachedKeys)+ in cachedService
+ src/Glue/CircuitBreaker.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveDataTypeable #-}++-- | Module containing circuit breaker functionality, which is the ability to open a circuit once a number of failures have occurred, thereby preventing later calls from attempting to make unsuccessful calls.+-- | Often this is useful if the underlying service were to repeatedly time out, so as to reduce the number of calls inflight holding up upstream callers.+module Glue.CircuitBreaker(+ CircuitBreakerOptions+ , CircuitBreakerStatus+ , CircuitBreakerException(..)+ , 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++-- | Options for determining behaviour of circuit breaking services.+data CircuitBreakerOptions = CircuitBreakerOptions {+ maxBreakerFailures :: Int -- ^ How many times the underlying service must fail in the given window before the circuit opens.+ , resetTimeoutSecs :: Int -- ^ The window of time in which the underlying service must fail for the circuit to open.+ , breakerDescription :: String -- ^ Description that is attached to the failure so as to identify the particular circuit.+}++-- | Defaulted options for the circuit breaker with 3 failures over 60 seconds.+defaultCircuitBreakerOptions :: CircuitBreakerOptions+defaultCircuitBreakerOptions = CircuitBreakerOptions { maxBreakerFailures = 3, resetTimeoutSecs = 60, breakerDescription = "Circuit breaker open." }++-- | Status indicating if the circuit is open.+data CircuitBreakerStatus = CircuitBreakerClosed Int | CircuitBreakerOpen Int++-- | Exception thrown when the circuit is open.+data CircuitBreakerException = CircuitBreakerException String deriving (Eq, Show, Typeable)+instance Exception CircuitBreakerException++-- TODO: Check that values within m aren't lost on a successful call.+-- | Circuit breaking services can be constructed with this function.+circuitBreaker :: (MonadBaseControl IO m, MonadBaseControl IO n) + => CircuitBreakerOptions -- ^ Options for specifying the circuit breaker behaviour.+ -> BasicService m a b -- ^ Service to protect with the circuit breaker.+ -> n (IORef CircuitBreakerStatus, BasicService m a b)+circuitBreaker options service = + let getCurrentTime = 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 $ CircuitBreakerClosed 0+ return result+ incErrors ref = do+ currentTime <- getCurrentTime+ atomicModifyIORef' ref $ \status -> case status of+ (CircuitBreakerClosed errorCount) -> (if errorCount >= failureMax then CircuitBreakerOpen (currentTime + (resetTimeoutSecs options)) else CircuitBreakerClosed (errorCount + 1), ())+ other -> (other, ())+ + failingCall = throw $ CircuitBreakerException $ breakerDescription options+ callIfOpen request ref = do+ currentTime <- getCurrentTime+ canaryRequest <- atomicModifyIORef' ref $ \status -> case status of + (CircuitBreakerClosed _) -> (status, False)+ (CircuitBreakerOpen time) -> if currentTime > time then ((CircuitBreakerOpen (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 + (CircuitBreakerClosed _) -> callIfClosed request ref+ (CircuitBreakerOpen _) -> callIfOpen request ref+ + in do+ ref <- newIORef $ CircuitBreakerClosed 0+ return (ref, breakerService ref)
+ src/Glue/DogpileProtection.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Module supporting the dogpile protection of a service, see <http://en.wikipedia.org/wiki/Cache_stampede http://en.wikipedia.org/wiki/Cache_stampede>.+module Glue.DogpileProtection(+ dogpileProtect+) where++import Control.Concurrent.Lifted+import Control.Exception.Lifted+import Control.Monad.Trans.Control+import Data.Hashable+import qualified Data.HashMap.Strict as M+import Data.IORef.Lifted+import Glue.Types++-- TODO: Should make this return just BasicService, hiding the HashMap.+-- | Dogpile protection of a service, to prevent multiple calls for the same value being submitted.+-- | Loses the values held within m.+dogpileProtect :: (MonadBaseControl IO m, MonadBaseControl IO n, Eq a, Hashable a) + => BasicService m a b -- ^ The service to protect.+ -> n (IORef (M.HashMap a (ResultVar b)), BasicService m a b)+dogpileProtect service = do+ mapRef <- newIORef M.empty+ let protectedService request = do+ firstRequestMVar <- newEmptyMVar + resultAction <- atomicModifyIORef' mapRef (\refMap -> + let removeFromMap = atomicModifyIORef' mapRef (\m -> (M.delete request m, ()))+ invokeService = do + result <- bracketOnError (return ()) (\_ -> removeFromMap) (\_ -> service request)+ putMVar firstRequestMVar $ Right result+ return result+ updateMap mvar = (M.insert request mvar refMap, getResult mvar)+ addToMap = (M.insert request firstRequestMVar refMap, invokeService)+ in maybe addToMap updateMap $ M.lookup request refMap)+ resultAction+ return (mapRef, protectedService)
+ src/Glue/Failover.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Module supporting failover of a service by transforming the request each time a failure occurs up to a fixed number of attempts.+module Glue.Failover(+ FailoverOptions+ , defaultFailoverOptions+ , failover+ , maxFailovers+ , transformFailoverRequest+) where++import Glue.Types+import Control.Exception.Lifted hiding(throw)+import Control.Monad.Trans.Control++-- | Options for determining behaviour of failover services.+data FailoverOptions a = FailoverOptions {+ maxFailovers :: Int -- ^ The maximum numer of times the service will failover and make another attempt.+ , transformFailoverRequest :: a -> a -- ^ Each time the service performs a failover, transform the request with this function.+}++-- | Simple defaults that results in retrying 3 times in a dumb way immediately without transforming the request.+defaultFailoverOptions :: FailoverOptions a+defaultFailoverOptions = FailoverOptions { maxFailovers = 3, transformFailoverRequest = id }++-- | Creates a service that can transform requests with each subsequent failure.+failover :: (MonadBaseControl IO m) + => FailoverOptions a -- ^ Instance of 'FailoverOptions' to configure the failover functionality.+ -> BasicService m a b -- ^ The service to perform failover around.+ -> BasicService m a b+failover options service =+ let invokeService failCount request = + let afterFail = (\(_ :: SomeException) -> invokeService (failCount + 1) ((transformFailoverRequest options) request))+ invoke = service request+ in if failCount >= (maxFailovers options) then invoke else catch invoke afterFail+ in invokeService 0
+ src/Glue/Preload.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RankNTypes #-}++-- | Module containing a form of caching where values for given keys are preloaded ahead of time.+-- | Once warmed up requests for preloaded keys will be instant, with the values refreshed in the background.+module Glue.Preload(+ PreloadedOptions+ , defaultPreloadedOptions+ , preloadingService+ , preloadedKeys+ , preloadingRefreshTimeMs+ , preloadingRun+) where++import Glue.Types+import Data.Hashable+import Data.Typeable+import qualified Data.HashSet as S+import qualified Data.HashMap.Strict as M+import Control.Concurrent.Lifted+import Control.Exception.Base hiding (throwIO)+import Control.Exception.Lifted+import Data.IORef.Lifted+import Control.Monad.Trans.Control+import Control.Monad.IO.Class++-- | Options for determining behaviour of preloading services.+data PreloadedOptions m a b = PreloadedOptions {+ preloadedKeys :: S.HashSet a, -- ^ Keys to preload.+ preloadingRefreshTimeMs :: Int, -- ^ Amount of time between refreshes.+ preloadingRun :: MToIO m -- ^ Get an IO of the response for the caching.+}++-- | Defaulted options for preloading a HashSet of keys with a 30 second refresh time.+defaultPreloadedOptions :: S.HashSet a -> MToIO m -> PreloadedOptions m a b+defaultPreloadedOptions toPreload pRun = PreloadedOptions {+ preloadedKeys = toPreload,+ preloadingRefreshTimeMs = 30 * 1000,+ preloadingRun = pRun+}++data PreloadedState a b = PreloadedStarted+ | PreloadedWithResult (FailOrSuccess a b) Bool++data PreloadStoppedBeforeExecutedException = PreloadStoppedBeforeExecutedException deriving (Eq, Show, Typeable)+instance Exception PreloadStoppedBeforeExecutedException++modifyStateWithResult :: forall a b . Either SomeException (MultiGetResponse a b) -> PreloadedState a b -> (PreloadedState a b, Bool)+modifyStateWithResult result PreloadedStarted = (PreloadedWithResult result True, True)+modifyStateWithResult result (PreloadedWithResult _ c) = (PreloadedWithResult result c, c)++applyResultToState :: forall m a b . MonadBaseControl IO m => IORef (PreloadedState a b) -> FailOrSuccess a b -> m Bool+applyResultToState stateRef result = atomicModifyIORef' stateRef $ modifyStateWithResult result++waitForResult :: forall m a b . (MonadBaseControl IO m) => IORef (PreloadedState a b) -> m (MultiGetResponse a b)+waitForResult stateRef = do+ state <- readIORef stateRef+ let tryAgainLater = threadDelay 1000 >> waitForResult stateRef+ case state of+ PreloadedStarted -> tryAgainLater+ PreloadedWithResult (Right success) _ -> return success+ PreloadedWithResult (Left failure) _ -> throwIO failure++markAsFinished :: PreloadedState a b -> (PreloadedState a b, ())+markAsFinished PreloadedStarted = (PreloadedWithResult (Left (SomeException PreloadStoppedBeforeExecutedException)) False, ())+markAsFinished (PreloadedWithResult r _) = (PreloadedWithResult r False, ())++-- | Preloads the results of calls for given keys.+preloadingService :: forall m n a b . (MonadIO m, MonadIO n, MonadBaseControl IO m, MonadBaseControl IO n, Eq a, Hashable a, Show a)+ => PreloadedOptions m a b -- ^ Instance of 'PreloadedOptions' to configure the preloading functionality.+ -> MultiGetService m a b -- ^ The service to perform preloading of.+ -> n (MultiGetService m a b, () -> n ())+preloadingService PreloadedOptions{..} service = do+ !stateIORef <- newIORef PreloadedStarted+ let stop _ = atomicModifyIORef' stateIORef markAsFinished+ let runUpdate = do+ result <- makeCall service preloadedKeys+ applyResultToState stateIORef result+ let updatePreloaded = do + continue <- liftIO $ preloadingRun $ runUpdate+ if continue then threadDelay (preloadingRefreshTimeMs * 1000) >> updatePreloaded else return ()+ let plService request = do+ let fromPreloadKeys = S.intersection request preloadedKeys+ let fromServiceKeys = S.difference request preloadedKeys+ !fromPreload <- if S.null fromPreloadKeys then return M.empty else fmap (M.filterWithKey (\k -> \_ -> S.member k fromPreloadKeys)) $ waitForResult stateIORef+ !fromService <- if S.null fromServiceKeys then return M.empty else service fromServiceKeys+ return $ M.union fromService fromPreload+ fork updatePreloaded+ return (plService, stop)
+ src/Glue/Retry.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveDataTypeable #-}++-- | Module containing retry functionality, allowing the construction of services that attempt multiple times in case of transient failure.+module Glue.Retry(+ RetryOptions+ , defaultRetryOptions+ , retryingService+ , retryAllowed+ , retryInitialWaitTimeMs+ , maximumRetries+ , retryWaitTimeMultiplier+) where++import Glue.Types+import Control.Concurrent.Lifted+import Control.Exception.Lifted+import Control.Monad.Trans.Control++-- | Options for determining behaviour of retrying services.+data RetryOptions a = RetryOptions {+ retryAllowed :: a -> Bool, -- ^ Predicate for determining if we can retry a call, can be used to prevent retries on non-idempotent operations.+ retryInitialWaitTimeMs :: Int, -- ^ Amount of time to wait after the first failure.+ maximumRetries :: Int, -- ^ The upper bound on how many attempts to make when invoking the service.+ retryWaitTimeMultiplier :: Double -- ^ How much to multiply 'retryInitialWaitTimeMs' by for each number of times the service has retried.+}++-- | Defaulted options for retrying 3 times with no wait time.+defaultRetryOptions :: RetryOptions a+defaultRetryOptions = RetryOptions {+ retryAllowed = (\_ -> True)+ , retryInitialWaitTimeMs = 0+ , maximumRetries = 3+ , retryWaitTimeMultiplier = 0+ }++-- | Retries a call to a service multiple times, potentially backing off wait times between subsequent calls.+retryingService :: (MonadBaseControl IO m)+ => RetryOptions a -- ^ Instance of 'RetryOptions' to configure the retry functionality.+ -> BasicService m a b -- ^ The service to perform retries of.+ -> BasicService m a b+retryingService options service =+ let attempt retryCount request = if (retryAllowed options) request && maxRetries > retryCount+ then catch (service request) (\(_ :: SomeException) -> (wait (retryCount + 1)) >> (attempt (retryCount + 1) request))+ else service request+ maxRetries = maximumRetries options+ wait retryCount = threadDelay $ round $ fromIntegral (retryInitialWaitTimeMs options) * ((retryWaitTimeMultiplier options) ^ retryCount)+ in attempt 0
+ src/Glue/Switching.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RecordWildCards #-}++-- | Module containing a switchable service, allowing the possibility of changing+-- | a service "live".+module Glue.Switching(+ switchingService+) where++import Glue.Types+import Control.Monad.Base+import Data.IORef.Lifted++-- | Provides a switchable service.+switchingService :: (MonadBase IO m, MonadBase IO n) => MultiGetService m a b -- ^ The service to initialise the switching service with.+ -> n (MultiGetService m a b, (MultiGetService m a b) -> n ())+switchingService service = do+ !serviceRef <- newIORef service+ let switching rs = do+ serviceToUse <- readIORef serviceRef+ serviceToUse rs+ let switchingUpdate newService = writeIORef serviceRef newService+ return (switching, switchingUpdate)
+ src/Glue/Timeout.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveDataTypeable #-}++-- | Module supporting adding timeouts to a given service.+module Glue.Timeout(+ TimeoutOptions+ , TimeoutException(..)+ , defaultTimeoutOptions+ , addTimeout+ , timeoutDescription+ , timeoutLimitMs+) where++import Data.Typeable+import Glue.Types+import Control.Concurrent.Lifted+import Control.Exception.Lifted+import Control.Monad.Trans.Control++-- | Options for determining behaviour of services with a timeout.+data TimeoutOptions = TimeoutOptions {+ timeoutDescription :: String -- ^ Description added to the 'TimeoutException' thrown when the timeout is exceeded.+ , timeoutLimitMs :: Int -- ^ Timeout in milliseconds.+}++-- | Default instance of 'TimeoutOptions' with a timeout of 30 seconds.+defaultTimeoutOptions :: TimeoutOptions+defaultTimeoutOptions = TimeoutOptions { timeoutDescription = "Service call timed out.", timeoutLimitMs = 30000 }++-- | Exception thrown when the timeout is exceeded.+data TimeoutException = TimeoutException String deriving (Eq, Show, Typeable)+instance Exception TimeoutException++-- | Function for producing services protected with a timeout.+addTimeout :: (MonadBaseControl IO m)+ => TimeoutOptions -- ^ Options to configure the timeout.+ -> BasicService m a b -- ^ Service to protect with a timeout.+ -> BasicService m a b+addTimeout options service = (\request -> do+ currentThreadId <- myThreadId+ timeoutThreadId <- fork $ do+ threadDelay (1000 * timeoutLimitMs options)+ throwTo currentThreadId (TimeoutException $ timeoutDescription options)+ finally (service request) (killThread timeoutThreadId))
+ test/Glue/BatcherSpec.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, ScopedTypeVariables #-}++module Glue.BatcherSpec where++import Control.Concurrent.Async+import qualified Data.HashSet as S+import qualified Data.HashMap.Strict as M+import Glue.Batcher+import Glue.Types+import Test.Hspec+import Test.QuickCheck++spec :: Spec+spec = do+ describe "batchingService" $ do+ it "Requests should receive their full results" $ do+ property $ \(requests :: [[Int]]) -> do+ let requestsAsSets = fmap (S.fromList) requests+ let serviceFunctionality rs = M.fromList $ fmap (\r -> (r, r * 2)) $ S.toList rs+ let service = (return . serviceFunctionality) :: MultiGetService IO Int Int+ (_, multiService) <- batchingService defaultBatchingOptions service+ let expectedResults = fmap serviceFunctionality requestsAsSets+ (mapConcurrently multiService requestsAsSets) `shouldReturn` expectedResults+
+ test/Glue/CachingSpec.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, ScopedTypeVariables #-}++module Glue.CachingSpec where++import Data.Typeable+import Glue.Caching+import Glue.Types+import Test.QuickCheck.Instances()+import Test.Hspec+import Data.IORef+import Test.QuickCheck+import Control.Exception.Base hiding (throw, throwIO)+import Control.Exception.Lifted+import qualified Data.HashSet as S+import qualified Data.HashMap.Strict as M++data CachingTestException = CachingTestException Int deriving (Eq, Show, Typeable)+instance Exception CachingTestException++type TestResp = MultiGetResponse Int Int++spec :: Spec+spec = do+ describe "cacheWithBasic" $ do+ it "For a second request, the value comes from the cache" $ do+ property $ \(request :: Int, result :: Int) -> do+ ref <- newIORef (0 :: Int)+ let service req = do+ if req == request then return () else throwIO (CachingTestException (-1))+ callCount <- atomicModifyIORef' ref (\c -> (c + 1, c + 1))+ if callCount > 1 then throwIO (CachingTestException callCount) else return result+ cache <- newIORef M.empty+ let lookupWith r = fmap (M.lookup r) $ readIORef cache+ let insertWith req resp = atomicModifyIORef' cache (\c -> (M.insert req resp c, ()))+ let cachedService = cacheWithBasic lookupWith insertWith service+ (cachedService request) `shouldReturn` result+ (cachedService request) `shouldReturn` result+ describe "cacheWithMulti" $ do+ it "For a second request, the value comes from the cache" $ do+ property $ \(result :: TestResp) -> do+ let request = S.fromList $ M.keys result+ ref <- newIORef (0 :: Int)+ let service req = do+ if req == request then return () else throwIO (CachingTestException (-1))+ callCount <- atomicModifyIORef' ref (\c -> (c + 1, c + 1))+ if callCount > 1 then throwIO (CachingTestException callCount) else return result+ cache <- newIORef M.empty+ let lookupWith rs = fmap (M.filterWithKey (\k -> \_ -> S.member k rs)) $ readIORef cache+ let insertWith resp = atomicModifyIORef' cache (\c -> (M.union resp c, ()))+ let cachedService = cacheWithMulti lookupWith insertWith service+ (cachedService request) `shouldReturn` result+ (cachedService request) `shouldReturn` result+ it "Merges the cached values as appropriate from subsequent requests" $ do+ property $ \(first :: TestResp, second :: TestResp, both :: TestResp) -> do+ let uniqueFirst = M.difference first (M.union second both)+ let uniqueSecond = M.difference second (M.union first both)+ let uniqueBoth = M.difference both (M.union first second)+ let uniqueAll = M.union uniqueFirst $ M.union uniqueSecond uniqueBoth+ let firstResult = M.union uniqueFirst uniqueBoth+ let secondResult = M.union uniqueSecond uniqueBoth+ let firstRequest = S.fromList $ M.keys firstResult+ let secondRequest = S.fromList $ M.keys secondResult+ ref <- newIORef (0 :: Int)+ let service req = do+ callCount <- atomicModifyIORef' ref (\c -> (c + 1, c + 1))+ if callCount > 2 then throwIO (CachingTestException callCount) else return $ M.filterWithKey (\k -> \_ -> S.member k req) uniqueAll+ cache <- newIORef M.empty+ let lookupWith rs = fmap (M.filterWithKey (\k -> \_ -> S.member k rs)) $ readIORef cache+ let insertWith resp = atomicModifyIORef' cache (\c -> (M.union resp c, ()))+ let cachedService = cacheWithMulti lookupWith insertWith service+ (cachedService firstRequest) `shouldReturn` firstResult+ (cachedService secondRequest) `shouldReturn` secondResult+ (cachedService firstRequest) `shouldReturn` firstResult+ (cachedService secondRequest) `shouldReturn` secondResult++
+ test/Glue/CircuitBreakerSpec.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, ScopedTypeVariables #-}++module Glue.CircuitBreakerSpec where++import Data.Traversable+import Data.Typeable+import Glue.CircuitBreaker+import Test.Hspec+import Data.IORef+import Test.QuickCheck+import Control.Exception.Base hiding (throw, throwIO, try)+import Control.Exception.Lifted++data CircuitBreakerTestException = CircuitBreakerTestException deriving (Eq, Show, Typeable)+instance Exception CircuitBreakerTestException++requests :: [Int]+requests = [1..10]++spec :: Spec+spec = do+ describe "circuitBreaker" $ do+ it "Multiple failures prevent subsequent calls" $ do+ property $ \failureMax -> do+ let positiveFailureMax = (abs failureMax) `mod` 5+ let options = defaultCircuitBreakerOptions { maxBreakerFailures = positiveFailureMax }+ ref <- newIORef (0 :: Int)+ let service _ = atomicModifyIORef' ref (\c -> (c + 1, ())) >> throwIO CircuitBreakerTestException :: IO Int+ (_, circuitBreakerService) <- circuitBreaker options service+ results <- traverse (\req -> try $ try $ circuitBreakerService req) requests :: IO [Either CircuitBreakerException (Either CircuitBreakerTestException Int)]+ let expectedResults = (replicate (positiveFailureMax + 1) (Right $ Left $ CircuitBreakerTestException)) ++ (replicate (10 - positiveFailureMax - 1) (Left $ CircuitBreakerException "Circuit breaker open."))+ results `shouldBe` expectedResults+ (readIORef ref) `shouldReturn` (positiveFailureMax + 1)+ ++
+ test/Glue/DogpileProtectionSpec.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, ScopedTypeVariables #-}++module Glue.DogpileProtectionSpec where++import Data.Traversable+import Data.Typeable+import Glue.DogpileProtection+import Test.Hspec+import Data.IORef+import Control.Concurrent+import Control.Concurrent.Async+import Control.Exception.Base hiding (throw, throwIO)+import Control.Exception.Lifted+import Prelude hiding (sequence)++data DogpileProtectionTestException = DogpileProtectionTestException deriving (Eq, Show, Typeable)+instance Exception DogpileProtectionTestException++requests :: [Int]+requests = take 10 $ repeat 1++delayTime :: Int+delayTime = 1000 * 1000++spec :: Spec+spec = do+ describe "dogpileProtect" $ do+ it "With multiple calls to a slow service only one actually gets through" $ do+ counter <- newIORef (0 :: Int)+ let service request = atomicModifyIORef' counter (\n -> (n + 1, ())) >> threadDelay delayTime >> return (request * 2)+ (_, protectedService) <- dogpileProtect service+ asyncResults <- traverse (async . protectedService) requests+ let results = traverse wait asyncResults+ results `shouldReturn` (fmap (*2) requests)+ (readIORef counter) `shouldReturn` 1+ it "With multiple calls to a slow failing service only one actually gets through" $ do+ counter <- newIORef (0 :: Int)+ let service _ = atomicModifyIORef' counter (\n -> (n + 1, ())) >> threadDelay delayTime >> throwIO DogpileProtectionTestException :: IO Int+ (_, protectedService) <- dogpileProtect service+ asyncResults <- traverse (async . protectedService) requests+ let results = traverse wait asyncResults+ results `shouldThrow` (== DogpileProtectionTestException)+ (readIORef counter) `shouldReturn` 1 ++
+ test/Glue/FailoverSpec.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}++module Glue.FailoverSpec where++import Data.Typeable+import Glue.Failover+import Test.Hspec+import Test.QuickCheck+import Control.Exception.Base hiding (throw, throwIO)+import Control.Exception.Lifted++data FailoverTestException = FailoverTestException deriving (Eq, Show, Typeable)+instance Exception FailoverTestException++spec :: Spec+spec = do+ describe "failover" $ do+ it "Failover handles potentially multiple errors" $ do+ property $ \(request, failureMax) ->+ let positiveFailureMax = (abs failureMax) `mod` 10+ service req = if req >= 10 then return (req + 100) else throwIO FailoverTestException + options = defaultFailoverOptions { transformFailoverRequest = (+1), maxFailovers = positiveFailureMax }+ failOverService = failover options service+ successCase = (failOverService request) `shouldReturn` ((if request <= 10 then 10 else request) + 100)+ failureCase = (failOverService request) `shouldThrow` (== FailoverTestException)+ in if request + positiveFailureMax >= 10 then successCase else failureCase
+ test/Glue/PreloadSpec.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, ScopedTypeVariables #-}++module Glue.PreloadSpec where++import qualified Data.HashSet as S+import qualified Data.HashMap.Strict as M+import Glue.Preload+import Glue.Types+import Test.Hspec+import Test.QuickCheck+import Test.QuickCheck.Instances()+import Control.Exception.Base+import Data.Typeable++serviceFunctionality :: MultiGetRequest Int -> MultiGetResponse Int Int+serviceFunctionality rs = M.fromList $ fmap (\r -> (r, r * 2)) $ S.toList rs++failingService :: MultiGetRequest Int -> IO (MultiGetResponse Int Int)+failingService _ = throwIO PreloadTestException++data PreloadTestException = PreloadTestException deriving (Eq, Show, Typeable)+instance Exception PreloadTestException++handler :: SomeException -> IO (M.HashMap Int Int)+handler e = print e >> return M.empty++spec :: Spec+spec = do+ describe "preloadingService" $ do+ it "Requests should work the same regardless of whether or not parts are preloaded" $ do+ property $ \(preload :: S.HashSet Int, nonPreload :: S.HashSet Int) -> do+ let service = (return . serviceFunctionality) :: MultiGetService IO Int Int+ (preloadedService, disable) <- preloadingService (defaultPreloadedOptions preload id) service+ let expectedResults = serviceFunctionality (S.union preload nonPreload)+ actualResults <- preloadedService (S.union preload nonPreload)+ disable ()+ actualResults `shouldBe` expectedResults+ it "Exceptions should propagate" $ do+ property $ \(preload :: S.HashSet Int, nonPreload :: S.HashSet Int) -> do+ (preloadedService, _) <- preloadingService (defaultPreloadedOptions preload id) failingService+ let expectedResults = serviceFunctionality (S.union preload nonPreload)+ let goodPath = preloadedService (S.union preload nonPreload) `shouldReturn` expectedResults+ let badPath = preloadedService (S.union preload nonPreload) `shouldThrow` (== PreloadTestException)+ if (S.null preload && S.null nonPreload) then goodPath else badPath
+ test/Glue/RetrySpec.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-}++module Glue.RetrySpec where++import Data.IORef+import Data.Typeable+import Glue.Retry+import Test.Hspec+import Test.QuickCheck+import Control.Exception.Base hiding (throw, throwIO)+import Control.Exception.Lifted+import Control.Monad.IO.Class++newtype SmallInt = SmallInt Int deriving (Eq, Show)++instance Arbitrary SmallInt where+ arbitrary = sized $ \s -> do+ n <- choose (0, s `min` 10)+ return $ SmallInt n++data RetryTestException = RetryTestException deriving (Eq, Show, Typeable)+instance Exception RetryTestException++spec :: Spec+spec = do+ describe "retryingService" $ do+ it "Attempts a service call multiple times" $ do+ property $ \(request, (SmallInt failures), (SmallInt retries)) -> + do+ ref <- liftIO $ newIORef 0+ let service req = do+ counter <- atomicModifyIORef' ref (\c -> (c + 1, c + 1))+ if counter > failures then return req else throwIO RetryTestException+ let options = defaultRetryOptions { maximumRetries = retries }+ let retryService = retryingService options service+ let successCase = (retryService request) `shouldReturn` (request :: Int)+ let failureCase = (retryService request) `shouldThrow` (== RetryTestException)+ if retries >= failures then successCase else failureCase
+ test/Glue/Testing.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, ScopedTypeVariables #-}++module Glue.Testing where++import Data.Hashable+import Test.QuickCheck+import qualified Data.HashSet as S+import qualified Data.HashMap.Strict as M
+ test/Glue/TimeoutSpec.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-}++module Glue.TimeoutSpec where++import Glue.Timeout+import Test.Hspec+import Test.QuickCheck+import Control.Concurrent++timeoutOptions :: TimeoutOptions+timeoutOptions = defaultTimeoutOptions { timeoutLimitMs = 10 }++spec :: Spec+spec = do+ describe "addTimeout" $ do+ it "Services taking too long should fail with a timeout" $ do+ property $ \request ->+ let service req = (if req > 0 then return () else threadDelay (100 * 1000)) >> return (req + 100) + timeoutService = addTimeout timeoutOptions service+ successCase = (timeoutService request) `shouldReturn` (request + 100)+ failureCase = (timeoutService request) `shouldThrow` (== TimeoutException(timeoutDescription timeoutOptions))+ in if request > (0 :: Int) then successCase else failureCase
+ test/Main.hs view
@@ -0,0 +1,14 @@+module Main where++import Test.Hspec.Runner+import qualified Spec++customConfig :: Config+customConfig = defaultConfig + { configColorMode = ColorAlways+ , configPrintCpuTime = True+ }+++main :: IO ()+main = hspecWith customConfig Spec.spec
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}