packages feed

glue-core 0.6.1 → 0.6.2

raw patch · 22 files changed

+210/−212 lines, 22 filessetup-changed

Files

Setup.hs view
glue-core.cabal view
@@ -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
src/Glue/Batcher.hs view
@@ -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 {
src/Glue/Caching.hs view
@@ -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)
src/Glue/CircuitBreaker.hs view
@@ -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)
src/Glue/DogpileProtection.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleContexts #-}+{-# 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>.@@ -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
src/Glue/Failover.hs view
@@ -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
src/Glue/Preload.hs view
@@ -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.
src/Glue/Retry.hs view
@@ -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 {
src/Glue/Switching.hs view
@@ -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.
src/Glue/Timeout.hs view
@@ -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.
test/Glue/BatcherSpec.hs view
@@ -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
test/Glue/CachingSpec.hs view
@@ -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
test/Glue/CircuitBreakerSpec.hs view
@@ -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
test/Glue/DogpileProtectionSpec.hs view
@@ -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  
test/Glue/FailoverSpec.hs view
@@ -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
test/Glue/PreloadSpec.hs view
@@ -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)
test/Glue/RetrySpec.hs view
@@ -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
test/Glue/SwitchingSpec.hs view
@@ -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
− test/Glue/Testing.hs 
@@ -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
test/Glue/TimeoutSpec.hs view
@@ -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
test/Main.hs view
@@ -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   }