{-# LANGUAGE TupleSections #-}

-- | An intentionally-leaky StatsD interface to Datadog
--
-- $usage
--
module Freckle.App.Stats
  ( StatsSettings
  , defaultStatsSettings
  , setStatsSettingsTags
  , envParseStatsSettings

  -- * Client
  , StatsClient
  , tagsL
  , withStatsClient
  , HasStatsClient(..)

  -- * Reporting
  , 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 -- Legacy
        , (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 ->
        -- Add the tags to the thread context so they're present in all logs
        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

-- | Include the given tags on all metrics emitted from a block
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

-- | Synonym for @'counter' 1@
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

-- | Emit an elapsed duration (which Datadog calls a /histogram/)
--
-- The 'ToMetricValue' constraint can be satisfied by most numeric types and is
-- assumed to be seconds.
--
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)
      ]

-- $usage
-- Usage:
--
-- - Use 'envParseStatsSettings' to configure things
--
--   @
--   data AppSettings = AppSettings
--    { -- ...
--    , appStatsSettings :: StatsSettings
--    }
--
--   loadSettings :: IO AppSettings
--   loadSettings = Env.parse id $ AppSettings
--     <$> -- ...
--     <*> 'envParseStatsSettings'
--   @
--
--   This will read,
--
--   - @DOGSTATSD_ENABLED=x@
--   - @DOGSTATSD_HOST=127.0.0.1@
--   - @DOGSTATSD_PORT=8125@
--   - @DOGSTATSD_TAGS=[<key>:<value>,...]@
--   - Optionally @DD_ENV@, @DD_SERVICE@, and @DD_VERSION@
--
-- - Give your @App@ a 'HasStatsClient' instance
--
--   @
--   data App = App
--     { -- ...
--     , appStatsClient :: 'StatsClient'
--     }
--
--   instance 'HasStatsClient' App where
--     'statsClientL' = lens appStatsClient $ \x y -> { appStatsClient = y }
--   @
--
-- - Use 'withStatsClient' to build and store a client on your @App@ when you
--   run it
--
--   @
--   'withStatsClient' appStatsSettings $ \client -> do
--     app <- App
--       <$> ...
--       <*> pure client
--
--     'runApp' app $ ...
--   @
--
-- - Throughout your application code, emit metrics as desired
--
--   @
--   import qualified Freckle.App.Stats as Stats
--
--   myFunction :: (MonadIO m, MonadReader env m, 'HasStatsClient' env) => m ()
--   myFunction = do
--     start <- liftIO getCurrentTime
--     result <- myAction
--
--     Stats.'increment' \"action.attempt\"
--     Stats.'histogramSinceMs' \"action.duration\" start
--
--     case result of
--       Left err -> do
--         Stats.'increment' \"action.failure\"
--         -- ...
--       Right x -. do
--         Stats.'increment' \"action.success\"
--         -- ...
--   @
--