diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Changelog for monad-metrics-extensible +## v. 0.1.1.0 + +Add some utility types and functions: `Timestamp`, `Timer`, `timed`. + ## v. 0.1.0.1 A very brief documentation in README diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,10 @@ # monad-metrics-extensible +[![Build Status][travis-badge]][travis] +[![Hackage][hackage-badge]][hackage] +[![Stackage LTS][stackage-lts-badge]][stackage-lts] +[![Stackage Nightly][stackage-nightly-badge]][stackage-nightly] + ## tl;dr This library simplifies using [ekg](http://hackage.haskell.org/package/ekg) @@ -16,7 +21,7 @@ (hence "extensible" one more time). You want a combined distribution + counter? No prob! -`import System.Metrics.Extensible` is your entry point of choice! +`System.Metrics.Extensible` is your entry point of choice! ## A quick example @@ -36,19 +41,19 @@ AnotherCounter :: SomeMetrics Counter "other_counter" SomeGauge :: SomeMetrics Gauge "some_gauge" ``` -The string literals is what will be shown via ekg UI. +The string literals are what will be shown via ekg UI. There is a couple of requirements: * The type shall be of the kind `* -> Symbol -> *`. * The first type argument (`Counter` and `Gauge` in the example above) shall be an instance of `TrackerLike`. All ekg counters are already - an instance of this class. -* The type shall be comparable, hence we shall also do -```haskell -deriving instance Eq (SomeMetrics ty name) -deriving instance Ord (SomeMetrics ty name) -``` + instances of this class. +* The type shall be comparable, hence we also do + ```haskell + deriving instance Eq (SomeMetrics ty name) + deriving instance Ord (SomeMetrics ty name) + ``` Then we can write our small program! @@ -67,5 +72,16 @@ the metrics. * `track` is the function that's responsible for updating the metrics. Its arguments depend on the specific metric that's being tracked: - for instance, `Counter`s have no arguments, while `Gauge`s accept + for instance, as can be seen in the example above, + `Counter`s have no arguments, while `Gauge`s accept the corresponding new value. + + +[travis]: +[travis-badge]: +[hackage]: +[hackage-badge]: +[stackage-lts-badge]: +[stackage-nightly-badge]: +[stackage-lts]: +[stackage-nightly]: diff --git a/monad-metrics-extensible.cabal b/monad-metrics-extensible.cabal --- a/monad-metrics-extensible.cabal +++ b/monad-metrics-extensible.cabal @@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.0. +-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack -- --- hash: 79c192bfb089d6da408408ac335a54cc76caffb9f9520888b58754d4981712fe +-- hash: 69ea4201ba5699f3590e46f8f9ef0a986f900c2f2b489840763c7e2b26c42394 name: monad-metrics-extensible -version: 0.1.0.1 +version: 0.1.1.0 synopsis: An extensible and type-safe wrapper around EKG metrics description: Please see the README on GitHub at category: Web @@ -31,6 +31,7 @@ exposed-modules: Data.Dyn System.Metrics.Extensible + System.Metrics.ExtraTrackers System.Metrics.Monad System.Metrics.Monad.Class System.Metrics.Store @@ -50,6 +51,7 @@ , mtl , stm , text + , time default-language: Haskell2010 test-suite monad-metrics-extensible-test @@ -72,4 +74,5 @@ , mtl , stm , text + , time default-language: Haskell2010 diff --git a/src/System/Metrics/ExtraTrackers.hs b/src/System/Metrics/ExtraTrackers.hs new file mode 100644 --- /dev/null +++ b/src/System/Metrics/ExtraTrackers.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE TypeFamilies, DataKinds, ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} + +module System.Metrics.ExtraTrackers +( Timestamp + +, TimerMagnitude(..) +, Timer(..) +, timed +) where + +import qualified Data.Text as T +import Control.Monad.IO.Class +import Data.Proxy +import Data.Time.Clock.POSIX +import Data.Typeable +import GHC.TypeLits +import System.CPUTime +import System.Metrics +import System.Metrics.Distribution as TD +import System.Metrics.Label as TL + +import System.Metrics.Extensible + +newtype Timestamp = Timestamp Label + +instance TrackerLike Timestamp where + type TrackAction Timestamp m = m () + track metric = do + Timestamp l <- getTracker metric + liftIO $ do + utc <- getCurrentTime + TL.set l $ T.pack $ show utc + createTracker name store = Timestamp <$> createLabel name store + + +newtype Timer (magn :: TimerMagnitude) = Timer { getTimerDistribution :: Distribution } + +data TimerMagnitude = Msecs | Usecs | Nsecs deriving (Typeable) + +class MagnitudeOps (magn :: TimerMagnitude) where + toString :: Proxy magn -> T.Text + secFraction :: Proxy magn -> Double + +instance MagnitudeOps 'Msecs where + toString _ = "ms" + secFraction _ = 1e-3 + +instance MagnitudeOps 'Usecs where + toString _ = "us" + secFraction _ = 1e-6 + +instance MagnitudeOps 'Nsecs where + toString _ = "ns" + secFraction _ = 1e-9 + +instance (Typeable magn, MagnitudeOps magn) => TrackerLike (Timer magn) where + type TrackAction (Timer magn) m = Double -> m () + track metric timing = do + Timer timer <- getTracker metric + liftIO $ TD.add timer timing + createTracker name store = Timer <$> createDistribution (name <> "_" <> toString (Proxy :: Proxy magn)) store + +-- Returns the number of picoseconds +time :: MonadIO m => m a -> m (Integer, a) +time act = do + start <- liftIO getCPUTime + res <- act + end <- liftIO getCPUTime + pure (end - start, res) + +timed :: forall m metric magn name a. + (MonadMetrics m, KnownSymbol name, Typeable metric, Typeable magn, MagnitudeOps magn, Ord (metric (Timer magn) name)) + => metric (Timer magn) name + -> m a + -> m a +timed metric act = do + (cpuTime, res) <- time act + track metric $ fromIntegral cpuTime / (1e12 * secFraction (Proxy :: Proxy magn)) + pure res diff --git a/src/System/Metrics/Store.hs b/src/System/Metrics/Store.hs --- a/src/System/Metrics/Store.hs +++ b/src/System/Metrics/Store.hs @@ -14,6 +14,7 @@ import Control.Concurrent import Control.Concurrent.STM.TQueue import Control.Monad.Catch +import Control.Monad.IO.Class import Control.Monad.Identity import Control.Monad.STM import Data.GADT.Compare @@ -62,11 +63,11 @@ newtype MetricsStore = MetricsStore { mReqQueue :: TQueue MetricRequest } -newMetricsStore :: Server -> IO (MetricsStore, IO ()) -newMetricsStore srv = do +newMetricsStore :: MonadIO m => Server -> m (MetricsStore, m ()) +newMetricsStore srv = liftIO $ do queue <- newTQueueIO threadId <- forkIO $ act queue $ MetricsState srv mempty - pure (MetricsStore queue, killThread threadId) + pure (MetricsStore queue, liftIO $ killThread threadId) where act queue state = do req <- atomically (readTQueue queue) @@ -89,7 +90,7 @@ putMVar mvar tracker pure state' -withMetricsStore :: Server -> (MetricsStore -> IO a) -> IO a +withMetricsStore :: (MonadIO m, MonadMask m) => Server -> (MetricsStore -> m a) -> m a withMetricsStore srv f = bracket (newMetricsStore srv) snd diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -2,28 +2,41 @@ {-# LANGUAGE OverloadedStrings, StandaloneDeriving #-} import Control.Monad.IO.Class +import Data.Functor +import System.CPUTime import System.Metrics.Counter as TC(read) +import System.Metrics.Distribution as TD(read, sum, count) import System.Metrics.Gauge as TG(read) import System.Remote.Monitoring import Test.Hspec import System.Metrics.Extensible +import System.Metrics.ExtraTrackers data TestMetrics ty name where - Foo1 :: TestMetrics Counter "foo1" - Foo2 :: TestMetrics Counter "foo2" - Bar :: TestMetrics Gauge "bar" + Foo1 :: TestMetrics Counter "foo1" + Foo2 :: TestMetrics Counter "foo2" + Bar :: TestMetrics Gauge "bar" + TimeMS :: TestMetrics (Timer 'Msecs) "timeMS" deriving instance Eq (TestMetrics ty name) deriving instance Ord (TestMetrics ty name) data OtherMetrics ty name where - Baz :: OtherMetrics Counter "foo1" - Quux :: OtherMetrics Gauge "bar" + Baz :: OtherMetrics Counter "other-foo1" + Quux :: OtherMetrics Gauge "other-bar" deriving instance Eq (OtherMetrics ty name) deriving instance Ord (OtherMetrics ty name) +cpuThreadDelay :: Int -> IO () +cpuThreadDelay usecs | usecs < 0 = pure () + | otherwise = do + start <- getCPUTime + void $ readFile "/dev/null" + end <- getCPUTime + cpuThreadDelay $ usecs - fromIntegral ((end - start) `div` 1000000) + main :: IO () main = do ekgServer <- forkServer "localhost" 21000 @@ -34,6 +47,7 @@ track Bar 10 track Bar 20 track Baz + timed TimeMS $ liftIO $ cpuThreadDelay testMicroseconds track Quux 42 liftIO $ hspec $ do describe "Counters are stored as expected" $ do @@ -43,3 +57,15 @@ describe "Gauges are stored as expected" $ do it "The final value of Bar is kept" $ (getMetricFromStore store Bar >>= TG.read) `shouldReturn` 20 it "Metrics from other type are also saved" $ (getMetricFromStore store Quux >>= TG.read) `shouldReturn` 42 + describe "Timers are stored and computed as expected" $ do + it "TimeMS has only seen one value" $ do + storedStats <- getMetricFromStore store TimeMS >>= TD.read . getTimerDistribution + TD.count storedStats `shouldBe` 1 + it "The value of TimeMS exceeds the wait time" $ do + storedStats <- getMetricFromStore store TimeMS >>= TD.read . getTimerDistribution + TD.sum storedStats `shouldSatisfy` (>= (fromIntegral testMicroseconds / 1000)) + it "…but not too much" $ do + storedStats <- getMetricFromStore store TimeMS >>= TD.read . getTimerDistribution + TD.sum storedStats `shouldSatisfy` (< 1000 * (fromIntegral testMicroseconds / 1000)) + where + testMicroseconds = 10000