glue-ekg (empty) → 0.4.1
raw patch · 7 files changed
+288/−0 lines, 7 filesdep +QuickCheckdep +asyncdep +basesetup-changed
Dependencies added: QuickCheck, async, base, ekg-core, glue-common, hashable, hspec, lifted-base, monad-control, quickcheck-instances, text, time, transformers, transformers-base, unordered-containers
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- glue-ekg.cabal +63/−0
- src/Glue/Ekg.hs +109/−0
- test/Glue/EkgSpec.hs +69/−0
- test/Main.hs +14/−0
- test/Spec.hs +1/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Sean Parsons++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Sean Parsons nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ glue-ekg.cabal view
@@ -0,0 +1,63 @@+name: glue-ekg+version: 0.4.1+synopsis: Make better services.+description: Glue library that makes use of ekg for providing stats around 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.Ekg+ -- other-extensions:+ build-depends: base >=4.6 && <4.9,+ glue-common ==0.4.1,+ transformers,+ transformers-base,+ lifted-base,+ time,+ monad-control,+ unordered-containers,+ hashable,+ ekg-core,+ text+ ghc-options: -rtsopts+ -Wall+ hs-source-dirs: src+ default-language: Haskell2010++test-suite glue-ekg-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.EkgSpec+ Spec+ ghc-options: -rtsopts+ -Wall+ -O2+ -threaded+ type: exitcode-stdio-1.0+ main-is: Main.hs+ buildable: True+ default-language: Haskell2010+ hs-source-dirs: test,+ src
+ src/Glue/Ekg.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Module supporting the recording of various stats about a service using "System.Metrics".+module Glue.Ekg(+ recordDistribution+ , recordAttempts+ , recordSuccesses+ , recordFailures+ , recordLastRequest+ , recordLastResult+) where++import Control.Exception.Lifted+import Control.Monad.Base+import Data.Text+import Data.Time.Clock.POSIX+import Glue.Types+import Control.Monad.Trans.Control+import System.Metrics+import qualified System.Metrics.Distribution as MD+import qualified System.Metrics.Counter as MC+import qualified System.Metrics.Label as ML++currentTime :: (MonadBaseControl IO m) => m Double+currentTime = do+ time <- liftBase $ getPOSIXTime+ return $ realToFrac time++-- | Record the timings for service invocations with a 'Distribution' held in the passed in 'Store'..+recordDistribution :: (MonadBaseControl IO m, MonadBaseControl IO n)+ => Store -- ^ 'Store' where the 'Distribution' will reside.+ -> Text -- ^ The name to associate the 'Distribution' with.+ -> BasicService m a b -- ^ Base service to record stats for.+ -> n (BasicService m a b)+recordDistribution store name service = do+ dist <- liftBase $ createDistribution name store+ let timedService req = do+ before <- currentTime+ let recordTime = do+ after <- currentTime+ liftBase $ MD.add dist (after - before)+ finally (service req) recordTime+ return timedService++-- | Increments a counter with a 'Counter' held in the passed in 'Store' for each time the service is called.+recordAttempts :: (MonadBaseControl IO m, MonadBaseControl IO n)+ => Store -- ^ 'Store' where the 'Counter' will reside.+ -> Text -- ^ The name to associate the 'Counter' with.+ -> BasicService m a b -- ^ Base service to record stats for.+ -> n (BasicService m a b)+recordAttempts store name service = do+ counter <- liftBase $ createCounter name store+ let countedService req = do+ liftBase $ MC.inc counter+ service req+ return countedService++-- | Increments a counter with a 'Counter' held in the passed in 'Store' for each time the service successfully returns.+recordSuccesses :: (MonadBaseControl IO m, MonadBaseControl IO n)+ => Store -- ^ 'Store' where the 'Counter' will reside.+ -> Text -- ^ The name to associate the 'Counter' with.+ -> BasicService m a b -- ^ Base service to record stats for.+ -> n (BasicService m a b)+recordSuccesses store name service = do+ counter <- liftBase $ createCounter name store+ let countedService req = do+ result <- service req+ liftBase $ MC.inc counter+ return result+ return countedService++-- | Increments a counter with a 'Counter' held in the passed in 'Store' for each time the service fails.+recordFailures :: (MonadBaseControl IO m, MonadBaseControl IO n)+ => Store -- ^ 'Store' where the 'Counter' will reside.+ -> Text -- ^ The name to associate the 'Counter' with.+ -> BasicService m a b -- ^ Base service to record stats for.+ -> n (BasicService m a b)+recordFailures store name service = do+ counter <- liftBase $ createCounter name store+ let countedService req = onException (service req) (liftBase $ MC.inc counter)+ return countedService++-- | Sets a 'Label' held in the passed in 'Store' for each request the service receives.+recordLastRequest :: (MonadBaseControl IO m, MonadBaseControl IO n, Show a)+ => Store -- ^ 'Store' where the 'Label' will reside.+ -> Text -- ^ The name to associate the 'Label' with.+ -> BasicService m a b -- ^ Base service to record stats for.+ -> n (BasicService m a b)+recordLastRequest store name service = do+ label <- liftBase $ createLabel name store+ let requestRecordingService req = do+ liftBase $ ML.set label $ pack $ show req+ service req+ return requestRecordingService++-- | Sets a 'Label' held in the passed in 'Store' for each successful result the service returns.+recordLastResult :: (MonadBaseControl IO m, MonadBaseControl IO n, Show b)+ => Store -- ^ 'Store' where the 'Label' will reside.+ -> Text -- ^ The name to associate the 'Label' with.+ -> BasicService m a b -- ^ Base service to record stats for.+ -> n (BasicService m a b)+recordLastResult store name service = do+ label <- liftBase $ createLabel name store+ let resultRecordingService req = do+ result <- service req+ liftBase $ ML.set label $ pack $ show result+ return result+ return resultRecordingService
+ test/Glue/EkgSpec.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, ScopedTypeVariables #-}++module Glue.EkgSpec where++import Data.Int+import Data.Typeable+import Glue.Ekg+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 EkgTestException = EkgTestException deriving (Eq, Show, Typeable)+instance Exception EkgTestException++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 EkgTestException :: IO Int+ store <- newStore+ wrappedService <- method store name service :: IO (BasicService IO Int Int)+ (wrappedService request) `shouldThrow` (== EkgTestException)+ 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 ""))
+ test/Main.hs view
@@ -0,0 +1,14 @@+module Main where++import Test.Hspec.Runner+import qualified Spec++customConfig :: Config+customConfig = defaultConfig + { configColorMode = ColorAlways+ , configPrintCpuTime = True+ }+++main :: IO ()+main = hspecWith customConfig Spec.spec
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}