glue-ekg 0.6.3 → 0.7.0

raw patch · 4 files changed

+195/−169 lines, 4 filesdep +unliftiodep −asyncdep −hashabledep −lifted-basedep ~basedep ~glue-commonsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: unliftio

Dependencies removed: async, hashable, lifted-base, monad-control, transformers, transformers-base

Dependency ranges changed: base, glue-common

API changes (from Hackage documentation)

Files

• Setup.hs +0/−2
• glue-ekg.cabal +60/−57
• src/Glue/Ekg.hs +100/−76
• test/Glue/EkgSpec.hs +35/−34

@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain

@@ -1,63 +1,66 @@-name:                   glue-ekg-version:                0.6.3-synopsis:               Make better services and clients.-description:            Glue library that makes use of ekg for providing stats around services and clients.-license:                BSD3-license-file:           LICENSE-author:                 Sean Parsons-maintainer:             github@futurenotfound.com-category:               Network-build-type:             Simple-cabal-version:          >=1.10+cabal-version:      3.0+name:               glue-ekg+version:            0.7.0+synopsis:           Make better services and clients.+description:        Glue library that makes use of ekg for providing stats around services and clients.+license:            BSD-3-Clause+license-file:       LICENSE+author:             Sean Parsons+maintainer:         github@futurenotfound.com+category:           Network+build-type:         Simple+tested-with:        GHC == 9.6.7, GHC == 9.8.4, GHC == 9.10.3, GHC == 9.12.3  source-repository head-  type:                 git-  location:             git://github.com/seanparsons/glue.git+  type:     git+  location: https://github.com/seanparsons/glue.git +common common-options+  default-language: Haskell2010+  ghc-options:+    -Wall+    -Wcompat+    -Widentities+    -Wincomplete-record-updates+    -Wincomplete-uni-patterns+    -Wmissing-home-modules+    -Wpartial-fields+    -Wredundant-constraints+ library-  exposed-modules:      Glue.Ekg-  -- other-extensions:-  build-depends:        base >=4.6 && <5,-                        glue-common ==0.6.3,-                        transformers,-                        transformers-base,-                        lifted-base,-                        time,-                        monad-control,-                        unordered-containers,-                        hashable,-                        ekg-core,-                        text-  ghc-options:          -Wall-  hs-source-dirs:       src-  default-language:     Haskell2010+  import:          common-options+  hs-source-dirs:  src+  exposed-modules: Glue.Ekg+  build-depends:+    , base        >= 4.16 && < 5+    , ekg-core+    , glue-common ^>= 0.7.0+    , text+    , time+    , unliftio    >= 0.2  test-suite glue-ekg-tests-  build-depends:        base >=4.6 && <5,-                        glue-common ==0.6.3,-                        glue-ekg,-                        QuickCheck -any,-                        quickcheck-instances,-                        hspec,-                        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-  build-tools:          hspec-discover-  type:                 exitcode-stdio-1.0-  main-is:              Main.hs-  buildable:            True-  default-language:     Haskell2010-  hs-source-dirs:       test+  import:             common-options+  type:               exitcode-stdio-1.0+  hs-source-dirs:     test+  main-is:            Main.hs+  other-modules:+    Glue.EkgSpec+    Spec+  build-tool-depends: hspec-discover:hspec-discover+  ghc-options:+    -threaded+    -rtsopts+    -with-rtsopts=-N+    -O2+  build-depends:+    , base                  >= 4.16 && < 5+    , ekg-core+    , glue-common           ^>= 0.7.0+    , glue-ekg+    , hspec+    , QuickCheck+    , quickcheck-instances+    , text+    , unliftio              >= 0.2+    , unordered-containers

@@ -2,108 +2,132 @@ {-# LANGUAGE ScopedTypeVariables #-}  -- | Module supporting the recording of various stats about a service using "System.Metrics".-module Glue.Ekg(-    recordDistribution+module Glue.Ekg+  ( recordDistribution   , recordAttempts   , recordSuccesses   , recordFailures   , recordLastRequest   , recordLastResult-) where+  ) where -import           Control.Exception.Lifted-import           Control.Monad.Base-import           Control.Monad.Trans.Control-import           Data.Text-import           Data.Time.Clock.POSIX+import           Data.Text                   (Text, pack)+import           Data.Time.Clock.POSIX       (getPOSIXTime) import           Glue.Types-import           System.Metrics+import           System.Metrics              (Store, createCounter,+                                              createDistribution, createLabel) import qualified System.Metrics.Counter      as MC import qualified System.Metrics.Distribution as MD import qualified System.Metrics.Label        as ML+import           UnliftIO                    (MonadIO, MonadUnliftIO, liftIO)+import           UnliftIO.Exception          (finally, onException) -currentTime :: (MonadBaseControl IO m) => m Double+currentTime :: MonadIO m => m Double currentTime = do-                time <- liftBase $ getPOSIXTime-                return $ realToFrac time+  time <- liftIO getPOSIXTime+  pure $ 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)+-- | Record the timings for service invocations with a 'MD.Distribution' held in the passed in 'Store'.+recordDistribution+  :: (MonadUnliftIO m, MonadIO n)+  => Store+  -- ^ 'Store' where the 'MD.Distribution' will reside.+  -> Text+  -- ^ The name to associate the 'MD.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+  dist <- liftIO $ 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+        before <- currentTime+        let recordTime = do+              after <- currentTime+              liftIO $ MD.add dist (after - before)+        finally (service req) recordTime+  pure 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)+-- | Increments a counter with a 'MC.Counter' held in the passed in 'Store' for each time the service is called.+recordAttempts+  :: (MonadIO m, MonadIO n)+  => Store+  -- ^ 'Store' where the 'MC.Counter' will reside.+  -> Text+  -- ^ The name to associate the 'MC.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+  counter <- liftIO $ createCounter name store   let countedService req = do-                              liftBase $ MC.inc counter-                              service req-  return countedService+        liftIO $ MC.inc counter+        service req+  pure 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)+-- | Increments a counter with a 'MC.Counter' held in the passed in 'Store' for each time the service successfully returns.+recordSuccesses+  :: (MonadIO m, MonadIO n)+  => Store+  -- ^ 'Store' where the 'MC.Counter' will reside.+  -> Text+  -- ^ The name to associate the 'MC.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+  counter <- liftIO $ createCounter name store   let countedService req = do-                              result <- service req-                              liftBase $ MC.inc counter-                              return result-  return countedService+        result <- service req+        liftIO $ MC.inc counter+        pure result+  pure 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)+-- | Increments a counter with a 'MC.Counter' held in the passed in 'Store' for each time the service fails.+recordFailures+  :: (MonadUnliftIO m, MonadIO n)+  => Store+  -- ^ 'Store' where the 'MC.Counter' will reside.+  -> Text+  -- ^ The name to associate the 'MC.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+  counter <- liftIO $ createCounter name store+  let countedService req = onException (service req) (liftIO $ MC.inc counter)+  pure 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)+-- | Sets a 'ML.Label' held in the passed in 'Store' for each request the service receives.+recordLastRequest+  :: (MonadIO m, MonadIO n, Show a)+  => Store+  -- ^ 'Store' where the 'ML.Label' will reside.+  -> Text+  -- ^ The name to associate the 'ML.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+  label <- liftIO $ createLabel name store   let requestRecordingService req = do-                                      liftBase $ ML.set label $ pack $ show req-                                      service req-  return requestRecordingService+        liftIO $ ML.set label $ pack $ show req+        service req+  pure 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)+-- | Sets a 'ML.Label' held in the passed in 'Store' for each successful result the service returns.+recordLastResult+  :: (MonadIO m, MonadIO n, Show b)+  => Store+  -- ^ 'Store' where the 'ML.Label' will reside.+  -> Text+  -- ^ The name to associate the 'ML.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+  label <- liftIO $ createLabel name store   let resultRecordingService req = do-                                      result <- service req-                                      liftBase $ ML.set label $ pack $ show result-                                      return result-  return resultRecordingService+        result <- service req+        liftIO $ ML.set label $ pack $ show result+        pure result+  pure resultRecordingService

@@ -1,15 +1,11 @@-{-# LANGUAGE DeriveDataTypeable  #-} {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-} -module Glue.EkgSpec where+module Glue.EkgSpec (spec) where -import           Control.Exception.Base      hiding (throw, throwIO)-import           Control.Exception.Lifted import qualified Data.HashMap.Strict         as M-import           Data.Int-import           Data.Text-import           Data.Typeable+import           Data.Int                    (Int64)+import           Data.Text                   (Text, pack) import           Glue.Ekg import           Glue.Types import           System.Metrics@@ -17,55 +13,60 @@ import           Test.Hspec import           Test.QuickCheck import           Test.QuickCheck.Instances   ()+import           UnliftIO.Exception          (Exception, throwIO) -data EkgTestException = EkgTestException deriving (Eq, Show, Typeable)+data EkgTestException = EkgTestException+  deriving (Eq, Show)+ instance Exception EkgTestException -data MetricsResult = CounterResult Int64-                   | GaugeResult Int64-                   | LabelResult Text-                   | DistributionResult Int64-                    deriving (Eq, Show)+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."+    Just (Counter counterCount) -> pure $ CounterResult counterCount+    Just (Gauge value)          -> pure $ GaugeResult value+    Just (Label text)           -> pure $ LabelResult text+    Just (Distribution stats)   -> pure $ 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+  :: 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+    it "Successful call" $       property $ \(request :: Int, result :: Int, name :: Text) -> do-        let service _ = return result :: IO Int+        let service _ = pure result :: IO Int         store <- newStore         wrappedService <- method store name service :: IO (BasicService IO Int Int)-        (wrappedService request) `shouldReturn` result+        wrappedService request `shouldReturn` result         checkResult store name $ successCheck request result-    it "Failing call" $ do+    it "Failing call" $       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)+        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 ""))+  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 "")