{-# LANGUAGE TypeFamilies, DataKinds, ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
module System.Metrics.ExtraTrackers
( Timestamp
, TimerMagnitude(..)
, Timer(..)
, timed
) where
import qualified Data.Text as T
import Control.Monad.IO.Class
import Data.Proxy
import Data.Time.Clock.POSIX
import Data.Typeable
import GHC.TypeLits
import System.CPUTime
import System.Metrics
import System.Metrics.Distribution as TD
import System.Metrics.Label as TL
import System.Metrics.Extensible
newtype Timestamp = Timestamp Label
instance TrackerLike Timestamp where
type TrackAction Timestamp m = m ()
track :: metric Timestamp name -> TrackAction Timestamp m
track metric Timestamp name
metric = do
Timestamp Label
l <- metric Timestamp name -> m Timestamp
forall (m :: * -> *) tracker (name :: Symbol)
(metric :: * -> Symbol -> *).
(MonadMetrics m, TrackerLike tracker, KnownSymbol name,
Typeable metric, Ord (metric tracker name)) =>
metric tracker name -> m tracker
getTracker metric Timestamp name
metric
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
UTCTime
utc <- IO UTCTime
getCurrentTime
Label -> Text -> IO ()
TL.set Label
l (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ UTCTime -> String
forall a. Show a => a -> String
show UTCTime
utc
createTracker :: Text -> Store -> IO Timestamp
createTracker Text
name Store
store = Label -> Timestamp
Timestamp (Label -> Timestamp) -> IO Label -> IO Timestamp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Store -> IO Label
createLabel Text
name Store
store
newtype Timer (magn :: TimerMagnitude) = Timer { Timer magn -> Distribution
getTimerDistribution :: Distribution }
data TimerMagnitude = Msecs | Usecs | Nsecs deriving (Typeable)
class MagnitudeOps (magn :: TimerMagnitude) where
toString :: Proxy magn -> T.Text
secFraction :: Proxy magn -> Double
instance MagnitudeOps 'Msecs where
toString :: Proxy 'Msecs -> Text
toString Proxy 'Msecs
_ = Text
"ms"
secFraction :: Proxy 'Msecs -> Double
secFraction Proxy 'Msecs
_ = Double
1e-3
instance MagnitudeOps 'Usecs where
toString :: Proxy 'Usecs -> Text
toString Proxy 'Usecs
_ = Text
"us"
secFraction :: Proxy 'Usecs -> Double
secFraction Proxy 'Usecs
_ = Double
1e-6
instance MagnitudeOps 'Nsecs where
toString :: Proxy 'Nsecs -> Text
toString Proxy 'Nsecs
_ = Text
"ns"
secFraction :: Proxy 'Nsecs -> Double
secFraction Proxy 'Nsecs
_ = Double
1e-9
instance (Typeable magn, MagnitudeOps magn) => TrackerLike (Timer magn) where
type TrackAction (Timer magn) m = Double -> m ()
track :: metric (Timer magn) name -> TrackAction (Timer magn) m
track metric (Timer magn) name
metric Double
timing = do
Timer Distribution
timer <- metric (Timer magn) name -> m (Timer magn)
forall (m :: * -> *) tracker (name :: Symbol)
(metric :: * -> Symbol -> *).
(MonadMetrics m, TrackerLike tracker, KnownSymbol name,
Typeable metric, Ord (metric tracker name)) =>
metric tracker name -> m tracker
getTracker metric (Timer magn) name
metric
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Distribution -> Double -> IO ()
TD.add Distribution
timer Double
timing
createTracker :: Text -> Store -> IO (Timer magn)
createTracker Text
name Store
store = Distribution -> Timer magn
forall (magn :: TimerMagnitude). Distribution -> Timer magn
Timer (Distribution -> Timer magn) -> IO Distribution -> IO (Timer magn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Store -> IO Distribution
createDistribution (Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Proxy magn -> Text
forall (magn :: TimerMagnitude).
MagnitudeOps magn =>
Proxy magn -> Text
toString (Proxy magn
forall k (t :: k). Proxy t
Proxy :: Proxy magn)) Store
store
time :: MonadIO m => m a -> m (Integer, a)
time :: m a -> m (Integer, a)
time m a
act = do
Integer
start <- IO Integer -> m Integer
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Integer
getCPUTime
a
res <- m a
act
Integer
end <- IO Integer -> m Integer
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Integer
getCPUTime
(Integer, a) -> m (Integer, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer
end Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
start, a
res)
timed :: forall m metric magn name a.
(MonadMetrics m, KnownSymbol name, Typeable metric, Typeable magn, MagnitudeOps magn, Ord (metric (Timer magn) name))
=> metric (Timer magn) name
-> m a
-> m a
timed :: metric (Timer magn) name -> m a -> m a
timed metric (Timer magn) name
metric m a
act = do
(Integer
cpuTime, a
res) <- m a -> m (Integer, a)
forall (m :: * -> *) a. MonadIO m => m a -> m (Integer, a)
time m a
act
metric (Timer magn) name -> TrackAction (Timer magn) m
forall tracker (m :: * -> *) (name :: Symbol)
(metric :: * -> Symbol -> *).
(TrackerLike tracker, MonadMetrics m, KnownSymbol name,
Typeable metric, Ord (metric tracker name)) =>
metric tracker name -> TrackAction tracker m
track metric (Timer magn) name
metric (Double -> m ()) -> Double -> m ()
forall a b. (a -> b) -> a -> b
$ Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
cpuTime Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Double
1e12 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Proxy magn -> Double
forall (magn :: TimerMagnitude).
MagnitudeOps magn =>
Proxy magn -> Double
secFraction (Proxy magn
forall k (t :: k). Proxy t
Proxy :: Proxy magn))
a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res