arbor-monad-counter (empty) → 2.0.0

raw patch · 8 files changed

+264/−0 lines, 8 filesdep +arbor-monad-counterdep +basedep +containerssetup-changed

Dependencies added: arbor-monad-counter, base, containers, generic-lens, hedgehog, hspec, hw-hspec-hedgehog, lens, mtl, resourcet, stm, transformers

Files

ChangeLog.md +3/−0
LICENSE +21/−0
README.md +3/−0
Setup.hs +2/−0
arbor-monad-counter.cabal +72/−0
src/Arbor/Monad/Counter.hs +113/−0
src/Arbor/Monad/Counter/Type.hs +49/−0
test/Spec.hs +1/−0

+ ChangeLog.md view

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

+ LICENSE view

@@ -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.

+ README.md view

@@ -0,0 +1,3 @@+# arbor-monad-counter++[![CircleCI](https://circleci.com/gh/arbor/arbor-monad-counter.svg?style=svg)](https://circleci.com/gh/arbor/arbor-monad-counter)

+ Setup.hs view

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

+ arbor-monad-counter.cabal view

@@ -0,0 +1,72 @@+-- This file has been generated from package.yaml by hpack version 0.18.1.+--+-- see: https://github.com/sol/hpack++name:           arbor-monad-counter+version:        2.0.0+description:    Please see the README on Github at <https://github.com/arbor/arbor-monad-counter#readme>+category:       Services+homepage:       https://github.com/arbor/arbor-monad-counter#readme+bug-reports:    https://github.com/arbor/arbor-monad-counter/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-counter++library+  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:+      base >=4.7 && <5+    , containers+    , generic-lens+    , lens+    , mtl+    , stm+    , resourcet+    , transformers+  exposed-modules:+      Arbor.Monad.Counter+      Arbor.Monad.Counter.Type+  other-modules:+      Paths_arbor_monad_counter+  default-language: Haskell2010++test-suite arbor-monad-counter-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  hs-source-dirs:+      test+      src+  default-extensions: BangPatterns FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings TupleSections+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , containers+    , generic-lens+    , lens+    , mtl+    , stm+    , resourcet+    , transformers+    , arbor-monad-counter+    , hspec+    , hedgehog+    , hw-hspec-hedgehog+  other-modules:+      Arbor.Monad.Counter+      Arbor.Monad.Counter.Type+  default-language: Haskell2010

+ src/Arbor/Monad/Counter.hs view

@@ -0,0 +1,113 @@+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE TypeApplications #-}++module Arbor.Monad.Counter+  ( MonadCounters+  , Z.getCounters++  , incByKey+  , incByKey'+  , addByKey+  , addByKey'++  , newCounters+  , resetStats+  , valuesByKeys+  , extractValues+  , newCountersMap+  , deltaStats+  ) where++import Arbor.Monad.Counter.Type    (CounterKey, CounterValue (CounterValue), Counters (Counters), CountersMap, MonadCounters)+import Control.Concurrent.STM.TVar+import Control.Lens+import Control.Monad.IO.Class+import Control.Monad.STM           (STM, atomically)+import Data.Foldable+import Data.Generics.Product.Any++import qualified Arbor.Monad.Counter.Type as Z+import qualified Data.List                as DL+import qualified Data.Map.Strict          as M++newCounters :: [CounterKey] -> IO Counters+newCounters ks = Counters <$> newCountersMap ks <*> newCountersMap ks <*> newCountersMap ks++newCountersMap :: [CounterKey] -> IO CountersMap+newCountersMap (k:ks) = do+  m <- newCountersMap ks+  v <- CounterValue <$> newTVarIO 0+  return $ M.insert k v m+newCountersMap [] = return M.empty++-- Increase the current value by 1+incByKey :: MonadCounters m => CounterKey -> m ()+incByKey = modifyByKey (+1)++-- Increase the current value by 1+incByKey' :: Counters -> CounterKey -> IO ()+incByKey' = modifyByKey' (+1)++-- Increase the current value by n+addByKey :: MonadCounters m => Int -> CounterKey -> m ()+addByKey n = modifyByKey (+n)++-- Increase the current value by n+addByKey' :: Int -> Counters -> CounterKey -> IO ()+addByKey' n = modifyByKey' (+n)++-- Modify the current value with the supplied function+modifyByKey :: MonadCounters m => (Int -> Int) -> CounterKey -> m ()+modifyByKey f key = do+  counters <- Z.getCounters+  liftIO $ modifyByKey' f counters key++-- Modify the current value with the supplied function+modifyByKey' :: (Int -> Int) -> Counters -> CounterKey -> IO ()+modifyByKey' f (Counters cur _ _) key = do+  let (CounterValue v) = cur M.! key+  atomically $ modifyTVar v f++valuesByKeys :: MonadCounters m => [CounterKey] -> m [Int]+valuesByKeys ks = do+  (Counters cur _ _) <- Z.getCounters+  liftIO $ atomically $ sequence $ readTVar <$> ((\k -> cur M.! k ^. the @"var") <$> ks)++extractValues :: CountersMap -> STM ([(CounterKey, Int)], [TVar Int])+extractValues m = do+  let names = M.keys m+  let tvars = (^. the @"var") <$> M.elems m+  nums <- sequence $ readTVar <$> tvars+  return (zip names nums, tvars)++-- store the current stats into previous;+-- accumulate stats in total+-- calculate the delta+deltaStats :: MonadCounters m => m CountersMap+deltaStats = do+  counters <- Z.getCounters+  deltas <- liftIO $ newCountersMap $ M.keys $ counters ^. the @"current"+  -- deltaCounters is accumulated into based on the diff between last and current counter values.+  liftIO $ atomically $ do+    (_, oldTvars)   <- extractValues $ counters ^. the @"previous"+    (_, newTvars)   <- extractValues $ counters ^. the @"current"+    (_, totalTvars) <- extractValues $ counters ^. the @"total"+    (_, deltaTvars) <- extractValues deltas+    for_ (DL.zip4 oldTvars newTvars totalTvars deltaTvars) $ \(old, new, total, delta) -> do+      new' <- readTVar new+      old' <- readTVar old+      total' <- readTVar total+      writeTVar old new'+      writeTVar delta (new' - old')+      writeTVar total (total' + (new' - old'))+    return deltas++resetStats :: MonadCounters m => m ()+resetStats = do+  counters <- Z.getCounters+  sequence_ $ setZeroes <$> [counters ^. the @"current", counters ^. the @"previous", counters ^. the @"total"]++setZeroes :: MonadIO m => CountersMap -> m ()+setZeroes cs = liftIO $ atomically $ do+  (_, tvars) <- extractValues cs+  traverse_ (`modifyTVar` const 0) tvars

+ src/Arbor/Monad/Counter/Type.hs view

@@ -0,0 +1,49 @@+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE DuplicateRecordFields #-}++module Arbor.Monad.Counter.Type where++import Control.Concurrent.STM.TVar+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.Map.Strict+import GHC.Generics++type CounterKey = String++newtype CounterValue = CounterValue+  { var   :: TVar Int+  } deriving (Generic)++type CountersMap = Map CounterKey CounterValue++data Counters = Counters+  { current  :: CountersMap+  , previous :: CountersMap+  , total    :: CountersMap+  } deriving (Generic)++class (Monad m, MonadIO m) => MonadCounters m where+  getCounters :: m Counters++instance MonadCounters m => MonadCounters (ExceptT e m) where+  getCounters = lift getCounters++instance MonadCounters m => MonadCounters (IdentityT m) where+  getCounters = lift getCounters++instance MonadCounters m => MonadCounters (MaybeT m) where+  getCounters = lift getCounters++instance MonadCounters m => MonadCounters (ReaderT e m) where+  getCounters = lift getCounters++instance MonadCounters m => MonadCounters (ResourceT m) where+  getCounters = lift getCounters++instance MonadCounters m => MonadCounters (StateT s m) where+  getCounters = lift getCounters

+ test/Spec.hs view

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