diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs diff --git a/glue-core.cabal b/glue-core.cabal --- a/glue-core.cabal +++ b/glue-core.cabal @@ -1,5 +1,5 @@ name: glue-core -version: 0.6.1 +version: 0.6.2 synopsis: Make better services and clients. description: Combinator library to enhance the general functionality of services and clients. license: BSD3 @@ -60,7 +60,6 @@ Glue.FailoverSpec Glue.RetrySpec Glue.DogpileProtectionSpec - Glue.Testing Glue.TimeoutSpec Glue.CircuitBreakerSpec Glue.BatcherSpec diff --git a/src/Glue/Batcher.hs b/src/Glue/Batcher.hs --- a/src/Glue/Batcher.hs +++ b/src/Glue/Batcher.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Module for creating a service that batches calls across requests. @@ -9,17 +9,16 @@ , 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 +import Control.Concurrent.Lifted +import Control.Exception.Lifted +import Control.Monad +import Control.Monad.Trans.Control +import Data.Foldable +import Data.Hashable +import qualified Data.HashMap.Strict as M +import qualified Data.HashSet as S +import Data.IORef.Lifted +import Glue.Types -- | Options for configuring the batching. data BatchingOptions = BatchingOptions { diff --git a/src/Glue/Caching.hs b/src/Glue/Caching.hs --- a/src/Glue/Caching.hs +++ b/src/Glue/Caching.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Module supporting the caching of a service. @@ -7,23 +7,23 @@ , cacheWithMulti ) where -import Data.Hashable -import Glue.Types -import qualified Data.HashSet as S +import Data.Hashable import qualified Data.HashMap.Strict as M +import qualified Data.HashSet as S +import Glue.Types -- | 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) +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 = +cacheWithBasic lookupWith insertWith service = let fallback request = do result <- service request insertWith request result - return result + return result cachedService request = do fromCache <- lookupWith request maybe (fallback request) return fromCache @@ -32,16 +32,16 @@ -- | 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) +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 = +cacheWithMulti lookupWith insertWith service = let fallback request = do result <- service request insertWith result - return result + return result cachedService request = do fromCache <- lookupWith request let uncachedKeys = S.difference request (S.fromList $ M.keys fromCache) diff --git a/src/Glue/CircuitBreaker.hs b/src/Glue/CircuitBreaker.hs --- a/src/Glue/CircuitBreaker.hs +++ b/src/Glue/CircuitBreaker.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# 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. @@ -18,22 +18,19 @@ , breakerDescription ) where -import Data.Foldable hiding (or, and) -import Data.Traversable -import Data.Monoid -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 +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. + 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. @@ -56,13 +53,13 @@ -- | Determines if a specific status is open. isStatusOpen :: BreakerStatus -> Bool -isStatusOpen (BreakerOpen _) = True -isStatusOpen (BreakerClosed _) = False +isStatusOpen (BreakerOpen _) = True +isStatusOpen (BreakerClosed _) = False -- | Determines if a specific status is closed. isStatusClosed :: BreakerStatus -> Bool -isStatusClosed (BreakerOpen _) = False -isStatusClosed (BreakerClosed _) = True +isStatusClosed (BreakerOpen _) = False +isStatusClosed (BreakerClosed _) = True -- | Determines if a circuit breaker is open. isCircuitBreakerOpen :: (MonadBaseControl IO m) => CircuitBreakerState -> m Bool @@ -74,12 +71,12 @@ -- 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) +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 (CircuitBreakerState, BasicService m a b) -circuitBreaker options service = - let getCurrentTime = liftBase $ round `fmap` getPOSIXTime +circuitBreaker options service = + let retrieveTime = liftBase $ round `fmap` getPOSIXTime failureMax = maxBreakerFailures options callIfClosed request ref = bracketOnError (return ()) (\_ -> incErrors ref) (\_ -> service request) canaryCall request ref = do @@ -87,25 +84,23 @@ writeIORef ref $ BreakerClosed 0 return result incErrors ref = do - currentTime <- getCurrentTime + currentTime <- retrieveTime atomicModifyIORef' ref $ \status -> case status of (BreakerClosed errorCount) -> (if errorCount >= failureMax then BreakerOpen (currentTime + (resetTimeoutSecs options)) else BreakerClosed (errorCount + 1), ()) other -> (other, ()) - failingCall = throw $ CircuitBreakerException $ breakerDescription options callIfOpen request ref = do - currentTime <- getCurrentTime - canaryRequest <- atomicModifyIORef' ref $ \status -> case status of + currentTime <- retrieveTime + canaryRequest <- atomicModifyIORef' ref $ \status -> case status of (BreakerClosed _) -> (status, False) (BreakerOpen time) -> if currentTime > time then ((BreakerOpen (currentTime + (resetTimeoutSecs options))), True) else (status, False) - if canaryRequest then canaryCall request ref else failingCall breakerService ref request = do status <- readIORef ref - case status of + case status of (BreakerClosed _) -> callIfClosed request ref (BreakerOpen _) -> callIfOpen request ref - + in do ref <- newIORef $ BreakerClosed 0 return (CircuitBreakerState [ref], breakerService ref) diff --git a/src/Glue/DogpileProtection.hs b/src/Glue/DogpileProtection.hs --- a/src/Glue/DogpileProtection.hs +++ b/src/Glue/DogpileProtection.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Module supporting the dogpile protection of a service, see . @@ -6,12 +6,12 @@ dogpileProtect ) where -import Control.Concurrent -import Control.Exception -import Data.Hashable +import Control.Concurrent +import Control.Exception +import Data.Hashable import qualified Data.HashMap.Strict as M -import Data.IORef -import Glue.Types +import Data.IORef +import Glue.Types data DogpileResult b = CachedValue (Either SomeException b) | RequestInProgress (IO b) @@ -22,7 +22,7 @@ getDogpileResult :: DogpileResult b -> IO b getDogpileResult (RequestInProgress requestWait) = requestWait -getDogpileResult (CachedValue result) = either throw return result +getDogpileResult (CachedValue result) = either throw return result waitForMVar :: MVar (Either SomeException b) -> IO b waitForMVar mvar = do diff --git a/src/Glue/Failover.hs b/src/Glue/Failover.hs --- a/src/Glue/Failover.hs +++ b/src/Glue/Failover.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# 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. @@ -10,14 +10,14 @@ , transformFailoverRequest ) where -import Glue.Types -import Control.Exception.Lifted hiding(throw) -import Control.Monad.Trans.Control +import Control.Exception.Lifted hiding (throw) +import Control.Monad.Trans.Control +import Glue.Types -- | 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. + 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. @@ -25,12 +25,12 @@ defaultFailoverOptions = FailoverOptions { maxFailovers = 3, transformFailoverRequest = id } -- | Creates a service that can transform requests with each subsequent failure. -failover :: (MonadBaseControl IO m) +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 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 diff --git a/src/Glue/Preload.hs b/src/Glue/Preload.hs --- a/src/Glue/Preload.hs +++ b/src/Glue/Preload.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# 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. @@ -17,24 +17,24 @@ , preloadingRun ) where -import Data.Maybe -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 +import Control.Concurrent.Lifted +import Control.Exception.Base hiding (throwIO) +import Control.Exception.Lifted +import Control.Monad.IO.Class +import Control.Monad.Trans.Control +import Data.Hashable +import qualified Data.HashMap.Strict as M +import qualified Data.HashSet as S +import Data.IORef.Lifted +import Data.Maybe +import Data.Typeable +import Glue.Types -- | 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. + 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. @@ -91,7 +91,7 @@ !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 + _ <- fork updatePreloaded return (plService, stop) -- | Preloads a single parameter-less call. diff --git a/src/Glue/Retry.hs b/src/Glue/Retry.hs --- a/src/Glue/Retry.hs +++ b/src/Glue/Retry.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# 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( @@ -13,10 +13,10 @@ , retryWaitTimeMultiplier ) where -import Glue.Types -import Control.Concurrent.Lifted -import Control.Exception.Lifted -import Control.Monad.Trans.Control +import Control.Concurrent.Lifted +import Control.Exception.Lifted +import Control.Monad.Trans.Control +import Glue.Types -- | Options for determining behaviour of retrying services. data RetryOptions a = RetryOptions { diff --git a/src/Glue/Switching.hs b/src/Glue/Switching.hs --- a/src/Glue/Switching.hs +++ b/src/Glue/Switching.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE RecordWildCards #-} -- | Module containing a switchable service, allowing the possibility of changing -- | a service "live". @@ -10,9 +10,9 @@ switchingService ) where -import Glue.Types -import Control.Monad.Base -import Data.IORef.Lifted +import Control.Monad.Base +import Data.IORef.Lifted +import Glue.Types -- | Provides a switchable service. switchingService :: (MonadBase IO m, MonadBase IO n) => MultiGetService m a b -- ^ The service to initialise the switching service with. diff --git a/src/Glue/Timeout.hs b/src/Glue/Timeout.hs --- a/src/Glue/Timeout.hs +++ b/src/Glue/Timeout.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveDataTypeable #-} -- | Module supporting adding timeouts to a given service. module Glue.Timeout( @@ -12,16 +12,16 @@ , timeoutLimitMs ) where -import Data.Typeable -import Glue.Types -import Control.Concurrent.Lifted -import Control.Exception.Lifted -import Control.Monad.Trans.Control +import Control.Concurrent.Lifted +import Control.Exception.Lifted +import Control.Monad.Trans.Control +import Data.Typeable +import Glue.Types -- | 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. + 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. diff --git a/test/Glue/BatcherSpec.hs b/test/Glue/BatcherSpec.hs --- a/test/Glue/BatcherSpec.hs +++ b/test/Glue/BatcherSpec.hs @@ -1,14 +1,16 @@ -{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE 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 +import Control.Concurrent.Async +import qualified Data.HashMap.Strict as M +import qualified Data.HashSet as S +import Glue.Batcher +import Glue.Types +import Test.Hspec +import Test.QuickCheck spec :: Spec spec = do diff --git a/test/Glue/CachingSpec.hs b/test/Glue/CachingSpec.hs --- a/test/Glue/CachingSpec.hs +++ b/test/Glue/CachingSpec.hs @@ -1,18 +1,20 @@ -{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE 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 +import Control.Exception.Base hiding (throw, throwIO) +import Control.Exception.Lifted +import qualified Data.HashMap.Strict as M +import qualified Data.HashSet as S +import Data.IORef +import Data.Typeable +import Glue.Caching +import Glue.Types +import Test.Hspec +import Test.QuickCheck +import Test.QuickCheck.Instances () data CachingTestException = CachingTestException Int deriving (Eq, Show, Typeable) instance Exception CachingTestException diff --git a/test/Glue/CircuitBreakerSpec.hs b/test/Glue/CircuitBreakerSpec.hs --- a/test/Glue/CircuitBreakerSpec.hs +++ b/test/Glue/CircuitBreakerSpec.hs @@ -1,15 +1,16 @@ -{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE 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 +import Control.Exception.Base hiding (throw, throwIO, try) +import Control.Exception.Lifted +import Data.IORef +import Data.Typeable +import Glue.CircuitBreaker +import Test.Hspec +import Test.QuickCheck data CircuitBreakerTestException = CircuitBreakerTestException deriving (Eq, Show, Typeable) instance Exception CircuitBreakerTestException @@ -34,13 +35,13 @@ (isCircuitBreakerClosed s) `shouldReturn` False (readIORef ref) `shouldReturn` (positiveFailureMax + 1) it "Successful calls pass straight through" $ do - property $ \(failureMax :: Int, requests :: [Int]) -> do + property $ \(failureMax :: Int, requestIDs :: [Int]) -> do let positiveFailureMax = abs failureMax let options = defaultCircuitBreakerOptions { maxBreakerFailures = positiveFailureMax } let service req = return $ req + 1 (s, circuitBreakerService) <- circuitBreaker options service - results <- traverse (\req -> circuitBreakerService req) requests - let expectedResults = fmap (+ 1) requests + results <- traverse (\req -> circuitBreakerService req) requestIDs + let expectedResults = fmap (+ 1) requestIDs results `shouldBe` expectedResults (isCircuitBreakerOpen s) `shouldReturn` False (isCircuitBreakerClosed s) `shouldReturn` True diff --git a/test/Glue/DogpileProtectionSpec.hs b/test/Glue/DogpileProtectionSpec.hs --- a/test/Glue/DogpileProtectionSpec.hs +++ b/test/Glue/DogpileProtectionSpec.hs @@ -1,17 +1,19 @@ -{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE 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) +import Control.Concurrent +import Control.Concurrent.Async +import Control.Exception.Base hiding (throw, throwIO) +import Control.Exception.Lifted +import Data.IORef +import Data.Traversable +import Data.Typeable +import Glue.DogpileProtection +import Prelude hiding (sequence) +import Test.Hspec data DogpileProtectionTestException = DogpileProtectionTestException deriving (Eq, Show, Typeable) instance Exception DogpileProtectionTestException @@ -28,7 +30,7 @@ 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 + protectedService <- dogpileProtect service asyncResults <- traverse (async . protectedService) requests let results = traverse wait asyncResults results `shouldReturn` (fmap (*2) requests) @@ -36,10 +38,10 @@ 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 + protectedService <- dogpileProtect service asyncResults <- traverse (async . protectedService) requests let results = traverse wait asyncResults results `shouldThrow` (== DogpileProtectionTestException) - (readIORef counter) `shouldReturn` 1 + (readIORef counter) `shouldReturn` 1 diff --git a/test/Glue/FailoverSpec.hs b/test/Glue/FailoverSpec.hs --- a/test/Glue/FailoverSpec.hs +++ b/test/Glue/FailoverSpec.hs @@ -1,15 +1,15 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} 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 +import Control.Exception.Base hiding (throw, throwIO) +import Control.Exception.Lifted +import Data.Typeable +import Glue.Failover +import Test.Hspec +import Test.QuickCheck data FailoverTestException = FailoverTestException deriving (Eq, Show, Typeable) instance Exception FailoverTestException @@ -20,9 +20,9 @@ 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 + 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 + in if request + positiveFailureMax >= 10 then successCase else failureCase diff --git a/test/Glue/PreloadSpec.hs b/test/Glue/PreloadSpec.hs --- a/test/Glue/PreloadSpec.hs +++ b/test/Glue/PreloadSpec.hs @@ -1,16 +1,18 @@ -{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE 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 +import Control.Exception.Base +import qualified Data.HashMap.Strict as M +import qualified Data.HashSet as S +import Data.Typeable +import Glue.Preload +import Glue.Types +import Test.Hspec +import Test.QuickCheck +import Test.QuickCheck.Instances () serviceFunctionality :: MultiGetRequest Int -> MultiGetResponse Int Int serviceFunctionality rs = M.fromList $ fmap (\r -> (r, r * 2)) $ S.toList rs @@ -54,5 +56,5 @@ actualResults `shouldBe` 12 it "Exceptions should propagate" $ do property $ do - (preloadedCall, disable) <- preloadingCall id 1000 failingCall + (preloadedCall, _) <- preloadingCall id 1000 failingCall preloadedCall `shouldThrow` (== PreloadTestException) diff --git a/test/Glue/RetrySpec.hs b/test/Glue/RetrySpec.hs --- a/test/Glue/RetrySpec.hs +++ b/test/Glue/RetrySpec.hs @@ -1,16 +1,17 @@ -{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} module Glue.RetrySpec where -import Control.Concurrent -import Data.IORef -import Data.Typeable -import Glue.Retry -import Test.Hspec -import Test.QuickCheck -import Control.Exception.Base hiding (throw, throwIO, throwTo) -import Control.Exception.Lifted hiding (throwTo) -import Control.Monad.IO.Class +import Control.Concurrent +import Control.Exception.Base hiding (throw, throwIO, throwTo) +import Control.Exception.Lifted hiding (throwTo) +import Control.Monad.IO.Class +import Data.IORef +import Data.Typeable +import Glue.Retry +import Test.Hspec +import Test.QuickCheck newtype SmallInt = SmallInt Int deriving (Eq, Show) @@ -38,7 +39,7 @@ let failureCase = (retryService request) `shouldThrow` (== RetryTestException) if retries >= failures then successCase else failureCase it "Asynchronous exceptions are rethrown" $ do - property $ \(request, retries) -> + property $ \(request, retries) -> do ref <- liftIO $ newIORef (0 :: Int) let service req = do diff --git a/test/Glue/SwitchingSpec.hs b/test/Glue/SwitchingSpec.hs --- a/test/Glue/SwitchingSpec.hs +++ b/test/Glue/SwitchingSpec.hs @@ -1,12 +1,14 @@ -{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Glue.SwitchingSpec where -import Glue.Switching -import Glue.Types -import Test.Hspec -import Test.QuickCheck -import Test.QuickCheck.Instances() +import Glue.Switching +import Glue.Types +import Test.Hspec +import Test.QuickCheck +import Test.QuickCheck.Instances () spec :: Spec spec = do diff --git a/test/Glue/Testing.hs b/test/Glue/Testing.hs deleted file mode 100644 --- a/test/Glue/Testing.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# 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 --- a/test/Glue/TimeoutSpec.hs +++ b/test/Glue/TimeoutSpec.hs @@ -1,11 +1,12 @@ -{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} module Glue.TimeoutSpec where -import Glue.Timeout -import Test.Hspec -import Test.QuickCheck -import Control.Concurrent +import Control.Concurrent +import Glue.Timeout +import Test.Hspec +import Test.QuickCheck timeoutOptions :: TimeoutOptions timeoutOptions = defaultTimeoutOptions { timeoutLimitMs = 10 } @@ -15,8 +16,8 @@ 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) + 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 + in if request > (0 :: Int) then successCase else failureCase diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,10 +1,10 @@ module Main where -import Test.Hspec.Runner import qualified Spec +import Test.Hspec.Runner customConfig :: Config -customConfig = defaultConfig +customConfig = defaultConfig { configColorMode = ColorAlways , configPrintCpuTime = True }