diff --git a/arbor-monad-metric.cabal b/arbor-monad-metric.cabal --- a/arbor-monad-metric.cabal +++ b/arbor-monad-metric.cabal @@ -1,5 +1,5 @@ name: arbor-monad-metric -version: 1.0.0 +version: 1.1.0 description: Please see the README on Github at synopsis: Core metric library for publishing metrics. category: Metrics @@ -23,6 +23,8 @@ library exposed-modules: Arbor.Monad.Metric + Arbor.Monad.Metric.Api.String + Arbor.Monad.Metric.Api.Text Arbor.Monad.Metric.Generic Arbor.Monad.Metric.Type other-modules: @@ -48,8 +50,11 @@ main-is: Spec.hs other-modules: Arbor.Monad.Metric + Arbor.Monad.Metric.Api.String + Arbor.Monad.Metric.Api.Text Arbor.Monad.Metric.Generic Arbor.Monad.Metric.Type + Arbor.Monad.MetricApp Arbor.Monad.MetricSpec Paths_arbor_monad_metric hs-source-dirs: diff --git a/src/Arbor/Monad/Metric.hs b/src/Arbor/Monad/Metric.hs --- a/src/Arbor/Monad/Metric.hs +++ b/src/Arbor/Monad/Metric.hs @@ -4,23 +4,28 @@ module Arbor.Monad.Metric ( MonadMetrics , Z.getMetrics - , metric - , Counter(..) - , Gauge(..) - , Metrics(..) , newMetricsIO , extractValues + , metric + + , Counter + , Gauge + , Metrics + , Tag + , counter , gauge + , tag + , tags ) where +import Arbor.Monad.Metric.Api.Text import Arbor.Monad.Metric.Generic (metric) -import Arbor.Monad.Metric.Type (Counter, Gauge, MetricFamily (..), MetricMap, Metrics (Metrics), MonadMetrics) +import Arbor.Monad.Metric.Type (Counter, Gauge, MetricFamily (..), MetricMap, Metrics (Metrics), MonadMetrics, Tag) import Control.Concurrent.STM.TVar import Control.Monad.STM (STM) import Data.Proxy -import Data.Text (Text) import qualified Arbor.Monad.Metric.Type as Z import qualified Control.Concurrent.STM as STM @@ -41,9 +46,3 @@ let tvars = M.elems m nums <- fmap (metricStateToValue pk <$>) . sequence $ readTVar <$> tvars return (zip names nums, tvars) - -counter :: Text -> Counter -counter name = Z.Counter name [] - -gauge :: Text -> Gauge -gauge name = Z.Gauge name [] diff --git a/src/Arbor/Monad/Metric/Api/String.hs b/src/Arbor/Monad/Metric/Api/String.hs new file mode 100644 --- /dev/null +++ b/src/Arbor/Monad/Metric/Api/String.hs @@ -0,0 +1,33 @@ +module Arbor.Monad.Metric.Api.String + ( Counter + , Gauge + , Tag + + , tags + , tag + , counter + , gauge + ) where + +import Arbor.Monad.Metric.Type (Counter, Gauge, Tag) +import Data.Bifunctor +import Data.Set (Set) + +import qualified Arbor.Monad.Metric.Api.Text as T +import qualified Data.Text as T + +counter :: String -> Counter +counter = T.counter . T.pack +{-# INLINE counter #-} + +gauge :: String -> Gauge +gauge = T.gauge . T.pack +{-# INLINE gauge #-} + +tag :: String -> String -> Tag +tag name value = T.tag (T.pack name) (T.pack value) +{-# INLINE tag #-} + +tags :: [(String, String)] -> Set Tag +tags = T.tags . fmap (bimap T.pack T.pack) +{-# INLINE tags #-} diff --git a/src/Arbor/Monad/Metric/Api/Text.hs b/src/Arbor/Monad/Metric/Api/Text.hs new file mode 100644 --- /dev/null +++ b/src/Arbor/Monad/Metric/Api/Text.hs @@ -0,0 +1,33 @@ +module Arbor.Monad.Metric.Api.Text + ( Counter + , Gauge + , Tag + + , tags + , tag + , counter + , gauge + ) where + +import Arbor.Monad.Metric.Type (Counter, Gauge, Tag) +import Data.Set (Set) +import Data.Text (Text) + +import qualified Arbor.Monad.Metric.Type as Z +import qualified Data.Set as S + +counter :: Text -> Counter +counter name = Z.Counter name S.empty +{-# INLINE counter #-} + +gauge :: Text -> Gauge +gauge name = Z.Gauge name S.empty +{-# INLINE gauge #-} + +tag :: Text -> Text -> Tag +tag = Z.Tag +{-# INLINE tag #-} + +tags :: [(Text, Text)] -> Set Tag +tags nvs = S.fromList (uncurry tag <$> nvs) +{-# INLINE tags #-} diff --git a/src/Arbor/Monad/Metric/Type.hs b/src/Arbor/Monad/Metric/Type.hs --- a/src/Arbor/Monad/Metric/Type.hs +++ b/src/Arbor/Monad/Metric/Type.hs @@ -21,15 +21,21 @@ import qualified Control.Concurrent.STM as STM import qualified Data.Map.Strict as M +import qualified Data.Set as S +data Tag = Tag + { name :: Text + , value :: Text + } deriving (Eq, Ord, Show, Generic) + data Counter = Counter { name :: Text - , tags :: [Text] + , tags :: S.Set Tag } deriving (Eq, Ord, Show, Generic) data Gauge = Gauge { name :: Text - , tags :: [Text] + , tags :: S.Set Tag } deriving (Eq, Ord, Show, Generic) type MetricMap k v = M.Map k (STM.TVar v) diff --git a/test/Arbor/Monad/MetricApp.hs b/test/Arbor/Monad/MetricApp.hs new file mode 100644 --- /dev/null +++ b/test/Arbor/Monad/MetricApp.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Arbor.Monad.MetricApp + ( runMetricApp + ) where + +import Arbor.Monad.Metric +import Control.Monad.Reader +import Data.Generics.Product.Any +import GHC.Generics + +import qualified Arbor.Network.StatsD as S +import qualified Arbor.Network.StatsD.Type as Z + +newtype MiniConfig = MiniConfig + { metrics :: Metrics + } deriving (Generic) + +instance MonadMetrics MetricApp where + getMetrics = reader metrics + +newtype MetricApp a = MetricApp + { unMetricApp :: ReaderT MiniConfig IO a + } + deriving ( Functor + , Applicative + , Monad + , MonadIO + , MonadReader MiniConfig) + +runMetricApp :: MetricApp a -> IO a +runMetricApp f = do + metrics <- newMetricsIO + let config = MiniConfig metrics + runReaderT (unMetricApp f) config diff --git a/test/Arbor/Monad/MetricSpec.hs b/test/Arbor/Monad/MetricSpec.hs --- a/test/Arbor/Monad/MetricSpec.hs +++ b/test/Arbor/Monad/MetricSpec.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} module Arbor.Monad.MetricSpec @@ -21,6 +22,7 @@ import qualified Control.Concurrent.STM as STM import qualified Data.ByteString.Char8 as BS import qualified Data.Map.Strict as M +import qualified Data.Set as S import qualified Network.Socket as S hiding (recv, recvFrom, send, sendTo) import qualified Network.Socket.ByteString as S @@ -36,9 +38,9 @@ spec = describe "Arbor.Monad.MetricSpec" $ do it "Metrics library actually tracks metrics it receives" $ requireTest $ do metrics <- liftIO $ A.runMetricApp $ do - M.metric (M.counter "test.counter" ) 10 - M.metric (M.gauge "test.gauge" ) 20 - M.metric (M.gauge "test.gauge" & the @"tags" .~ ["foo"]) 30 + M.metric (M.counter "test.counter" ) 10 + M.metric (M.gauge "test.gauge" ) 20 + M.metric (M.gauge "test.gauge" & the @"tags" .~ M.tags [("foo", "bar")]) 30 MT.getMetrics countersMap <- liftIO $ STM.readTVarIO $ metrics ^. the @"counters" @@ -47,9 +49,9 @@ counters <- liftIO $ STM.atomically $ fst <$> M.extractValues @MT.Counter Proxy countersMap gauges <- liftIO $ STM.atomically $ fst <$> M.extractValues @MT.Gauge Proxy gaugesMap - counters === [ (M.counter "test.counter" , 10) + counters === [ (M.counter "test.counter" , 10) ] - gauges === [ (M.gauge "test.gauge" , 20) - , (M.gauge "test.gauge" & the @"tags" .~ ["foo"] , 30) + gauges === [ (M.gauge "test.gauge" , 20) + , (M.gauge "test.gauge" & the @"tags" .~ M.tags [("foo", "bar")] , 30) ]