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/glue-core.cabal b/glue-core.cabal new file mode 100644 --- /dev/null +++ b/glue-core.cabal @@ -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 diff --git a/src/Glue/Batcher.hs b/src/Glue/Batcher.hs new file mode 100644 --- /dev/null +++ b/src/Glue/Batcher.hs @@ -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) diff --git a/src/Glue/Caching.hs b/src/Glue/Caching.hs new file mode 100644 --- /dev/null +++ b/src/Glue/Caching.hs @@ -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 diff --git a/src/Glue/CircuitBreaker.hs b/src/Glue/CircuitBreaker.hs new file mode 100644 --- /dev/null +++ b/src/Glue/CircuitBreaker.hs @@ -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) diff --git a/src/Glue/DogpileProtection.hs b/src/Glue/DogpileProtection.hs new file mode 100644 --- /dev/null +++ b/src/Glue/DogpileProtection.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Module supporting the dogpile protection of a service, see . +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) diff --git a/src/Glue/Failover.hs b/src/Glue/Failover.hs new file mode 100644 --- /dev/null +++ b/src/Glue/Failover.hs @@ -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 diff --git a/src/Glue/Preload.hs b/src/Glue/Preload.hs new file mode 100644 --- /dev/null +++ b/src/Glue/Preload.hs @@ -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) diff --git a/src/Glue/Retry.hs b/src/Glue/Retry.hs new file mode 100644 --- /dev/null +++ b/src/Glue/Retry.hs @@ -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 diff --git a/src/Glue/Switching.hs b/src/Glue/Switching.hs new file mode 100644 --- /dev/null +++ b/src/Glue/Switching.hs @@ -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) diff --git a/src/Glue/Timeout.hs b/src/Glue/Timeout.hs new file mode 100644 --- /dev/null +++ b/src/Glue/Timeout.hs @@ -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)) diff --git a/test/Glue/BatcherSpec.hs b/test/Glue/BatcherSpec.hs new file mode 100644 --- /dev/null +++ b/test/Glue/BatcherSpec.hs @@ -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 + diff --git a/test/Glue/CachingSpec.hs b/test/Glue/CachingSpec.hs new file mode 100644 --- /dev/null +++ b/test/Glue/CachingSpec.hs @@ -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 + + diff --git a/test/Glue/CircuitBreakerSpec.hs b/test/Glue/CircuitBreakerSpec.hs new file mode 100644 --- /dev/null +++ b/test/Glue/CircuitBreakerSpec.hs @@ -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) + + + diff --git a/test/Glue/DogpileProtectionSpec.hs b/test/Glue/DogpileProtectionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Glue/DogpileProtectionSpec.hs @@ -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 + + diff --git a/test/Glue/FailoverSpec.hs b/test/Glue/FailoverSpec.hs new file mode 100644 --- /dev/null +++ b/test/Glue/FailoverSpec.hs @@ -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 diff --git a/test/Glue/PreloadSpec.hs b/test/Glue/PreloadSpec.hs new file mode 100644 --- /dev/null +++ b/test/Glue/PreloadSpec.hs @@ -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 diff --git a/test/Glue/RetrySpec.hs b/test/Glue/RetrySpec.hs new file mode 100644 --- /dev/null +++ b/test/Glue/RetrySpec.hs @@ -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 diff --git a/test/Glue/Testing.hs b/test/Glue/Testing.hs new file mode 100644 --- /dev/null +++ b/test/Glue/Testing.hs @@ -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 diff --git a/test/Glue/TimeoutSpec.hs b/test/Glue/TimeoutSpec.hs new file mode 100644 --- /dev/null +++ b/test/Glue/TimeoutSpec.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}