{-# LANGUAGE TupleSections #-}
module Freckle.App.Stats
( StatsSettings
, defaultStatsSettings
, setStatsSettingsTags
, envParseStatsSettings
, StatsClient
, tagsL
, withStatsClient
, HasStatsClient(..)
, tagged
, increment
, counter
, gauge
, histogram
, histogramSince
, histogramSinceMs
) where
import Freckle.App.Prelude
import Blammo.Logging
import Control.Lens (Lens', lens, view, (&), (.~), (<>~))
import Control.Monad.Reader (local)
import Data.Aeson (Value(..))
import Data.String
import Data.Time (diffUTCTime)
import Freckle.App.Ecs
import qualified Freckle.App.Env as Env
import qualified Network.StatsD.Datadog as Datadog
import Yesod.Core.Lens
import Yesod.Core.Types (HandlerData)
data StatsSettings = StatsSettings
{ StatsSettings -> Bool
amsEnabled :: Bool
, StatsSettings -> DogStatsSettings
amsSettings :: Datadog.DogStatsSettings
, StatsSettings -> [(Text, Text)]
amsTags :: [(Text, Text)]
}
defaultStatsSettings :: StatsSettings
defaultStatsSettings :: StatsSettings
defaultStatsSettings = StatsSettings
{ amsEnabled :: Bool
amsEnabled = Bool
False
, amsSettings :: DogStatsSettings
amsSettings = DogStatsSettings
Datadog.defaultSettings
, amsTags :: [(Text, Text)]
amsTags = []
}
setStatsSettingsTags :: [(Text, Text)] -> StatsSettings -> StatsSettings
setStatsSettingsTags :: [(Text, Text)] -> StatsSettings -> StatsSettings
setStatsSettingsTags [(Text, Text)]
x StatsSettings
settings = StatsSettings
settings { amsTags :: [(Text, Text)]
amsTags = [(Text, Text)]
x }
envParseStatsSettings :: Env.Parser Env.Error StatsSettings
envParseStatsSettings :: Parser Error StatsSettings
envParseStatsSettings =
Bool -> DogStatsSettings -> [(Text, Text)] -> StatsSettings
StatsSettings
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. HostName -> Mod Flag Bool -> Parser e Bool
Env.switch HostName
"DOGSTATSD_ENABLED" forall a. Monoid a => a
mempty
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Maybe HostName -> Maybe Int -> DogStatsSettings
buildSettings
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall e a.
AsUnset e =>
Reader e a -> HostName -> Mod Var a -> Parser e a
Env.var forall s e. IsString s => Reader e s
Env.str HostName
"DOGSTATSD_HOST" forall a. Monoid a => a
mempty)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall e a.
AsUnset e =>
Reader e a -> HostName -> Mod Var a -> Parser e a
Env.var forall e a. (AsUnread e, Read a) => Reader e a
Env.auto HostName
"DOGSTATSD_PORT" forall a. Monoid a => a
mempty)
)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall {t} {a}.
IsString t =>
Maybe a -> Maybe a -> Maybe a -> [(t, a)] -> [(t, a)]
buildTags
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall e a.
AsUnset e =>
Reader e a -> HostName -> Mod Var a -> Parser e a
Env.var forall e s. (AsEmpty e, IsString s) => Reader e s
Env.nonempty HostName
"DD_ENV" forall a. Monoid a => a
mempty)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall e a.
AsUnset e =>
Reader e a -> HostName -> Mod Var a -> Parser e a
Env.var forall e s. (AsEmpty e, IsString s) => Reader e s
Env.nonempty HostName
"DD_SERVICE" forall a. Monoid a => a
mempty)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall e a.
AsUnset e =>
Reader e a -> HostName -> Mod Var a -> Parser e a
Env.var forall e s. (AsEmpty e, IsString s) => Reader e s
Env.nonempty HostName
"DD_VERSION" forall a. Monoid a => a
mempty)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall e a.
AsUnset e =>
Reader e a -> HostName -> Mod Var a -> Parser e a
Env.var Reader Error [(Text, Text)]
Env.keyValues HostName
"DOGSTATSD_TAGS" (forall a. a -> Mod Var a
Env.def [])
)
where
buildSettings :: Maybe HostName -> Maybe Int -> DogStatsSettings
buildSettings Maybe HostName
mHost Maybe Int
mPort =
DogStatsSettings
Datadog.defaultSettings
forall a b. a -> (a -> b) -> b
& forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (forall s a. HasHost s a => Lens' s a
Datadog.host forall s t a b. ASetter s t a b -> b -> s -> t
.~) Maybe HostName
mHost
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (forall s a. HasPort s a => Lens' s a
Datadog.port forall s t a b. ASetter s t a b -> b -> s -> t
.~) Maybe Int
mPort
buildTags :: Maybe a -> Maybe a -> Maybe a -> [(t, a)] -> [(t, a)]
buildTags Maybe a
mEnv Maybe a
mService Maybe a
mVersion [(t, a)]
tags =
forall a. [Maybe a] -> [a]
catMaybes
[ (t
"env", ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe a
mEnv
, (t
"environment", ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe a
mEnv
, (t
"service", ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe a
mService
, (t
"version", ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe a
mVersion
]
forall a. Semigroup a => a -> a -> a
<> [(t, a)]
tags
data StatsClient = StatsClient
{ StatsClient -> StatsClient
scClient :: Datadog.StatsClient
, StatsClient -> [(Text, Text)]
scTags :: [(Text, Text)]
}
tagsL :: Lens' StatsClient [(Text, Text)]
tagsL :: Lens' StatsClient [(Text, Text)]
tagsL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens StatsClient -> [(Text, Text)]
scTags forall a b. (a -> b) -> a -> b
$ \StatsClient
x [(Text, Text)]
y -> StatsClient
x { scTags :: [(Text, Text)]
scTags = [(Text, Text)]
y }
class HasStatsClient env where
statsClientL :: Lens' env StatsClient
instance HasStatsClient StatsClient where
statsClientL :: Lens' StatsClient StatsClient
statsClientL = forall a. a -> a
id
instance HasStatsClient site => HasStatsClient (HandlerData child site) where
statsClientL :: Lens' (HandlerData child site) StatsClient
statsClientL = forall child site.
Lens' (HandlerData child site) (RunHandlerEnv child site)
envL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall child site. Lens' (RunHandlerEnv child site) site
siteL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall env. HasStatsClient env => Lens' env StatsClient
statsClientL
withStatsClient
:: (MonadMask m, MonadUnliftIO m)
=> StatsSettings
-> (StatsClient -> m a)
-> m a
withStatsClient :: forall (m :: * -> *) a.
(MonadMask m, MonadUnliftIO m) =>
StatsSettings -> (StatsClient -> m a) -> m a
withStatsClient StatsSettings {Bool
[(Text, Text)]
DogStatsSettings
amsTags :: [(Text, Text)]
amsSettings :: DogStatsSettings
amsEnabled :: Bool
amsTags :: StatsSettings -> [(Text, Text)]
amsSettings :: StatsSettings -> DogStatsSettings
amsEnabled :: StatsSettings -> Bool
..} StatsClient -> m a
f = do
if Bool
amsEnabled
then do
[(Text, Text)]
tags <- ([(Text, Text)]
amsTags forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadIO m => m [(Text, Text)]
getEcsMetadataTags
forall (m :: * -> *) a.
MonadUnliftIO m =>
DogStatsSettings -> (StatsClient -> m a) -> m a
Datadog.withDogStatsD DogStatsSettings
amsSettings forall a b. (a -> b) -> a -> b
$ \StatsClient
client ->
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[Pair] -> m a -> m a
withThreadContext (forall a b. (a -> b) -> [a] -> [b]
map forall {p :: * -> * -> *} {b}.
(Bifunctor p, IsString b) =>
p Text Text -> p b Value
toPair [(Text, Text)]
tags)
forall a b. (a -> b) -> a -> b
$ StatsClient -> m a
f StatsClient { scClient :: StatsClient
scClient = StatsClient
client, scTags :: [(Text, Text)]
scTags = [(Text, Text)]
tags }
else StatsClient -> m a
f forall a b. (a -> b) -> a -> b
$ StatsClient { scClient :: StatsClient
scClient = StatsClient
Datadog.Dummy, scTags :: [(Text, Text)]
scTags = [(Text, Text)]
amsTags }
where toPair :: p Text Text -> p b Value
toPair = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (forall a. IsString a => HostName -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> HostName
unpack) Text -> Value
String
tagged
:: (MonadReader env m, HasStatsClient env) => [(Text, Text)] -> m a -> m a
tagged :: forall env (m :: * -> *) a.
(MonadReader env m, HasStatsClient env) =>
[(Text, Text)] -> m a -> m a
tagged [(Text, Text)]
tags = forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local forall a b. (a -> b) -> a -> b
$ forall env. HasStatsClient env => Lens' env StatsClient
statsClientL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' StatsClient [(Text, Text)]
tagsL forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ [(Text, Text)]
tags
increment
:: (MonadUnliftIO m, MonadReader env m, HasStatsClient env) => Text -> m ()
increment :: forall (m :: * -> *) env.
(MonadUnliftIO m, MonadReader env m, HasStatsClient env) =>
Text -> m ()
increment Text
name = forall (m :: * -> *) env.
(MonadUnliftIO m, MonadReader env m, HasStatsClient env) =>
Text -> Int -> m ()
counter Text
name Int
1
counter
:: (MonadUnliftIO m, MonadReader env m, HasStatsClient env)
=> Text
-> Int
-> m ()
counter :: forall (m :: * -> *) env.
(MonadUnliftIO m, MonadReader env m, HasStatsClient env) =>
Text -> Int -> m ()
counter = forall (m :: * -> *) env v.
(MonadUnliftIO m, MonadReader env m, HasStatsClient env,
ToMetricValue v) =>
MetricType -> Text -> v -> m ()
sendMetric MetricType
Datadog.Counter
gauge
:: (MonadUnliftIO m, MonadReader env m, HasStatsClient env)
=> Text
-> Double
-> m ()
gauge :: forall (m :: * -> *) env.
(MonadUnliftIO m, MonadReader env m, HasStatsClient env) =>
Text -> Double -> m ()
gauge = forall (m :: * -> *) env v.
(MonadUnliftIO m, MonadReader env m, HasStatsClient env,
ToMetricValue v) =>
MetricType -> Text -> v -> m ()
sendMetric MetricType
Datadog.Gauge
histogram
:: ( MonadUnliftIO m
, MonadReader env m
, HasStatsClient env
, Datadog.ToMetricValue n
)
=> Text
-> n
-> m ()
histogram :: forall (m :: * -> *) env n.
(MonadUnliftIO m, MonadReader env m, HasStatsClient env,
ToMetricValue n) =>
Text -> n -> m ()
histogram = forall (m :: * -> *) env v.
(MonadUnliftIO m, MonadReader env m, HasStatsClient env,
ToMetricValue v) =>
MetricType -> Text -> v -> m ()
sendMetric MetricType
Datadog.Histogram
histogramSince
:: (MonadUnliftIO m, MonadReader env m, HasStatsClient env)
=> Text
-> UTCTime
-> m ()
histogramSince :: forall (m :: * -> *) env.
(MonadUnliftIO m, MonadReader env m, HasStatsClient env) =>
Text -> UTCTime -> m ()
histogramSince = forall (m :: * -> *) env n.
(MonadUnliftIO m, MonadReader env m, HasStatsClient env,
ToMetricValue n) =>
(NominalDiffTime -> n) -> Text -> UTCTime -> m ()
histogramSinceBy forall {w}. RealFrac w => w -> Int
toSeconds where toSeconds :: w -> Int
toSeconds = forall a b. (RealFrac a, Integral b) => a -> b
round @_ @Int
histogramSinceMs
:: (MonadUnliftIO m, MonadReader env m, HasStatsClient env)
=> Text
-> UTCTime
-> m ()
histogramSinceMs :: forall (m :: * -> *) env.
(MonadUnliftIO m, MonadReader env m, HasStatsClient env) =>
Text -> UTCTime -> m ()
histogramSinceMs = forall (m :: * -> *) env n.
(MonadUnliftIO m, MonadReader env m, HasStatsClient env,
ToMetricValue n) =>
(NominalDiffTime -> n) -> Text -> UTCTime -> m ()
histogramSinceBy forall {a}. Real a => a -> Double
toMilliseconds
where toMilliseconds :: a -> Double
toMilliseconds = (forall a. Num a => a -> a -> a
* Double
1000) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Real a, Fractional b) => a -> b
realToFrac @_ @Double
histogramSinceBy
:: ( MonadUnliftIO m
, MonadReader env m
, HasStatsClient env
, Datadog.ToMetricValue n
)
=> (NominalDiffTime -> n)
-> Text
-> UTCTime
-> m ()
histogramSinceBy :: forall (m :: * -> *) env n.
(MonadUnliftIO m, MonadReader env m, HasStatsClient env,
ToMetricValue n) =>
(NominalDiffTime -> n) -> Text -> UTCTime -> m ()
histogramSinceBy NominalDiffTime -> n
f Text
name UTCTime
time = do
UTCTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
let delta :: n
delta = NominalDiffTime -> n
f forall a b. (a -> b) -> a -> b
$ UTCTime
now UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
time
forall (m :: * -> *) env v.
(MonadUnliftIO m, MonadReader env m, HasStatsClient env,
ToMetricValue v) =>
MetricType -> Text -> v -> m ()
sendMetric MetricType
Datadog.Histogram Text
name n
delta
sendMetric
:: ( MonadUnliftIO m
, MonadReader env m
, HasStatsClient env
, Datadog.ToMetricValue v
)
=> Datadog.MetricType
-> Text
-> v
-> m ()
sendMetric :: forall (m :: * -> *) env v.
(MonadUnliftIO m, MonadReader env m, HasStatsClient env,
ToMetricValue v) =>
MetricType -> Text -> v -> m ()
sendMetric MetricType
metricType Text
name v
metricValue = do
StatsClient {[(Text, Text)]
StatsClient
scTags :: [(Text, Text)]
scClient :: StatsClient
scTags :: StatsClient -> [(Text, Text)]
scClient :: StatsClient -> StatsClient
..} <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasStatsClient env => Lens' env StatsClient
statsClientL
forall (m :: * -> *) v.
(MonadIO m, ToStatsD v) =>
StatsClient -> v -> m ()
Datadog.send StatsClient
scClient
forall a b. (a -> b) -> a -> b
$ forall a.
ToMetricValue a =>
MetricName -> MetricType -> a -> Metric
Datadog.metric (Text -> MetricName
Datadog.MetricName Text
name) MetricType
metricType v
metricValue
forall a b. a -> (a -> b) -> b
& (forall s a. HasTags s a => Lens' s a
Datadog.tags forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Text -> Tag
Datadog.tag) [(Text, Text)]
scTags)
getEcsMetadataTags :: MonadIO m => m [(Text, Text)]
getEcsMetadataTags :: forall (m :: * -> *). MonadIO m => m [(Text, Text)]
getEcsMetadataTags = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] forall {a}. IsString a => EcsMetadata -> [(a, Text)]
toTags forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadIO m => m (Maybe EcsMetadata)
getEcsMetadata
where
toTags :: EcsMetadata -> [(a, Text)]
toTags (EcsMetadata EcsContainerMetadata {Text
ecmImageID :: EcsContainerMetadata -> Text
ecmImage :: EcsContainerMetadata -> Text
ecmDockerName :: EcsContainerMetadata -> Text
ecmDockerId :: EcsContainerMetadata -> Text
ecmImageID :: Text
ecmImage :: Text
ecmDockerName :: Text
ecmDockerId :: Text
..} EcsContainerTaskMetadata {Text
ectmRevision :: EcsContainerTaskMetadata -> Text
ectmFamily :: EcsContainerTaskMetadata -> Text
ectmTaskARN :: EcsContainerTaskMetadata -> Text
ectmCluster :: EcsContainerTaskMetadata -> Text
ectmRevision :: Text
ectmFamily :: Text
ectmTaskARN :: Text
ectmCluster :: Text
..})
= [ (a
"container_id", Text
ecmDockerId)
, (a
"container_name", Text
ecmDockerName)
, (a
"docker_image", Text
ecmImage)
, (a
"image_tag", Text
ecmImageID)
, (a
"cluster_name", Text
ectmCluster)
, (a
"task_arn", Text
ectmTaskARN)
, (a
"task_family", Text
ectmFamily)
, (a
"task_version", Text
ectmRevision)
]