{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE NamedFieldPuns #-}

-- | Datadog access for your @App@
module Freckle.App.Datadog
  (
  -- * Reader environment interface
    HasDogStatsClient(..)
  , HasDogStatsTags(..)
  , StatsClient
  , Tag

  -- * Lower-level operations
  , sendAppMetricWithTags

  -- * Higher-level operations
  , increment
  , counter
  , gauge
  , histogram
  , histogramSince
  , histogramSinceMs

  -- * Reading settings at startup
  , DogStatsSettings(..)
  , envParseDogStatsEnabled
  , envParseDogStatsSettings
  , envParseDogStatsTags
  , mkStatsClient

  -- * To be removed in next major bump
  , 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" #-}
-- | Deprecated typo version of 'gauge'
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
  -- N.B. NominalDiffTime is treated as seconds when using round. Replace round
  -- with nominalDiffTimeToSeconds once we upgrade our version of the time
  -- library.
        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 []