summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorhaskellworks <>2018-12-06 00:38:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-12-06 00:38:00 (GMT)
commita3e3aa88e9b9617e6d1a2651aa5b6af9143ac530 (patch)
treee4bc97d5c065ea6d8ceaa4fca552b01f0d161a22
parent8ae8c8a12c49e43282fc41b84ff903888ceae7ad (diff)
version 1.1.0HEAD1.1.0master
-rw-r--r--arbor-monad-metric.cabal7
-rw-r--r--src/Arbor/Monad/Metric.hs23
-rw-r--r--src/Arbor/Monad/Metric/Api/String.hs33
-rw-r--r--src/Arbor/Monad/Metric/Api/Text.hs33
-rw-r--r--src/Arbor/Monad/Metric/Type.hs10
-rw-r--r--test/Arbor/Monad/MetricApp.hs39
-rw-r--r--test/Arbor/Monad/MetricSpec.hs14
7 files changed, 138 insertions, 21 deletions
diff --git a/arbor-monad-metric.cabal b/arbor-monad-metric.cabal
index ed53882..28f11d3 100644
--- 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 <https://github.com/arbor/arbor-monad-metric#readme>
synopsis: Core metric library for publishing metrics.
category: Metrics
@@ -23,6 +23,8 @@ source-repository head
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 @@ test-suite arbor-monad-metric-test
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
index 79d495e..a1efe6e 100644
--- 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 @@ extractValues pk m = do
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
index 0000000..68163b4
--- /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
index 0000000..444b491
--- /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
index 3b55ca7..50d9acc 100644
--- a/src/Arbor/Monad/Metric/Type.hs
+++ b/src/Arbor/Monad/Metric/Type.hs
@@ -21,15 +21,21 @@ import GHC.Generics
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
index 0000000..a6887f8
--- /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
index 1a0bfce..8b32f14 100644
--- 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 Arbor.Monad.MetricApp as A
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 :: Spec
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 @@ spec = describe "Arbor.Monad.MetricSpec" $ do
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)
]