monad-metrics-extensible (empty) → 0.1.0.0

raw patch · 12 files changed

+416/−0 lines, 12 filesdep +basedep +dependent-mapdep +dependent-sumsetup-changed

Dependencies added: base, dependent-map, dependent-sum, ekg, ekg-core, exceptions, hspec, monad-metrics-extensible, mtl, stm, text

Files

ChangeLog.md +3/−0
LICENSE +30/−0
README.md +1/−0
Setup.hs +2/−0
monad-metrics-extensible.cabal +75/−0
src/Data/Dyn.hs +24/−0
src/System/Metrics/Extensible.hs +13/−0
src/System/Metrics/Monad.hs +50/−0
src/System/Metrics/Monad/Class.hs +18/−0
src/System/Metrics/Store.hs +105/−0
src/System/Metrics/TrackerInstances.hs +50/−0
test/Spec.hs +45/−0

+ ChangeLog.md view

@@ -0,0 +1,3 @@+# Changelog for monad-metrics-extensible++## Unreleased changes

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Georg Rudoy (c) 2019++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 Georg Rudoy 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.

+ README.md view

@@ -0,0 +1,1 @@+# monad-metrics-extensible

+ Setup.hs view

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

+ monad-metrics-extensible.cabal view

@@ -0,0 +1,75 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: bb9eb3e4722acb9d4fdca6657d73f6bd0989b7a3a4b7039ab5d09b4304702e73++name:           monad-metrics-extensible+version:        0.1.0.0+synopsis:       An extensible and type-safe wrapper around EKG metrics+description:    Please see the README on GitHub at <https://github.com/0xd34df00d/monad-metrics-extensible#readme>+category:       Web+homepage:       https://github.com/0xd34df00d/monad-metrics-extensible#readme+bug-reports:    https://github.com/0xd34df00d/monad-metrics-extensible/issues+author:         Georg Rudoy+maintainer:     0xd34df00d@gmail.com+copyright:      2019 Georg Rudoy+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/0xd34df00d/monad-metrics-extensible++library+  exposed-modules:+      Data.Dyn+      System.Metrics.Extensible+      System.Metrics.Monad+      System.Metrics.Monad.Class+      System.Metrics.Store+      System.Metrics.TrackerInstances+  other-modules:+      Paths_monad_metrics_extensible+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      base >=4.7 && <5+    , dependent-map+    , dependent-sum+    , ekg+    , ekg-core+    , exceptions+    , mtl+    , stm+    , text+  default-language: Haskell2010++test-suite monad-metrics-extensible-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_monad_metrics_extensible+  hs-source-dirs:+      test+  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , dependent-map+    , dependent-sum+    , ekg+    , ekg-core+    , exceptions+    , hspec+    , monad-metrics-extensible+    , mtl+    , stm+    , text+  default-language: Haskell2010

+ src/Data/Dyn.hs view

@@ -0,0 +1,24 @@+{-# LANGUAGE RankNTypes, GADTs, ConstraintKinds, FlexibleInstances #-}++module Data.Dyn where++import Type.Reflection++data Dyn ctx where+  Dyn :: ctx a => TypeRep a -> a -> Dyn ctx++toDyn :: (Typeable a, ctx a) => a -> Dyn ctx+toDyn val = Dyn (typeOf val) val++withDyns :: Dyn ctx -> Dyn ctx ->+            (forall a. ctx a => a -> a -> b) ->+            (SomeTypeRep -> SomeTypeRep -> b) -> b+withDyns (Dyn ty1 v1) (Dyn ty2 v2) f def = case eqTypeRep ty1 ty2 of+  Nothing -> def (SomeTypeRep ty1) (SomeTypeRep ty2)+  Just HRefl -> f v1 v2++instance Eq (Dyn Ord) where+  d1 == d2 = withDyns d1 d2 (==) (\_ _ -> False)++instance Ord (Dyn Ord) where+  compare d1 d2 = withDyns d1 d2 compare compare

+ src/System/Metrics/Extensible.hs view

@@ -0,0 +1,13 @@+module System.Metrics.Extensible+( module X+) where++import System.Metrics.Counter as X(Counter)+import System.Metrics.Distribution as X(Distribution)+import System.Metrics.Gauge as X(Gauge)+import System.Metrics.Label as X(Label)++import System.Metrics.Monad as X+import System.Metrics.Monad.Class as X+import System.Metrics.Store as X+import System.Metrics.TrackerInstances as X

+ src/System/Metrics/Monad.hs view

@@ -0,0 +1,50 @@+{-# LANGUAGE PolyKinds, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}++module System.Metrics.Monad+( MonadMetrics(..)+, MetricsT+, runMetricsT+, Metrics+) where++import Control.Monad.Catch+import Control.Monad.IO.Class+import Control.Monad.Reader++import System.Metrics.Monad.Class+import System.Metrics.Store++newtype MetricsT (m :: k -> *) (a :: k) = MetricsT { runMetricsT :: MetricsStore -> m a }+type Metrics = MetricsT IO++instance Functor m => Functor (MetricsT m) where+  fmap f (MetricsT m) = MetricsT $ fmap f . m++instance Applicative m => Applicative (MetricsT m) where+  pure = MetricsT . const . pure+  (MetricsT fun) <*> (MetricsT val) = MetricsT $ \store -> fun store <*> val store++instance Monad m => Monad (MetricsT m) where+  (MetricsT val) >>= f = MetricsT $ \store -> val store >>= \a -> runMetricsT (f a) store++instance MonadIO m => MonadMetrics (MetricsT m) where+  getTracker metric = MetricsT $ \store -> liftIO $ getMetricFromStore store metric+++instance MonadTrans MetricsT where+  lift m = MetricsT $ const m+++instance MonadIO m => MonadIO (MetricsT m) where+  liftIO act = MetricsT $ const $ liftIO act++instance MonadReader r m => MonadReader r (MetricsT m) where+  ask = MetricsT $ const ask+  reader f = MetricsT $ const $ reader f+  local m (MetricsT rFun) = MetricsT $ local m . rFun++instance MonadThrow m => MonadThrow (MetricsT m) where+  throwM ex = MetricsT $ const $ throwM ex++instance MonadCatch m => MonadCatch (MetricsT m) where+  catch (MetricsT act) handler = MetricsT $ \store -> catch (act store) $ \ex -> runMetricsT (handler ex) store

+ src/System/Metrics/Monad/Class.hs view

@@ -0,0 +1,18 @@+{-# LANGUAGE TypeFamilyDependencies #-}++module System.Metrics.Monad.Class where++import qualified Data.Text as T+import Control.Monad.IO.Class+import GHC.TypeLits+import System.Metrics+import Type.Reflection++class Typeable tracker => TrackerLike tracker where+  type TrackAction tracker (m :: * -> *) = r | r -> m+  track :: (MonadMetrics m, KnownSymbol name, Typeable metric, Ord (metric tracker name)) => metric tracker name -> TrackAction tracker m+  createTracker :: T.Text -> Store -> IO tracker++class MonadIO m => MonadMetrics m where+  getTracker :: (TrackerLike tracker, KnownSymbol name, Typeable metric, Ord (metric tracker name))+             => metric tracker name -> m tracker

+ src/System/Metrics/Store.hs view

@@ -0,0 +1,105 @@+{-# LANGUAGE RankNTypes, GADTs #-}+{-# LANGUAGE StandaloneDeriving, ScopedTypeVariables, TypeOperators #-}++module System.Metrics.Store+( MetricsStore+, newMetricsStore+, withMetricsStore++, getMetricFromStore+) where++import qualified Data.Dependent.Map as DM+import qualified Data.Text as T+import Control.Concurrent+import Control.Concurrent.STM.TQueue+import Control.Monad.Catch+import Control.Monad.Identity+import Control.Monad.STM+import Data.GADT.Compare+import Data.Proxy+import Data.Typeable(eqT)+import GHC.TypeLits+import System.Remote.Monitoring+import Type.Reflection++import Data.Dyn+import System.Metrics.Monad.Class++type DynOrd = Dyn Ord++data SomeMetric tracker where+  MkSomeMetric :: (Typeable metric, TrackerLike tracker, KnownSymbol name, Ord (metric tracker name))+               => metric tracker name -> SomeMetric tracker++deriving instance Typeable (SomeMetric t)++instance GEq SomeMetric where+  geq (MkSomeMetric _) (MkSomeMetric _) = eqT++instance GCompare SomeMetric where+  gcompare sm1@(MkSomeMetric (m1 :: mTy1 tTy1 nTy1)) sm2@(MkSomeMetric (m2 :: mTy2 tTy2 nTy2)) =+    case eqT :: Maybe (tTy1 :~: tTy2) of+      Just Refl -> case compare (toDyn m1 :: DynOrd) (toDyn m2) of+        LT -> GLT+        EQ -> GEQ+        GT -> GGT+      Nothing -> case compare (someTypeRep sm1) (someTypeRep sm2) of+        LT -> GLT+        EQ -> error "SomeTypeReps are equal though eqT proved them wrong"+        GT -> GGT++data MetricsState = MetricsState+  { server :: Server+  , metrics :: DM.DMap SomeMetric Identity+  }++data MetricRequest where+  MetricRequest :: (TrackerLike tracker, KnownSymbol name, Typeable metric, Ord (metric tracker name))+                => metric tracker name+                -> MVar tracker+                -> MetricRequest++newtype MetricsStore = MetricsStore { mReqQueue :: TQueue MetricRequest }++newMetricsStore :: Server -> IO (MetricsStore, IO ())+newMetricsStore srv = do+  queue <- newTQueueIO+  threadId <- forkIO $ act queue $ MetricsState srv mempty+  pure (MetricsStore queue, killThread threadId)+  where+    act queue state = do+      req <- atomically (readTQueue queue)+      state' <- (\(MetricRequest metric mvar) -> handleReq state metric mvar) req+      act queue state'++    handleReq :: forall metric tracker name. (TrackerLike tracker, KnownSymbol name, Typeable metric, Ord (metric tracker name))+              => MetricsState+              -> metric tracker name+              -> MVar tracker+              -> IO MetricsState+    handleReq state metric mvar = do+      let asSome = MkSomeMetric metric+      (tracker, state') <- case DM.lookup asSome $ metrics state of+        Just existing -> pure (runIdentity existing, state)+        Nothing -> do+          let trackerName = symbolVal (Proxy :: Proxy name)+          newTracker <- createTracker (T.pack trackerName) $ serverMetricStore $ server state+          pure (newTracker, state { metrics = DM.insert asSome (Identity newTracker) $ metrics state })+      putMVar mvar tracker+      pure state'++withMetricsStore :: Server -> (MetricsStore -> IO a) -> IO a+withMetricsStore srv f = bracket+  (newMetricsStore srv)+  snd+  (f . fst)++getMetricFromStore :: (TrackerLike tracker, KnownSymbol name, Typeable metric, Ord (metric tracker name))+                   => MetricsStore+                   -> metric tracker name+                   -> IO tracker+getMetricFromStore store metric = do+  mvar <- newEmptyMVar+  atomically $ writeTQueue (mReqQueue store) $ MetricRequest metric mvar+  takeMVar mvar

+ src/System/Metrics/TrackerInstances.hs view

@@ -0,0 +1,50 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module System.Metrics.TrackerInstances where++import qualified Data.Text as T+import Control.Monad.IO.Class+import GHC.Int+import System.Metrics+import System.Metrics.Counter as TC+import System.Metrics.Distribution as TD+import System.Metrics.Gauge as TG+import System.Metrics.Label as TL++import System.Metrics.Monad.Class++instance TrackerLike Counter where+  type TrackAction Counter m = m ()+  track metric = getTracker metric >>= liftIO . TC.inc+  createTracker = createCounter++instance TrackerLike Distribution where+  type TrackAction Distribution m = Double -> m ()+  track metric val = getTracker metric >>= \distr -> liftIO $ TD.add distr val+  createTracker = createDistribution++instance TrackerLike Gauge where+  type TrackAction Gauge m = Int64 -> m ()+  track metric val = getTracker metric >>= \gauge -> liftIO $ TG.set gauge val+  createTracker = createGauge++instance TrackerLike Label where+  type TrackAction Label m = T.Text -> m ()+  track metric val = getTracker metric >>= \label -> liftIO $ TL.set label val+  createTracker = createLabel++newtype DistrGauge = DistrGauge (Distribution, Gauge)++instance TrackerLike DistrGauge where+  type TrackAction DistrGauge m = Int64 -> m ()+  track metric val = do+    DistrGauge (distr, gauge) <- getTracker metric+    liftIO $ do+      TG.add gauge val+      TD.add distr $ fromIntegral val+  createTracker name store = do+    d <- createDistribution (name <> "_distr") store+    g <- createGauge (name <> "_total") store+    pure $ DistrGauge (d, g)

+ test/Spec.hs view

@@ -0,0 +1,45 @@+{-# LANGUAGE DataKinds, GADTs #-}+{-# LANGUAGE OverloadedStrings, StandaloneDeriving #-}++import Control.Monad.IO.Class+import System.Metrics.Counter as TC(read)+import System.Metrics.Gauge as TG(read)+import System.Remote.Monitoring+import Test.Hspec++import System.Metrics.Extensible++data TestMetrics ty name where+  Foo1 :: TestMetrics Counter "foo1"+  Foo2 :: TestMetrics Counter "foo2"+  Bar  :: TestMetrics Gauge   "bar"++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"++deriving instance Eq (OtherMetrics ty name)+deriving instance Ord (OtherMetrics ty name)++main :: IO ()+main = do+  ekgServer <- forkServer "localhost" 21000+  withMetricsStore ekgServer $ \store -> flip runMetricsT store $ do+    track Foo1+    track Foo1+    track Foo2+    track Bar 10+    track Bar 20+    track Baz+    track Quux 42+    liftIO $ hspec $ do+      describe "Counters are stored as expected" $ do+        it "Foo1 is incremented twice" $ (getMetricFromStore store Foo1 >>= TC.read) `shouldReturn` 2+        it "This does not affect Foo2" $ (getMetricFromStore store Foo2 >>= TC.read) `shouldReturn` 1+        it "Metrics from other type are also saved" $ (getMetricFromStore store Baz >>= TC.read) `shouldReturn` 1+      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