{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE NamedFieldPuns #-}
module Freckle.App.Datadog
(
HasDogStatsClient(..)
, HasDogStatsTags(..)
, StatsClient
, Tag
, sendAppMetricWithTags
, increment
, counter
, gauge
, histogram
, histogramSince
, histogramSinceMs
, DogStatsSettings(..)
, envParseDogStatsEnabled
, envParseDogStatsSettings
, envParseDogStatsTags
, mkStatsClient
, guage
) where
import Freckle.App.Prelude
import Control.Lens (set)
import Control.Monad.Reader
import Data.Time (diffUTCTime)
import qualified Freckle.App.Env as Env
import Network.StatsD.Datadog hiding (metric, name, tags)
import qualified Network.StatsD.Datadog as Datadog
import Yesod.Core.Types (HandlerData, handlerEnv, rheSite)
class HasDogStatsClient app where
getDogStatsClient :: app -> Maybe StatsClient
instance HasDogStatsClient site => HasDogStatsClient (HandlerData child site) where
getDogStatsClient :: HandlerData child site -> Maybe StatsClient
getDogStatsClient = site -> Maybe StatsClient
forall app. HasDogStatsClient app => app -> Maybe StatsClient
getDogStatsClient (site -> Maybe StatsClient)
-> (HandlerData child site -> site)
-> HandlerData child site
-> Maybe StatsClient
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RunHandlerEnv child site -> site
forall child site. RunHandlerEnv child site -> site
rheSite (RunHandlerEnv child site -> site)
-> (HandlerData child site -> RunHandlerEnv child site)
-> HandlerData child site
-> site
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerData child site -> RunHandlerEnv child site
forall child site.
HandlerData child site -> RunHandlerEnv child site
handlerEnv
class HasDogStatsTags app where
getDogStatsTags :: app -> [Tag]
instance HasDogStatsTags site => HasDogStatsTags (HandlerData child site) where
getDogStatsTags :: HandlerData child site -> [Tag]
getDogStatsTags = site -> [Tag]
forall app. HasDogStatsTags app => app -> [Tag]
getDogStatsTags (site -> [Tag])
-> (HandlerData child site -> site)
-> HandlerData child site
-> [Tag]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RunHandlerEnv child site -> site
forall child site. RunHandlerEnv child site -> site
rheSite (RunHandlerEnv child site -> site)
-> (HandlerData child site -> RunHandlerEnv child site)
-> HandlerData child site
-> site
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerData child site -> RunHandlerEnv child site
forall child site.
HandlerData child site -> RunHandlerEnv child site
handlerEnv
increment
:: ( MonadUnliftIO m
, MonadReader env m
, HasDogStatsClient env
, HasDogStatsTags env
)
=> Text
-> [(Text, Text)]
-> m ()
increment :: Text -> [(Text, Text)] -> m ()
increment Text
name [(Text, Text)]
tags = Text -> [(Text, Text)] -> Int -> m ()
forall (m :: * -> *) env.
(MonadUnliftIO m, MonadReader env m, HasDogStatsClient env,
HasDogStatsTags env) =>
Text -> [(Text, Text)] -> Int -> m ()
counter Text
name [(Text, Text)]
tags Int
1
counter
:: ( MonadUnliftIO m
, MonadReader env m
, HasDogStatsClient env
, HasDogStatsTags env
)
=> Text
-> [(Text, Text)]
-> Int
-> m ()
counter :: Text -> [(Text, Text)] -> Int -> m ()
counter Text
name [(Text, Text)]
tags = Text -> [(Text, Text)] -> MetricType -> Int -> m ()
forall (m :: * -> *) env v.
(MonadUnliftIO m, MonadReader env m, HasDogStatsClient env,
HasDogStatsTags env, ToMetricValue v) =>
Text -> [(Text, Text)] -> MetricType -> v -> m ()
sendAppMetricWithTags Text
name [(Text, Text)]
tags MetricType
Counter
gauge
:: ( MonadUnliftIO m
, MonadReader env m
, HasDogStatsClient env
, HasDogStatsTags env
)
=> Text
-> [(Text, Text)]
-> Double
-> m ()
gauge :: Text -> [(Text, Text)] -> Double -> m ()
gauge Text
name [(Text, Text)]
tags = Text -> [(Text, Text)] -> MetricType -> Double -> m ()
forall (m :: * -> *) env v.
(MonadUnliftIO m, MonadReader env m, HasDogStatsClient env,
HasDogStatsTags env, ToMetricValue v) =>
Text -> [(Text, Text)] -> MetricType -> v -> m ()
sendAppMetricWithTags Text
name [(Text, Text)]
tags MetricType
Gauge
{-# DEPRECATED guage "Use gauge instead" #-}
guage
:: ( MonadUnliftIO m
, MonadReader env m
, HasDogStatsClient env
, HasDogStatsTags env
)
=> Text
-> [(Text, Text)]
-> Double
-> m ()
guage :: Text -> [(Text, Text)] -> Double -> m ()
guage = Text -> [(Text, Text)] -> Double -> m ()
forall (m :: * -> *) env.
(MonadUnliftIO m, MonadReader env m, HasDogStatsClient env,
HasDogStatsTags env) =>
Text -> [(Text, Text)] -> Double -> m ()
gauge
histogram
:: ( MonadUnliftIO m
, MonadReader env m
, HasDogStatsClient env
, HasDogStatsTags env
, ToMetricValue n
)
=> Text
-> [(Text, Text)]
-> n
-> m ()
histogram :: Text -> [(Text, Text)] -> n -> m ()
histogram Text
name [(Text, Text)]
tags n
metricValue =
Text -> [(Text, Text)] -> MetricType -> n -> m ()
forall (m :: * -> *) env v.
(MonadUnliftIO m, MonadReader env m, HasDogStatsClient env,
HasDogStatsTags env, ToMetricValue v) =>
Text -> [(Text, Text)] -> MetricType -> v -> m ()
sendAppMetricWithTags Text
name [(Text, Text)]
tags MetricType
Histogram n
metricValue
histogramSince
:: ( MonadUnliftIO m
, MonadReader env m
, HasDogStatsClient env
, HasDogStatsTags env
)
=> Text
-> [(Text, Text)]
-> UTCTime
-> m ()
histogramSince :: Text -> [(Text, Text)] -> UTCTime -> m ()
histogramSince = (NominalDiffTime -> Int)
-> Text -> [(Text, Text)] -> UTCTime -> m ()
forall (m :: * -> *) env n.
(MonadUnliftIO m, MonadReader env m, HasDogStatsClient env,
HasDogStatsTags env, ToMetricValue n) =>
(NominalDiffTime -> n) -> Text -> [(Text, Text)] -> UTCTime -> m ()
histogramSinceBy NominalDiffTime -> Int
forall _. RealFrac _ => _ -> Int
toSeconds
where
toSeconds :: _ -> Int
toSeconds = Integral Int => _ -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round @_ @Int
histogramSinceMs
:: ( MonadUnliftIO m
, MonadReader env m
, HasDogStatsClient env
, HasDogStatsTags env
)
=> Text
-> [(Text, Text)]
-> UTCTime
-> m ()
histogramSinceMs :: Text -> [(Text, Text)] -> UTCTime -> m ()
histogramSinceMs = (NominalDiffTime -> Double)
-> Text -> [(Text, Text)] -> UTCTime -> m ()
forall (m :: * -> *) env n.
(MonadUnliftIO m, MonadReader env m, HasDogStatsClient env,
HasDogStatsTags env, ToMetricValue n) =>
(NominalDiffTime -> n) -> Text -> [(Text, Text)] -> UTCTime -> m ()
histogramSinceBy NominalDiffTime -> Double
forall _. Real _ => _ -> Double
toMilliseconds
where toMilliseconds :: _ -> Double
toMilliseconds = (Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1000) (Double -> Double) -> (_ -> Double) -> _ -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Real _, Fractional Double) => _ -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac @_ @Double
histogramSinceBy
:: ( MonadUnliftIO m
, MonadReader env m
, HasDogStatsClient env
, HasDogStatsTags env
, ToMetricValue n
)
=> (NominalDiffTime -> n)
-> Text
-> [(Text, Text)]
-> UTCTime
-> m ()
histogramSinceBy :: (NominalDiffTime -> n) -> Text -> [(Text, Text)] -> UTCTime -> m ()
histogramSinceBy NominalDiffTime -> n
f Text
name [(Text, Text)]
tags UTCTime
time = do
UTCTime
now <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
let delta :: n
delta = NominalDiffTime -> n
f (NominalDiffTime -> n) -> NominalDiffTime -> n
forall a b. (a -> b) -> a -> b
$ UTCTime
now UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
time
Text -> [(Text, Text)] -> MetricType -> n -> m ()
forall (m :: * -> *) env v.
(MonadUnliftIO m, MonadReader env m, HasDogStatsClient env,
HasDogStatsTags env, ToMetricValue v) =>
Text -> [(Text, Text)] -> MetricType -> v -> m ()
sendAppMetricWithTags Text
name [(Text, Text)]
tags MetricType
Histogram n
delta
sendAppMetricWithTags
:: ( MonadUnliftIO m
, MonadReader env m
, HasDogStatsClient env
, HasDogStatsTags env
, ToMetricValue v
)
=> Text
-> [(Text, Text)]
-> MetricType
-> v
-> m ()
sendAppMetricWithTags :: Text -> [(Text, Text)] -> MetricType -> v -> m ()
sendAppMetricWithTags Text
name [(Text, Text)]
tags MetricType
metricType v
metricValue = do
Maybe StatsClient
mClient <- (env -> Maybe StatsClient) -> m (Maybe StatsClient)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks env -> Maybe StatsClient
forall app. HasDogStatsClient app => app -> Maybe StatsClient
getDogStatsClient
Maybe StatsClient -> (StatsClient -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe StatsClient
mClient ((StatsClient -> m ()) -> m ()) -> (StatsClient -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \StatsClient
client -> do
[Tag]
appTags <- (env -> [Tag]) -> m [Tag]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks env -> [Tag]
forall app. HasDogStatsTags app => app -> [Tag]
getDogStatsTags
let
ddTags :: [Tag]
ddTags = [Tag]
appTags [Tag] -> [Tag] -> [Tag]
forall a. Semigroup a => a -> a -> a
<> ((Text, Text) -> Tag) -> [(Text, Text)] -> [Tag]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Text -> Tag) -> (Text, Text) -> Tag
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Text -> Tag
tag) [(Text, Text)]
tags
ddMetric :: Metric
ddMetric = ASetter Metric Metric [Tag] [Tag] -> [Tag] -> Metric -> Metric
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Metric Metric [Tag] [Tag]
forall s a. HasTags s a => Lens' s a
Datadog.tags [Tag]
ddTags
(Metric -> Metric) -> Metric -> Metric
forall a b. (a -> b) -> a -> b
$ MetricName -> MetricType -> v -> Metric
forall a.
ToMetricValue a =>
MetricName -> MetricType -> a -> Metric
Datadog.metric (Text -> MetricName
MetricName Text
name) MetricType
metricType v
metricValue
StatsClient -> Metric -> m ()
forall (m :: * -> *) v.
(MonadIO m, ToStatsD v) =>
StatsClient -> v -> m ()
send StatsClient
client Metric
ddMetric
envParseDogStatsEnabled :: Env.Parser Bool
envParseDogStatsEnabled :: Parser Bool
envParseDogStatsEnabled = String -> Mod Bool -> Parser Bool
Env.switch String
"DOGSTATSD_ENABLED" (Mod Bool -> Parser Bool) -> Mod Bool -> Parser Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Mod Bool
forall a. a -> Mod a
Env.def Bool
False
envParseDogStatsSettings :: Env.Parser DogStatsSettings
envParseDogStatsSettings :: Parser DogStatsSettings
envParseDogStatsSettings = do
String
dogStatsSettingsHost <- Reader String -> String -> Mod String -> Parser String
forall a. Reader a -> String -> Mod a -> Parser a
Env.var Reader String
forall a. IsString a => Reader a
Env.str String
"DOGSTATSD_HOST" (Mod String -> Parser String) -> Mod String -> Parser String
forall a b. (a -> b) -> a -> b
$ String -> Mod String
forall a. a -> Mod a
Env.def String
"127.0.0.1"
Int
dogStatsSettingsPort <- Reader Int -> String -> Mod Int -> Parser Int
forall a. Reader a -> String -> Mod a -> Parser a
Env.var Reader Int
forall a. Read a => Reader a
Env.auto String
"DOGSTATSD_PORT" (Mod Int -> Parser Int) -> Mod Int -> Parser Int
forall a b. (a -> b) -> a -> b
$ Int -> Mod Int
forall a. a -> Mod a
Env.def Int
8125
Int
dogStatsSettingsMaxDelay <-
Reader Int -> String -> Mod Int -> Parser Int
forall a. Reader a -> String -> Mod a -> Parser a
Env.var Reader Int
forall a. Read a => Reader a
Env.auto String
"DOGSTATSD_MAX_DELAY_MICROSECONDS" (Mod Int -> Parser Int) -> Mod Int -> Parser Int
forall a b. (a -> b) -> a -> b
$ Int -> Mod Int
forall a. a -> Mod a
Env.def Int
1000000
pure DogStatsSettings
defaultSettings
{ String
dogStatsSettingsHost :: String
dogStatsSettingsHost :: String
dogStatsSettingsHost
, Int
dogStatsSettingsPort :: Int
dogStatsSettingsPort :: Int
dogStatsSettingsPort
, Int
dogStatsSettingsMaxDelay :: Int
dogStatsSettingsMaxDelay :: Int
dogStatsSettingsMaxDelay
}
envParseDogStatsTags :: Env.Parser [Tag]
envParseDogStatsTags :: Parser [Tag]
envParseDogStatsTags =
Reader [Tag] -> String -> Mod [Tag] -> Parser [Tag]
forall a. Reader a -> String -> Mod a -> Parser a
Env.var (((Text, Text) -> Tag) -> [(Text, Text)] -> [Tag]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Text -> Tag) -> (Text, Text) -> Tag
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Text -> Tag
tag) ([(Text, Text)] -> [Tag]) -> Reader [(Text, Text)] -> Reader [Tag]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Reader [(Text, Text)]
Env.keyValues) String
"DOGSTATSD_TAGS" (Mod [Tag] -> Parser [Tag]) -> Mod [Tag] -> Parser [Tag]
forall a b. (a -> b) -> a -> b
$ [Tag] -> Mod [Tag]
forall a. a -> Mod a
Env.def []