glue 0.1.1.0 → 0.1.1.1

raw patch · 11 files changed

+359/−3 lines, 11 filesdep ~ekg-corePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: ekg-core

API changes (from Hackage documentation)

Files

• glue.cabal +12/−3
• test/Glue/BatcherSpec.hs +24/−0
• test/Glue/CachingSpec.hs +76/−0
• test/Glue/CircuitBreakerSpec.hs +36/−0
• test/Glue/DogpileProtectionSpec.hs +45/−0
• test/Glue/FailoverSpec.hs +28/−0
• test/Glue/RetrySpec.hs +38/−0
• test/Glue/StatsSpec.hs +69/−0
• test/Glue/Testing.hs +8/−0
• test/Glue/TimeoutSpec.hs +22/−0
• test/Spec.hs +1/−0

@@ -1,5 +1,5 @@ name:                   glue-version:                0.1.1.0+version:                0.1.1.1 synopsis:               Make better services. description:            Implements common patterns used in building services that run smoothly and efficiently. license:                BSD3@@ -26,7 +26,6 @@                         Glue.Retry                         Glue.Batcher                         Glue.Stats-  -- other-modules:   -- other-extensions:   build-depends:        base >=4.6 && <4.9,                         transformers,@@ -36,7 +35,7 @@                         monad-control,                         unordered-containers,                         hashable,-                        ekg-core,+                        ekg-core >=0.1.0.4 && <1,                         text   ghc-options:          -rtsopts                         -Wall@@ -76,6 +75,16 @@                         ekg-core,                         text,                         async+  other-modules:        Glue.CachingSpec+                        Glue.FailoverSpec+                        Glue.RetrySpec+                        Glue.DogpileProtectionSpec+                        Glue.Testing+                        Glue.TimeoutSpec+                        Glue.StatsSpec+                        Glue.CircuitBreakerSpec+                        Glue.BatcherSpec+                        Spec   ghc-options:          -rtsopts                         -Wall                         -O2

@@ -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+

@@ -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++

@@ -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)+        ++

@@ -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        ++

@@ -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 

@@ -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

@@ -0,0 +1,69 @@+{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, ScopedTypeVariables #-}++module Glue.StatsSpec where++import Data.Int+import Data.Typeable+import Glue.Stats+import Glue.Types+import Test.QuickCheck.Instances()+import Test.Hspec+import Data.Text+import Test.QuickCheck+import Control.Exception.Base hiding (throw, throwIO)+import Control.Exception.Lifted+import System.Metrics+import qualified System.Metrics.Distribution as MD+import qualified Data.HashMap.Strict as M++data StatsTestException = StatsTestException deriving (Eq, Show, Typeable)+instance Exception StatsTestException++data MetricsResult = CounterResult Int64+                   | GaugeResult Int64+                   | LabelResult Text+                   | DistributionResult Int64+                    deriving (Eq, Show)++checkResult :: Store -> Text -> (MetricsResult -> Expectation) -> Expectation+checkResult store name check = do+  allMetrics <- sampleAll store+  let possibleValue = M.lookup name allMetrics+  result <- case possibleValue of+                (Just (Counter counterCount)) -> return $ CounterResult counterCount+                (Just (Gauge value))          -> return $ GaugeResult value+                (Just (Label text))           -> return $ LabelResult text+                (Just (Distribution stats))   -> return $ DistributionResult $ MD.count stats+                Nothing                       -> fail "No metric."+  check result++testStats :: String -> +            (Store -> Text -> BasicService IO Int Int -> IO (BasicService IO Int Int)) ->+            (Int -> Int -> MetricsResult -> Expectation) ->+            (Int -> Int -> MetricsResult -> Expectation) ->+            Spec+testStats methodName method successCheck failureCheck = +  describe methodName $ do+    it "Successful call" $ do+      property $ \(request :: Int, result :: Int, name :: Text) -> do+        let service _ = return result :: IO Int+        store <- newStore+        wrappedService <- method store name service :: IO (BasicService IO Int Int)+        (wrappedService request) `shouldReturn` result+        checkResult store name $ successCheck request result+    it "Failing call" $ do+      property $ \(request :: Int, result :: Int, name :: Text) -> do+        let service _ = throwIO StatsTestException :: IO Int+        store <- newStore+        wrappedService <- method store name service :: IO (BasicService IO Int Int)+        (wrappedService request) `shouldThrow` (== StatsTestException)+        checkResult store name $ failureCheck request result++spec :: Spec+spec = parallel $ do+  testStats "recordDistribution" recordDistribution (\_ -> \_ -> \m -> m `shouldBe` (DistributionResult 1)) (\_ -> \_ -> \m -> m `shouldBe` (DistributionResult 1))+  testStats "recordAttempts" recordAttempts (\_ -> \_ -> \m -> m `shouldBe` (CounterResult 1)) (\_ -> \_ -> \m -> m `shouldBe` (CounterResult 1))+  testStats "recordSuccesses" recordSuccesses (\_ -> \_ -> \m -> m `shouldBe` (CounterResult 1)) (\_ -> \_ -> \m -> m `shouldBe` (CounterResult 0))+  testStats "recordFailures" recordFailures (\_ -> \_ -> \m -> m `shouldBe` (CounterResult 0)) (\_ -> \_ -> \m -> m `shouldBe` (CounterResult 1))+  testStats "recordLastRequest" recordLastRequest (\r -> \_ -> \m -> m `shouldBe` (LabelResult $ pack $ show r)) (\r -> \_ -> \m -> m `shouldBe` (LabelResult $ pack $ show r))+  testStats "recordLastResult" recordLastResult (\_ -> \r -> \m -> m `shouldBe` (LabelResult $ pack $ show r)) (\_ -> \_ -> \m -> m `shouldBe` (LabelResult ""))

@@ -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

@@ -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 

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}