arbor-monad-metric (empty) → 0.0.1

raw patch · 11 files changed

+356/−0 lines, 11 filesdep +arbor-datadogdep +arbor-monad-metricdep +basesetup-changed

Dependencies added: arbor-datadog, arbor-monad-metric, base, bytestring, containers, generic-lens, hedgehog, hspec, hw-hspec-hedgehog, lens, mtl, network, resourcet, stm, transformers

Files

• ChangeLog.md +3/−0
• LICENSE +21/−0
• README.md +6/−0
• Setup.hs +2/−0
• arbor-monad-metric.cabal +76/−0
• src/Arbor/Monad/Metric.hs +39/−0
• src/Arbor/Monad/Metric/Generic.hs +49/−0
• src/Arbor/Monad/Metric/Type.hs +85/−0
• test/Arbor/Monad/MetricSpec.hs +38/−0
• test/Arbor/Monad/UdpServer.hs +36/−0
• test/Spec.hs +1/−0

@@ -0,0 +1,3 @@+# Changelog for arbor-monad-metric++## Unreleased changes

@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2018 Arbor Networks++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.

@@ -0,0 +1,6 @@+# arbor-monad-metric++[![CircleCI](https://circleci.com/gh/arbor/arbor-monad-metric.svg?style=svg)](https://circleci.com/gh/arbor/arbor-monad-metric)++This is a fork of `arbor-monad-counter` into a module namespace to add support for varied metric types.+The `arbor-monad-counter` is retained for backwards compatibility.

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

@@ -0,0 +1,76 @@+name:           arbor-monad-metric+version:        0.0.1+description:    Please see the README on Github at <https://github.com/arbor/arbor-monad-metric#readme>+category:       Services+homepage:       https://github.com/arbor/arbor-monad-metric#readme+bug-reports:    https://github.com/arbor/arbor-monad-metric/issues+author:         Arbor Networks+maintainer:     mayhem@arbor.net+copyright:      Arbor Networks+license:        MIT+license-file:   LICENSE+build-type:     Simple+cabal-version:  >= 1.10+extra-source-files:+    ChangeLog.md+    README.md++source-repository head+  type: git+  location: https://github.com/arbor/arbor-monad-metric++library+  exposed-modules:+      Arbor.Monad.Metric+      Arbor.Monad.Metric.Generic+      Arbor.Monad.Metric.Type+  other-modules:+      Paths_arbor_monad_metric+  hs-source-dirs:+      src+  default-extensions: BangPatterns FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings TupleSections+  ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints+  build-depends:+      arbor-datadog+    , base >=4.7 && <5+    , containers+    , generic-lens+    , lens+    , mtl+    , resourcet+    , stm+    , transformers+  default-language: Haskell2010++test-suite arbor-monad-metric-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Arbor.Monad.MetricSpec+      Arbor.Monad.UdpServer+      Arbor.Monad.Metric+      Arbor.Monad.Metric.Generic+      Arbor.Monad.Metric.Type+      Paths_arbor_monad_metric+  hs-source-dirs:+      test+      src+  default-extensions: BangPatterns FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings TupleSections+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      arbor-datadog+    , arbor-monad-metric+    , base >=4.7 && <5+    , bytestring+    , containers+    , generic-lens+    , hedgehog+    , hspec+    , hw-hspec-hedgehog+    , lens+    , mtl+    , network+    , resourcet+    , stm+    , transformers+  default-language: Haskell2010

@@ -0,0 +1,39 @@+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Arbor.Monad.Metric+  ( MonadMetrics+  , Z.getMetrics+  , metric+  , Counter(..)+  , Gauge(..)+  , Metrics(..)+  , newMetricsIO+  , extractValues+  ) where++import Arbor.Monad.Metric.Generic  (metric)+import Arbor.Monad.Metric.Type     (Counter (..), Gauge (..), MetricFamily (..), MetricMap, Metrics (Metrics), MonadMetrics)+import Control.Concurrent.STM.TVar+import Control.Monad.STM           (STM)+import Data.Proxy++import qualified Arbor.Monad.Metric.Type as Z+import qualified Control.Concurrent.STM  as STM+import qualified Data.Map.Strict         as M++newMetricsIO :: IO Metrics+newMetricsIO = Metrics+  <$> STM.newTVarIO M.empty+  <*> STM.newTVarIO M.empty++extractValues :: forall k. ()+  => MetricFamily k+  => Proxy k+  -> MetricMap k (MetricState k)+  -> STM ([(k, MetricValue k)], [TVar (MetricState k)])+extractValues pk m = do+  let names = M.keys m+  let tvars = M.elems m+  nums <- fmap (metricStateToValue pk <$>) . sequence $ readTVar <$> tvars+  return (zip names nums, tvars)

@@ -0,0 +1,49 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}++module Arbor.Monad.Metric.Generic+  ( metric+  ) where++import Arbor.Monad.Metric.Type     (MetricFamily (..), Metrics, MonadMetrics)+import Control.Concurrent.STM.TVar+import Control.Monad.IO.Class+import Data.Semigroup (Semigroup, (<>))+import Data.Proxy++import qualified Arbor.Monad.Metric.Type as Z+import qualified Control.Concurrent.STM  as STM+import qualified Data.Map.Strict         as M++-- Modify the current value with the supplied function+metric :: ()+  => Ord k+  => Semigroup (MetricState k)+  => MetricFamily k+  => MonadMetrics m+  => k+  -> MetricValue k+  -> m ()+metric key v = do+  metrics <- Z.getMetrics+  liftIO $ metric' key v metrics++-- Modify the current value with the supplied function+metric' :: forall k . ()+  => Ord k+  => MetricFamily k+  => Semigroup (MetricState k)+  => k+  -> MetricValue k+  -> Metrics+  -> IO ()+metric' key value metrics = do+  let tCounters = metricMapTVarOf metrics :: STM.TVar (Z.MetricMap k (MetricState k))+  STM.atomically $ do+    counters <- STM.readTVar tCounters+    case counters M.!? key of+      Just tv -> modifyTVar tv (<> metricValueToState (Proxy @k) value)+      Nothing -> do+        tv <- STM.newTVar (metricValueToState (Proxy @k) value)+        let counters' = M.insert key tv counters+        STM.writeTVar tCounters counters'

@@ -0,0 +1,85 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-}++module Arbor.Monad.Metric.Type where++import Control.Lens+import Control.Monad.Except+import Control.Monad.Reader+import Control.Monad.State+import Control.Monad.Trans.Identity+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Resource+import Data.Generics.Product.Any+import Data.Proxy+import Data.Semigroup+import GHC.Generics++import qualified Control.Concurrent.STM as STM+import qualified Data.Map.Strict        as M++newtype Counter = Counter+  { name :: String+  } deriving (Eq, Ord, Show)++newtype Gauge = Gauge+  { name :: String+  } deriving (Eq, Ord, Show)++type MetricMap k v = M.Map k (STM.TVar v)++data Metrics = Metrics+  { counters :: STM.TVar (MetricMap Counter (MetricState Counter))+  , gauges   :: STM.TVar (MetricMap Gauge   (MetricState Gauge  ))+  } deriving (Generic)++class (Monad m, MonadIO m) => MonadMetrics m where+  getMetrics :: m Metrics++instance MonadMetrics m => MonadMetrics (ExceptT e m) where+  getMetrics = lift getMetrics++instance MonadMetrics m => MonadMetrics (IdentityT m) where+  getMetrics = lift getMetrics++instance MonadMetrics m => MonadMetrics (MaybeT m) where+  getMetrics = lift getMetrics++instance MonadMetrics m => MonadMetrics (ReaderT e m) where+  getMetrics = lift getMetrics++instance MonadMetrics m => MonadMetrics (ResourceT m) where+  getMetrics = lift getMetrics++instance MonadMetrics m => MonadMetrics (StateT s m) where+  getMetrics = lift getMetrics++class MetricFamily k where+  type MetricValue k+  type MetricState k+  metricMapTVarOf :: Metrics -> STM.TVar (MetricMap k (MetricState k))+  metricValueToState :: Proxy k -> MetricValue k -> MetricState k+  metricStateToValue :: Proxy k -> MetricState k -> MetricValue k++getMetricMapTVar :: (MetricFamily k, MonadMetrics m) => m (STM.TVar (MetricMap k (MetricState k)))+getMetricMapTVar = getMetrics <&> metricMapTVarOf++getMetricMap :: (MetricFamily k, MonadMetrics m) => m (MetricMap k (MetricState k))+getMetricMap = liftIO . STM.readTVarIO =<< getMetricMapTVar++instance MetricFamily Counter where+  type MetricValue Counter = Int+  type MetricState Counter = Sum Int+  metricMapTVarOf = (^. the @"counters")+  metricValueToState _ = Sum+  metricStateToValue _ = getSum++instance MetricFamily Gauge where+  type MetricValue Gauge = Double+  type MetricState Gauge = Last Double+  metricMapTVarOf = (^. the @"gauges")+  metricValueToState _ = Last+  metricStateToValue _ = getLast

@@ -0,0 +1,38 @@+module Arbor.Monad.MetricSpec+  ( spec+  ) where++import Control.Concurrent+import Control.Exception      (bracket)+import Control.Monad.IO.Class++import qualified Arbor.Monad.UdpServer     as UDP+import qualified Control.Concurrent.STM    as STM+import qualified Data.ByteString.Char8     as BS+import qualified Network.Socket            as S hiding (recv, recvFrom, send, sendTo)+import qualified Network.Socket.ByteString as S++import HaskellWorks.Hspec.Hedgehog+import Hedgehog+import Test.Hspec++{-# ANN module ("HLint: ignore Redundant do"        :: String) #-}+{-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}+{-# ANN module ("HLint: redundant bracket"          :: String) #-}++handler :: STM.TVar [BS.ByteString] -> UDP.UdpHandler+handler tMsgs addr msg = do+  STM.atomically $ STM.modifyTVar tMsgs (msg:)+  putStrLn $ "From " ++ show addr ++ ": " ++ show msg++spec :: Spec+spec = describe "Arbor.Monad.MetricSpec" $ do+  it "Metrics library actually sends statsd messages over UDP" $ requireTest $ do+    tMessages <- liftIO $ STM.newTVarIO []+    sock <- liftIO $ UDP.createUdpServer "5555"+    threadId <- liftIO $ forkIO $ do+      UDP.runUdpServer sock (handler tMessages)+    liftIO $ threadDelay 1000000+    liftIO $ killThread threadId+    messages <- liftIO $ STM.readTVarIO tMessages+    messages === []

@@ -0,0 +1,36 @@+module Arbor.Monad.UdpServer+  ( createUdpServer+  , runUdpServer+  , UdpHandler+  ) where++import Network.Socket++import qualified Data.ByteString           as BS+import qualified Network.Socket.ByteString as BS++type UdpHandler = SockAddr -> BS.ByteString -> IO ()++createUdpServer :: ()+    => String       -- ^ Port number or name; 514 is default+    -> IO Socket+createUdpServer port = withSocketsDo $ do+  addrinfos <- getAddrInfo+              (Just (defaultHints {addrFlags = [AI_PASSIVE]}))+              Nothing (Just port)+  let serveraddr = head addrinfos++  sock <- socket (addrFamily serveraddr) Datagram defaultProtocol++  bind sock (addrAddress serveraddr)+  return sock++runUdpServer :: ()+  => Socket+  -> UdpHandler+  -> IO ()+runUdpServer sock handler = withSocketsDo $ procMessages sock+  where procMessages sock = do+          (msg, addr) <- BS.recvFrom sock 1024+          handler addr msg+          procMessages sock

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}