{-# OPTIONS_GHC -fno-warn-type-defaults #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE CPP #-}
module System.Metrics.Prometheus.Ridley (
    startRidley
  , startRidleyWithStore
  -- * Handy re-exports
  , prometheusOptions
  , ridleyMetrics
  , AdapterOptions(..)
  , RidleyCtx
  , ridleyWaiMetrics
  , ridleyThreadId
  , katipScribes
  , dataRetentionPeriod
  , samplingFrequency
  , namespace
  , labels
  , newOptions
  , defaultMetrics
  ) where

import           Control.AutoUpdate as Auto
import           Control.Concurrent (threadDelay, forkIO)
import           Control.Concurrent.Async
import           Control.Concurrent.MVar
import qualified Control.Exception.Safe as Ex
import           Control.Monad (foldM)
import           Control.Monad.IO.Class (liftIO, MonadIO)
import           Control.Monad.Reader (asks)
import           Control.Monad.Trans.Class (lift)
import           Data.IORef
import qualified Data.List as List
import           Data.Map.Strict as M
import qualified Data.Set as Set
import           Data.String
import qualified Data.Text as T
import           Data.Time
import           GHC.Conc (getNumCapabilities, getNumProcessors)
import           GHC.Stack
import           Katip
import           Lens.Micro
import           Lens.Micro.Extras (view)
import           Network.Wai.Metrics (registerWaiMetrics)
import           System.Metrics as EKG
#if (MIN_VERSION_prometheus(0,5,0))
import qualified System.Metrics.Prometheus.Http.Scrape as P
#else
import qualified System.Metrics.Prometheus.Concurrent.Http as P
#endif
import           System.Metrics.Prometheus.Metric.Counter (add)
import qualified System.Metrics.Prometheus.RegistryT as P
import           System.Metrics.Prometheus.Registry (RegistrySample)
import           System.Metrics.Prometheus.Ridley.Metrics.CPU
import           System.Metrics.Prometheus.Ridley.Metrics.DiskUsage
import           System.Metrics.Prometheus.Ridley.Metrics.Memory
import           System.Metrics.Prometheus.Ridley.Metrics.Network
import           System.Metrics.Prometheus.Ridley.Types
import           System.Metrics.Prometheus.Ridley.Types.Internal
import           System.Remote.Monitoring.Prometheus

--------------------------------------------------------------------------------
startRidley :: RidleyOptions
            -> P.Path
            -> Port
            -> IO RidleyCtx
startRidley :: RidleyOptions -> Path -> Int -> IO RidleyCtx
startRidley RidleyOptions
opts Path
path Int
port = do
  Store
store <- IO Store
EKG.newStore
  Store -> IO ()
EKG.registerGcMetrics Store
store
  RidleyOptions -> Path -> Int -> Store -> IO RidleyCtx
startRidleyWithStore RidleyOptions
opts Path
path Int
port Store
store

--------------------------------------------------------------------------------
registerMetrics :: Set.Set RidleyMetric -> Ridley [RidleyMetricHandler]
registerMetrics :: Set RidleyMetric -> Ridley [RidleyMetricHandler]
registerMetrics = ([RidleyMetricHandler]
 -> RidleyMetric -> Ridley [RidleyMetricHandler])
-> [RidleyMetricHandler]
-> Set RidleyMetric
-> Ridley [RidleyMetricHandler]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM [RidleyMetricHandler]
-> RidleyMetric -> Ridley [RidleyMetricHandler]
registerSingleMetric []
  where
    registerSingleMetric :: [RidleyMetricHandler] -> RidleyMetric -> Ridley [RidleyMetricHandler]
    registerSingleMetric :: [RidleyMetricHandler]
-> RidleyMetric -> Ridley [RidleyMetricHandler]
registerSingleMetric ![RidleyMetricHandler]
acc RidleyMetric
x = case RidleyMetric
x of
        CustomMetric Text
metricName Maybe Int
mb_timeout Ridley RidleyMetricHandler
custom
          -> RidleyMetric
-> [RidleyMetricHandler]
-> Ridley RidleyMetricHandler
-> Ridley [RidleyMetricHandler]
tryRegister RidleyMetric
x [RidleyMetricHandler]
acc (Ridley RidleyMetricHandler -> Ridley [RidleyMetricHandler])
-> Ridley RidleyMetricHandler -> Ridley [RidleyMetricHandler]
forall a b. (a -> b) -> a -> b
$ Text
-> Maybe Int
-> Ridley RidleyMetricHandler
-> Ridley RidleyMetricHandler
registerCustomMetric Text
metricName Maybe Int
mb_timeout Ridley RidleyMetricHandler
custom
        RidleyMetric
ProcessMemory
          -> RidleyMetric
-> [RidleyMetricHandler]
-> Ridley RidleyMetricHandler
-> Ridley [RidleyMetricHandler]
tryRegister RidleyMetric
x [RidleyMetricHandler]
acc Ridley RidleyMetricHandler
registerProcessMemory
        RidleyMetric
CPULoad
          -> RidleyMetric
-> [RidleyMetricHandler]
-> Ridley RidleyMetricHandler
-> Ridley [RidleyMetricHandler]
tryRegister RidleyMetric
x [RidleyMetricHandler]
acc Ridley RidleyMetricHandler
registerCPULoad
        RidleyMetric
GHCConc
          -> RidleyMetric
-> [RidleyMetricHandler]
-> Ridley RidleyMetricHandler
-> Ridley [RidleyMetricHandler]
tryRegister RidleyMetric
x [RidleyMetricHandler]
acc Ridley RidleyMetricHandler
registerGHCConc
        RidleyMetric
Wai
          -> [RidleyMetricHandler] -> Ridley [RidleyMetricHandler]
forall a. a -> RidleyT (RegistryT (KatipContextT IO)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [RidleyMetricHandler]
acc -- Ignore `Wai` as we will use an external library for that.
        RidleyMetric
DiskUsage
          -> RidleyMetric
-> [RidleyMetricHandler]
-> Ridley RidleyMetricHandler
-> Ridley [RidleyMetricHandler]
tryRegister RidleyMetric
x [RidleyMetricHandler]
acc Ridley RidleyMetricHandler
registerDiskUsage
        RidleyMetric
Network
          -> RidleyMetric
-> [RidleyMetricHandler]
-> Ridley RidleyMetricHandler
-> Ridley [RidleyMetricHandler]
tryRegister RidleyMetric
x [RidleyMetricHandler]
acc Ridley RidleyMetricHandler
registerNetworkMetric

tryRegister :: RidleyMetric -> [RidleyMetricHandler] -> Ridley RidleyMetricHandler -> Ridley [RidleyMetricHandler]
tryRegister :: RidleyMetric
-> [RidleyMetricHandler]
-> Ridley RidleyMetricHandler
-> Ridley [RidleyMetricHandler]
tryRegister RidleyMetric
metric ![RidleyMetricHandler]
acc Ridley RidleyMetricHandler
doRegister = do
  Either SomeException RidleyMetricHandler
registrationResult <- Ridley RidleyMetricHandler
-> RidleyT
     (RegistryT (KatipContextT IO))
     (Either SomeException RidleyMetricHandler)
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> m (Either SomeException a)
Ex.tryAny Ridley RidleyMetricHandler
doRegister
  case Either SomeException RidleyMetricHandler
registrationResult of
    Left SomeException
ex -> do
      $(logTM) Severity
ErrorS (LogStr -> RidleyT (RegistryT (KatipContextT IO)) ())
-> LogStr -> RidleyT (RegistryT (KatipContextT IO)) ()
forall a b. (a -> b) -> a -> b
$ Text -> LogStr
forall a. StringConv a Text => a -> LogStr
ls (Text -> LogStr) -> Text -> LogStr
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Registration of metric '" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> RidleyMetric -> String
forall a. Show a => a -> String
show RidleyMetric
metric String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"' failed due to: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall a. Show a => a -> String
show SomeException
ex
      [RidleyMetricHandler] -> Ridley [RidleyMetricHandler]
forall a. a -> RidleyT (RegistryT (KatipContextT IO)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [RidleyMetricHandler]
acc
    Right RidleyMetricHandler
metricHandler -> [RidleyMetricHandler] -> Ridley [RidleyMetricHandler]
forall a. a -> RidleyT (RegistryT (KatipContextT IO)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([RidleyMetricHandler] -> Ridley [RidleyMetricHandler])
-> [RidleyMetricHandler] -> Ridley [RidleyMetricHandler]
forall a b. (a -> b) -> a -> b
$! RidleyMetricHandler
metricHandler RidleyMetricHandler
-> [RidleyMetricHandler] -> [RidleyMetricHandler]
forall a. a -> [a] -> [a]
: [RidleyMetricHandler]
acc

registerProcessMemory :: Ridley RidleyMetricHandler
registerProcessMemory :: Ridley RidleyMetricHandler
registerProcessMemory = do
  Severity
sev   <- (RidleyOptions -> Severity)
-> RidleyT (RegistryT (KatipContextT IO)) Severity
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Getting Severity RidleyOptions Severity
-> RidleyOptions -> Severity
forall a s. Getting a s a -> s -> a
view Getting Severity RidleyOptions Severity
Lens' RidleyOptions Severity
katipSeverity)
  PrometheusOptions
popts <- (RidleyOptions -> PrometheusOptions)
-> RidleyT (RegistryT (KatipContextT IO)) PrometheusOptions
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Getting PrometheusOptions RidleyOptions PrometheusOptions
-> RidleyOptions -> PrometheusOptions
forall a s. Getting a s a -> s -> a
view Getting PrometheusOptions RidleyOptions PrometheusOptions
Lens' RidleyOptions PrometheusOptions
prometheusOptions)
  Logger
logger <- Ridley Logger
ioLogger
  Gauge
processReservedMemory <- RegistryT (KatipContextT IO) Gauge
-> RidleyT (RegistryT (KatipContextT IO)) Gauge
forall (m :: * -> *) a. Monad m => m a -> RidleyT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RegistryT (KatipContextT IO) Gauge
 -> RidleyT (RegistryT (KatipContextT IO)) Gauge)
-> RegistryT (KatipContextT IO) Gauge
-> RidleyT (RegistryT (KatipContextT IO)) Gauge
forall a b. (a -> b) -> a -> b
$ Name -> Labels -> RegistryT (KatipContextT IO) Gauge
forall (m :: * -> *).
MonadIO m =>
Name -> Labels -> RegistryT m Gauge
P.registerGauge Name
"process_memory_kb" (PrometheusOptions
popts PrometheusOptions
-> Getting Labels PrometheusOptions Labels -> Labels
forall s a. s -> Getting a s a -> a
^. Getting Labels PrometheusOptions Labels
Lens' PrometheusOptions Labels
labels)
  let !m :: RidleyMetricHandler
m = Logger -> Gauge -> RidleyMetricHandler
processMemory Logger
logger Gauge
processReservedMemory
  $(logTM) Severity
sev LogStr
"Registering ProcessMemory metric..."
  RidleyMetricHandler -> Ridley RidleyMetricHandler
forall a. a -> RidleyT (RegistryT (KatipContextT IO)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RidleyMetricHandler
m

registerCPULoad :: Ridley RidleyMetricHandler
registerCPULoad :: Ridley RidleyMetricHandler
registerCPULoad = do
  Severity
sev   <- (RidleyOptions -> Severity)
-> RidleyT (RegistryT (KatipContextT IO)) Severity
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Getting Severity RidleyOptions Severity
-> RidleyOptions -> Severity
forall a s. Getting a s a -> s -> a
view Getting Severity RidleyOptions Severity
Lens' RidleyOptions Severity
katipSeverity)
  PrometheusOptions
popts <- (RidleyOptions -> PrometheusOptions)
-> RidleyT (RegistryT (KatipContextT IO)) PrometheusOptions
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Getting PrometheusOptions RidleyOptions PrometheusOptions
-> RidleyOptions -> PrometheusOptions
forall a s. Getting a s a -> s -> a
view Getting PrometheusOptions RidleyOptions PrometheusOptions
Lens' RidleyOptions PrometheusOptions
prometheusOptions)
  Gauge
cpu1m  <- RegistryT (KatipContextT IO) Gauge
-> RidleyT (RegistryT (KatipContextT IO)) Gauge
forall (m :: * -> *) a. Monad m => m a -> RidleyT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RegistryT (KatipContextT IO) Gauge
 -> RidleyT (RegistryT (KatipContextT IO)) Gauge)
-> RegistryT (KatipContextT IO) Gauge
-> RidleyT (RegistryT (KatipContextT IO)) Gauge
forall a b. (a -> b) -> a -> b
$ Name -> Labels -> RegistryT (KatipContextT IO) Gauge
forall (m :: * -> *).
MonadIO m =>
Name -> Labels -> RegistryT m Gauge
P.registerGauge Name
"cpu_load1"  (PrometheusOptions
popts PrometheusOptions
-> Getting Labels PrometheusOptions Labels -> Labels
forall s a. s -> Getting a s a -> a
^. Getting Labels PrometheusOptions Labels
Lens' PrometheusOptions Labels
labels)
  Gauge
cpu5m  <- RegistryT (KatipContextT IO) Gauge
-> RidleyT (RegistryT (KatipContextT IO)) Gauge
forall (m :: * -> *) a. Monad m => m a -> RidleyT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RegistryT (KatipContextT IO) Gauge
 -> RidleyT (RegistryT (KatipContextT IO)) Gauge)
-> RegistryT (KatipContextT IO) Gauge
-> RidleyT (RegistryT (KatipContextT IO)) Gauge
forall a b. (a -> b) -> a -> b
$ Name -> Labels -> RegistryT (KatipContextT IO) Gauge
forall (m :: * -> *).
MonadIO m =>
Name -> Labels -> RegistryT m Gauge
P.registerGauge Name
"cpu_load5"  (PrometheusOptions
popts PrometheusOptions
-> Getting Labels PrometheusOptions Labels -> Labels
forall s a. s -> Getting a s a -> a
^. Getting Labels PrometheusOptions Labels
Lens' PrometheusOptions Labels
labels)
  Gauge
cpu15m <- RegistryT (KatipContextT IO) Gauge
-> RidleyT (RegistryT (KatipContextT IO)) Gauge
forall (m :: * -> *) a. Monad m => m a -> RidleyT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RegistryT (KatipContextT IO) Gauge
 -> RidleyT (RegistryT (KatipContextT IO)) Gauge)
-> RegistryT (KatipContextT IO) Gauge
-> RidleyT (RegistryT (KatipContextT IO)) Gauge
forall a b. (a -> b) -> a -> b
$ Name -> Labels -> RegistryT (KatipContextT IO) Gauge
forall (m :: * -> *).
MonadIO m =>
Name -> Labels -> RegistryT m Gauge
P.registerGauge Name
"cpu_load15" (PrometheusOptions
popts PrometheusOptions
-> Getting Labels PrometheusOptions Labels -> Labels
forall s a. s -> Getting a s a -> a
^. Getting Labels PrometheusOptions Labels
Lens' PrometheusOptions Labels
labels)
  let !cpu :: RidleyMetricHandler
cpu = (Gauge, Gauge, Gauge) -> RidleyMetricHandler
processCPULoad (Gauge
cpu1m, Gauge
cpu5m, Gauge
cpu15m)
  $(logTM) Severity
sev LogStr
"Registering CPULoad metric..."
  RidleyMetricHandler -> Ridley RidleyMetricHandler
forall a. a -> RidleyT (RegistryT (KatipContextT IO)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RidleyMetricHandler
cpu

registerGHCConc :: Ridley RidleyMetricHandler
registerGHCConc :: Ridley RidleyMetricHandler
registerGHCConc = do
  Severity
sev   <- (RidleyOptions -> Severity)
-> RidleyT (RegistryT (KatipContextT IO)) Severity
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Getting Severity RidleyOptions Severity
-> RidleyOptions -> Severity
forall a s. Getting a s a -> s -> a
view Getting Severity RidleyOptions Severity
Lens' RidleyOptions Severity
katipSeverity)
  PrometheusOptions
popts <- (RidleyOptions -> PrometheusOptions)
-> RidleyT (RegistryT (KatipContextT IO)) PrometheusOptions
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Getting PrometheusOptions RidleyOptions PrometheusOptions
-> RidleyOptions -> PrometheusOptions
forall a s. Getting a s a -> s -> a
view Getting PrometheusOptions RidleyOptions PrometheusOptions
Lens' RidleyOptions PrometheusOptions
prometheusOptions)
  -- We don't want to keep updating this as it's a one-shot measure.
  Counter
numCaps  <- RegistryT (KatipContextT IO) Counter
-> RidleyT (RegistryT (KatipContextT IO)) Counter
forall (m :: * -> *) a. Monad m => m a -> RidleyT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RegistryT (KatipContextT IO) Counter
 -> RidleyT (RegistryT (KatipContextT IO)) Counter)
-> RegistryT (KatipContextT IO) Counter
-> RidleyT (RegistryT (KatipContextT IO)) Counter
forall a b. (a -> b) -> a -> b
$ Name -> Labels -> RegistryT (KatipContextT IO) Counter
forall (m :: * -> *).
MonadIO m =>
Name -> Labels -> RegistryT m Counter
P.registerCounter Name
"ghc_conc_num_capabilities"  (PrometheusOptions
popts PrometheusOptions
-> Getting Labels PrometheusOptions Labels -> Labels
forall s a. s -> Getting a s a -> a
^. Getting Labels PrometheusOptions Labels
Lens' PrometheusOptions Labels
labels)
  Counter
numPros  <- RegistryT (KatipContextT IO) Counter
-> RidleyT (RegistryT (KatipContextT IO)) Counter
forall (m :: * -> *) a. Monad m => m a -> RidleyT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RegistryT (KatipContextT IO) Counter
 -> RidleyT (RegistryT (KatipContextT IO)) Counter)
-> RegistryT (KatipContextT IO) Counter
-> RidleyT (RegistryT (KatipContextT IO)) Counter
forall a b. (a -> b) -> a -> b
$ Name -> Labels -> RegistryT (KatipContextT IO) Counter
forall (m :: * -> *).
MonadIO m =>
Name -> Labels -> RegistryT m Counter
P.registerCounter Name
"ghc_conc_num_processors"    (PrometheusOptions
popts PrometheusOptions
-> Getting Labels PrometheusOptions Labels -> Labels
forall s a. s -> Getting a s a -> a
^. Getting Labels PrometheusOptions Labels
Lens' PrometheusOptions Labels
labels)
  IO () -> RidleyT (RegistryT (KatipContextT IO)) ()
forall a. IO a -> RidleyT (RegistryT (KatipContextT IO)) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int
getNumCapabilities IO Int -> (Int -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
cap -> Int -> Counter -> IO ()
add (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
cap) Counter
numCaps)
  IO () -> RidleyT (RegistryT (KatipContextT IO)) ()
forall a. IO a -> RidleyT (RegistryT (KatipContextT IO)) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int
getNumProcessors IO Int -> (Int -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
cap -> Int -> Counter -> IO ()
add (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
cap) Counter
numPros)
  $(logTM) Severity
sev LogStr
"Registering GHCConc metric..."
  RidleyMetricHandler -> Ridley RidleyMetricHandler
forall a. a -> RidleyT (RegistryT (KatipContextT IO)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RidleyMetricHandler -> Ridley RidleyMetricHandler)
-> RidleyMetricHandler -> Ridley RidleyMetricHandler
forall a b. (a -> b) -> a -> b
$ Text
-> (Counter, Counter)
-> ((Counter, Counter) -> Bool -> IO ())
-> Bool
-> RidleyMetricHandler
forall c.
HasCallStack =>
Text -> c -> (c -> Bool -> IO ()) -> Bool -> RidleyMetricHandler
mkRidleyMetricHandler Text
"ridley-ghc-conc" (Counter
numCaps, Counter
numPros) (Counter, Counter) -> Bool -> IO ()
forall c. c -> Bool -> IO ()
noUpdate Bool
False

registerDiskUsage :: Ridley RidleyMetricHandler
registerDiskUsage :: Ridley RidleyMetricHandler
registerDiskUsage = do
  Severity
sev   <- (RidleyOptions -> Severity)
-> RidleyT (RegistryT (KatipContextT IO)) Severity
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Getting Severity RidleyOptions Severity
-> RidleyOptions -> Severity
forall a s. Getting a s a -> s -> a
view Getting Severity RidleyOptions Severity
Lens' RidleyOptions Severity
katipSeverity)
  RidleyMetricHandler
diskUsage <- Ridley RidleyMetricHandler
newDiskUsageMetrics
  $(logTM) Severity
sev LogStr
"Registering DiskUsage metric..."
  RidleyMetricHandler -> Ridley RidleyMetricHandler
forall a. a -> RidleyT (RegistryT (KatipContextT IO)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RidleyMetricHandler
diskUsage

registerCustomMetric :: T.Text -> Maybe Int -> Ridley RidleyMetricHandler -> Ridley RidleyMetricHandler
registerCustomMetric :: Text
-> Maybe Int
-> Ridley RidleyMetricHandler
-> Ridley RidleyMetricHandler
registerCustomMetric Text
metricName Maybe Int
mb_timeout Ridley RidleyMetricHandler
custom = do
  RidleyOptions
opts    <- Ridley RidleyOptions
getRidleyOptions
  let sev :: Severity
sev = RidleyOptions
opts RidleyOptions
-> Getting Severity RidleyOptions Severity -> Severity
forall s a. s -> Getting a s a -> a
^. Getting Severity RidleyOptions Severity
Lens' RidleyOptions Severity
katipSeverity
  LogEnv
le      <- RidleyT (RegistryT (KatipContextT IO)) LogEnv
forall (m :: * -> *). Katip m => m LogEnv
getLogEnv
  RidleyMetricHandler
customMetric <- case Maybe Int
mb_timeout of
    Maybe Int
Nothing   -> Ridley RidleyMetricHandler
custom
    Just Int
microseconds -> do
      RidleyMetricHandler c
mtr c -> Bool -> IO ()
upd Bool
flsh Text
lbl CallStack
cs <- Ridley RidleyMetricHandler
custom
      IO ()
doUpdate <- IO (IO ()) -> RidleyT (RegistryT (KatipContextT IO)) (IO ())
forall a. IO a -> RidleyT (RegistryT (KatipContextT IO)) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IO ()) -> RidleyT (RegistryT (KatipContextT IO)) (IO ()))
-> IO (IO ()) -> RidleyT (RegistryT (KatipContextT IO)) (IO ())
forall a b. (a -> b) -> a -> b
$ UpdateSettings () -> IO (IO ())
forall a. UpdateSettings a -> IO (IO a)
Auto.mkAutoUpdate UpdateSettings ()
Auto.defaultUpdateSettings
                    { updateAction = upd mtr flsh `Ex.catch` logFailedUpdate le lbl cs
                    , updateFreq   = microseconds
                    }
      RidleyMetricHandler -> Ridley RidleyMetricHandler
forall a. a -> RidleyT (RegistryT (KatipContextT IO)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RidleyMetricHandler -> Ridley RidleyMetricHandler)
-> RidleyMetricHandler -> Ridley RidleyMetricHandler
forall a b. (a -> b) -> a -> b
$ c
-> (c -> Bool -> IO ())
-> Bool
-> Text
-> CallStack
-> RidleyMetricHandler
forall c.
c
-> (c -> Bool -> IO ())
-> Bool
-> Text
-> CallStack
-> RidleyMetricHandler
RidleyMetricHandler c
mtr (\c
_ Bool
_ -> IO ()
doUpdate) Bool
flsh Text
lbl CallStack
cs
  $(logTM) Severity
sev (LogStr -> RidleyT (RegistryT (KatipContextT IO)) ())
-> LogStr -> RidleyT (RegistryT (KatipContextT IO)) ()
forall a b. (a -> b) -> a -> b
$ LogStr
"Registering CustomMetric '" LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> String -> LogStr
forall a. IsString a => String -> a
fromString (Text -> String
T.unpack Text
metricName) LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
"'..."
  RidleyMetricHandler -> Ridley RidleyMetricHandler
forall a. a -> RidleyT (RegistryT (KatipContextT IO)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RidleyMetricHandler
customMetric

registerNetworkMetric :: Ridley RidleyMetricHandler
registerNetworkMetric :: Ridley RidleyMetricHandler
registerNetworkMetric = do
  Severity
sev   <- (RidleyOptions -> Severity)
-> RidleyT (RegistryT (KatipContextT IO)) Severity
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Getting Severity RidleyOptions Severity
-> RidleyOptions -> Severity
forall a s. Getting a s a -> s -> a
view Getting Severity RidleyOptions Severity
Lens' RidleyOptions Severity
katipSeverity)
  PrometheusOptions
popts <- (RidleyOptions -> PrometheusOptions)
-> RidleyT (RegistryT (KatipContextT IO)) PrometheusOptions
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Getting PrometheusOptions RidleyOptions PrometheusOptions
-> RidleyOptions -> PrometheusOptions
forall a s. Getting a s a -> s -> a
view Getting PrometheusOptions RidleyOptions PrometheusOptions
Lens' RidleyOptions PrometheusOptions
prometheusOptions)
#if defined darwin_HOST_OS
  (ifaces, dtor) <- liftIO getNetworkMetrics
  imap   <- lift $ foldM (mkInterfaceGauge (popts ^. labels)) M.empty ifaces
  liftIO dtor
#else
  [IfData]
ifaces <- IO [IfData] -> RidleyT (RegistryT (KatipContextT IO)) [IfData]
forall a. IO a -> RidleyT (RegistryT (KatipContextT IO)) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [IfData]
getNetworkMetrics
  NetworkMetrics
imap   <- RegistryT (KatipContextT IO) NetworkMetrics
-> RidleyT (RegistryT (KatipContextT IO)) NetworkMetrics
forall (m :: * -> *) a. Monad m => m a -> RidleyT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RegistryT (KatipContextT IO) NetworkMetrics
 -> RidleyT (RegistryT (KatipContextT IO)) NetworkMetrics)
-> RegistryT (KatipContextT IO) NetworkMetrics
-> RidleyT (RegistryT (KatipContextT IO)) NetworkMetrics
forall a b. (a -> b) -> a -> b
$ (NetworkMetrics
 -> IfData -> RegistryT (KatipContextT IO) NetworkMetrics)
-> NetworkMetrics
-> [IfData]
-> RegistryT (KatipContextT IO) NetworkMetrics
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Labels
-> NetworkMetrics
-> IfData
-> RegistryT (KatipContextT IO) NetworkMetrics
forall (m :: * -> *).
MonadIO m =>
Labels -> NetworkMetrics -> IfData -> RegistryT m NetworkMetrics
mkInterfaceGauge (PrometheusOptions
popts PrometheusOptions
-> Getting Labels PrometheusOptions Labels -> Labels
forall s a. s -> Getting a s a -> a
^. Getting Labels PrometheusOptions Labels
Lens' PrometheusOptions Labels
labels)) NetworkMetrics
forall k a. Map k a
M.empty [IfData]
ifaces
#endif
  let !network :: RidleyMetricHandler
network = NetworkMetrics -> RidleyMetricHandler
networkMetrics NetworkMetrics
imap
  $(logTM) Severity
sev LogStr
"Registering Network metric..."
  RidleyMetricHandler -> Ridley RidleyMetricHandler
forall a. a -> RidleyT (RegistryT (KatipContextT IO)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RidleyMetricHandler
network

--------------------------------------------------------------------------------
startRidleyWithStore :: RidleyOptions
                     -> P.Path
                     -> Port
                     -> EKG.Store
                     -> IO RidleyCtx
startRidleyWithStore :: RidleyOptions -> Path -> Int -> Store -> IO RidleyCtx
startRidleyWithStore RidleyOptions
opts Path
path Int
port Store
store = do
  ThreadId
tid <- IO ThreadId
forkRidley
  Maybe WaiMetrics
mbMetr   <- case RidleyMetric -> Set RidleyMetric -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member RidleyMetric
Wai (RidleyOptions
opts RidleyOptions
-> Getting (Set RidleyMetric) RidleyOptions (Set RidleyMetric)
-> Set RidleyMetric
forall s a. s -> Getting a s a -> a
^. Getting (Set RidleyMetric) RidleyOptions (Set RidleyMetric)
Lens' RidleyOptions (Set RidleyMetric)
ridleyMetrics) of
    Bool
False -> Maybe WaiMetrics -> IO (Maybe WaiMetrics)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe WaiMetrics
forall a. Maybe a
Nothing
    Bool
True  -> WaiMetrics -> Maybe WaiMetrics
forall a. a -> Maybe a
Just (WaiMetrics -> Maybe WaiMetrics)
-> IO WaiMetrics -> IO (Maybe WaiMetrics)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Store -> IO WaiMetrics
registerWaiMetrics Store
store

  RidleyCtx -> IO RidleyCtx
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RidleyCtx -> IO RidleyCtx) -> RidleyCtx -> IO RidleyCtx
forall a b. (a -> b) -> a -> b
$ ThreadId -> Maybe WaiMetrics -> RidleyCtx
RidleyCtx ThreadId
tid Maybe WaiMetrics
mbMetr
  where
    forkRidley :: IO ThreadId
forkRidley = IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
      MVar (Async Any)
x <- IO (MVar (Async Any))
forall a. IO (MVar a)
newEmptyMVar
      LogEnv
le <- Namespace -> Environment -> IO LogEnv
initLogEnv (RidleyOptions
opts RidleyOptions
-> Getting Namespace RidleyOptions Namespace -> Namespace
forall s a. s -> Getting a s a -> a
^. ((Namespace, [(Text, Scribe)])
 -> Const Namespace (Namespace, [(Text, Scribe)]))
-> RidleyOptions -> Const Namespace RidleyOptions
Lens' RidleyOptions (Namespace, [(Text, Scribe)])
katipScribes (((Namespace, [(Text, Scribe)])
  -> Const Namespace (Namespace, [(Text, Scribe)]))
 -> RidleyOptions -> Const Namespace RidleyOptions)
-> ((Namespace -> Const Namespace Namespace)
    -> (Namespace, [(Text, Scribe)])
    -> Const Namespace (Namespace, [(Text, Scribe)]))
-> Getting Namespace RidleyOptions Namespace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Namespace -> Const Namespace Namespace)
-> (Namespace, [(Text, Scribe)])
-> Const Namespace (Namespace, [(Text, Scribe)])
forall s t a b. Field1 s t a b => Lens s t a b
Lens
  (Namespace, [(Text, Scribe)])
  (Namespace, [(Text, Scribe)])
  Namespace
  Namespace
_1) Environment
"production"

      -- Register all the externally-passed Katip's Scribe
#if (MIN_VERSION_katip(0,5,0))
      LogEnv
le' <- (LogEnv -> (Text, Scribe) -> IO LogEnv)
-> LogEnv -> [(Text, Scribe)] -> IO LogEnv
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\LogEnv
le0 (Text
n,Scribe
s) -> Text -> Scribe -> ScribeSettings -> LogEnv -> IO LogEnv
registerScribe Text
n Scribe
s ScribeSettings
defaultScribeSettings LogEnv
le0) LogEnv
le (RidleyOptions
opts RidleyOptions
-> Getting [(Text, Scribe)] RidleyOptions [(Text, Scribe)]
-> [(Text, Scribe)]
forall s a. s -> Getting a s a -> a
^. ((Namespace, [(Text, Scribe)])
 -> Const [(Text, Scribe)] (Namespace, [(Text, Scribe)]))
-> RidleyOptions -> Const [(Text, Scribe)] RidleyOptions
Lens' RidleyOptions (Namespace, [(Text, Scribe)])
katipScribes (((Namespace, [(Text, Scribe)])
  -> Const [(Text, Scribe)] (Namespace, [(Text, Scribe)]))
 -> RidleyOptions -> Const [(Text, Scribe)] RidleyOptions)
-> (([(Text, Scribe)] -> Const [(Text, Scribe)] [(Text, Scribe)])
    -> (Namespace, [(Text, Scribe)])
    -> Const [(Text, Scribe)] (Namespace, [(Text, Scribe)]))
-> Getting [(Text, Scribe)] RidleyOptions [(Text, Scribe)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Text, Scribe)] -> Const [(Text, Scribe)] [(Text, Scribe)])
-> (Namespace, [(Text, Scribe)])
-> Const [(Text, Scribe)] (Namespace, [(Text, Scribe)])
forall s t a b. Field2 s t a b => Lens s t a b
Lens
  (Namespace, [(Text, Scribe)])
  (Namespace, [(Text, Scribe)])
  [(Text, Scribe)]
  [(Text, Scribe)]
_2)
#else
      let le' = List.foldl' (\le0 (n,s) -> registerScribe n s le0) le (opts ^. katipScribes . _2)
#endif

      -- Start the server
      Async ()
serverLoop <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ RidleyOptions
-> LogEnv -> RidleyT (RegistryT (KatipContextT IO)) () -> IO ()
forall a. RidleyOptions -> LogEnv -> Ridley a -> IO a
runRidley RidleyOptions
opts LogEnv
le' (RidleyT (RegistryT (KatipContextT IO)) () -> IO ())
-> RidleyT (RegistryT (KatipContextT IO)) () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        RegistryT (KatipContextT IO) ()
-> RidleyT (RegistryT (KatipContextT IO)) ()
forall (m :: * -> *) a. Monad m => m a -> RidleyT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RegistryT (KatipContextT IO) ()
 -> RidleyT (RegistryT (KatipContextT IO)) ())
-> RegistryT (KatipContextT IO) ()
-> RidleyT (RegistryT (KatipContextT IO)) ()
forall a b. (a -> b) -> a -> b
$ Store -> PrometheusOptions -> RegistryT (KatipContextT IO) ()
forall (m :: * -> *).
MonadIO m =>
Store -> PrometheusOptions -> RegistryT m ()
registerEKGStore Store
store (RidleyOptions
opts RidleyOptions
-> Getting PrometheusOptions RidleyOptions PrometheusOptions
-> PrometheusOptions
forall s a. s -> Getting a s a -> a
^. Getting PrometheusOptions RidleyOptions PrometheusOptions
Lens' RidleyOptions PrometheusOptions
prometheusOptions)
        [RidleyMetricHandler]
handlers <- Set RidleyMetric -> Ridley [RidleyMetricHandler]
registerMetrics (RidleyOptions
opts RidleyOptions
-> Getting (Set RidleyMetric) RidleyOptions (Set RidleyMetric)
-> Set RidleyMetric
forall s a. s -> Getting a s a -> a
^. Getting (Set RidleyMetric) RidleyOptions (Set RidleyMetric)
Lens' RidleyOptions (Set RidleyMetric)
ridleyMetrics)

        IO () -> RidleyT (RegistryT (KatipContextT IO)) ()
forall a. IO a -> RidleyT (RegistryT (KatipContextT IO)) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RidleyT (RegistryT (KatipContextT IO)) ())
-> IO () -> RidleyT (RegistryT (KatipContextT IO)) ()
forall a b. (a -> b) -> a -> b
$ do
          IORef UTCTime
lastUpdate <- UTCTime -> IO (IORef UTCTime)
forall a. a -> IO (IORef a)
newIORef (UTCTime -> IO (IORef UTCTime)) -> IO UTCTime -> IO (IORef UTCTime)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO UTCTime
getCurrentTime
          Async Any
updateLoop <- IO Any -> IO (Async Any)
forall a. IO a -> IO (Async a)
async (IO Any -> IO (Async Any)) -> IO Any -> IO (Async Any)
forall a b. (a -> b) -> a -> b
$ LogEnv -> IORef UTCTime -> [RidleyMetricHandler] -> IO Any
forall a. LogEnv -> IORef UTCTime -> [RidleyMetricHandler] -> IO a
handlersLoop LogEnv
le' IORef UTCTime
lastUpdate [RidleyMetricHandler]
handlers
          MVar (Async Any) -> Async Any -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Async Any)
x Async Any
updateLoop

        RegistryT (KatipContextT IO) ()
-> RidleyT (RegistryT (KatipContextT IO)) ()
forall (m :: * -> *) a. Monad m => m a -> RidleyT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RegistryT (KatipContextT IO) ()
 -> RidleyT (RegistryT (KatipContextT IO)) ())
-> RegistryT (KatipContextT IO) ()
-> RidleyT (RegistryT (KatipContextT IO)) ()
forall a b. (a -> b) -> a -> b
$ RegistryT (KatipContextT IO) (IO RegistrySample)
forall (m :: * -> *). Monad m => RegistryT m (IO RegistrySample)
P.sample RegistryT (KatipContextT IO) (IO RegistrySample)
-> (IO RegistrySample -> RegistryT (KatipContextT IO) ())
-> RegistryT (KatipContextT IO) ()
forall a b.
RegistryT (KatipContextT IO) a
-> (a -> RegistryT (KatipContextT IO) b)
-> RegistryT (KatipContextT IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Path -> IO RegistrySample -> RegistryT (KatipContextT IO) ()
forall (m :: * -> *).
MonadIO m =>
Int -> Path -> IO RegistrySample -> m ()
serveMetrics Int
port Path
path

      Async Any
ul  <- MVar (Async Any) -> IO (Async Any)
forall a. MVar a -> IO a
takeMVar MVar (Async Any)
x
      Async () -> Async Any -> IO ()
forall a b. Async a -> Async b -> IO ()
link2 Async ()
serverLoop Async Any
ul
      Either SomeException Any
res <- Async Any -> IO (Either SomeException Any)
forall a. Async a -> IO (Either SomeException a)
waitCatch Async Any
ul
      case Either SomeException Any
res of
        Left SomeException
e  -> LogEnv -> () -> Namespace -> KatipContextT IO () -> IO ()
forall c (m :: * -> *) a.
LogItem c =>
LogEnv -> c -> Namespace -> KatipContextT m a -> m a
runKatipContextT LogEnv
le' () Namespace
"errors" (KatipContextT IO () -> IO ()) -> KatipContextT IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          $(logTM) Severity
ErrorS (String -> LogStr
forall a. IsString a => String -> a
fromString (String -> LogStr) -> String -> LogStr
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e)
        Right Any
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    handlersLoop :: LogEnv -> IORef UTCTime -> [RidleyMetricHandler] -> IO a
    handlersLoop :: forall a. LogEnv -> IORef UTCTime -> [RidleyMetricHandler] -> IO a
handlersLoop LogEnv
le IORef UTCTime
lastUpdateRef [RidleyMetricHandler]
handlers = do
      let freq :: Int
freq = RidleyOptions
opts RidleyOptions -> Getting Int RidleyOptions Int -> Int
forall s a. s -> Getting a s a -> a
^. (PrometheusOptions -> Const Int PrometheusOptions)
-> RidleyOptions -> Const Int RidleyOptions
Lens' RidleyOptions PrometheusOptions
prometheusOptions ((PrometheusOptions -> Const Int PrometheusOptions)
 -> RidleyOptions -> Const Int RidleyOptions)
-> ((Int -> Const Int Int)
    -> PrometheusOptions -> Const Int PrometheusOptions)
-> Getting Int RidleyOptions Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Const Int Int)
-> PrometheusOptions -> Const Int PrometheusOptions
Lens' PrometheusOptions Int
samplingFrequency
      let flushPeriod :: Maybe NominalDiffTime
flushPeriod = RidleyOptions
opts RidleyOptions
-> Getting
     (Maybe NominalDiffTime) RidleyOptions (Maybe NominalDiffTime)
-> Maybe NominalDiffTime
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe NominalDiffTime) RidleyOptions (Maybe NominalDiffTime)
Lens' RidleyOptions (Maybe NominalDiffTime)
dataRetentionPeriod
      Bool
mustFlush <- case Maybe NominalDiffTime
flushPeriod of
        Maybe NominalDiffTime
Nothing -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Just NominalDiffTime
p  -> do
          UTCTime
now        <- IO UTCTime
getCurrentTime
          UTCTime
lastUpdate <- IORef UTCTime -> IO UTCTime
forall a. IORef a -> IO a
readIORef IORef UTCTime
lastUpdateRef
          case UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
lastUpdate UTCTime
now NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
>= NominalDiffTime
p of
            Bool
True  -> do
              IORef UTCTime -> (UTCTime -> UTCTime) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef UTCTime
lastUpdateRef (UTCTime -> UTCTime -> UTCTime
forall a b. a -> b -> a
const UTCTime
now)
              Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            Bool
False -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      Int -> IO ()
threadDelay (Int
freq Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10Int -> Integer -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^Integer
6)
      LogEnv -> [RidleyMetricHandler] -> IO ()
updateHandlers LogEnv
le ((RidleyMetricHandler -> RidleyMetricHandler)
-> [RidleyMetricHandler] -> [RidleyMetricHandler]
forall a b. (a -> b) -> [a] -> [b]
List.map (\RidleyMetricHandler
x -> RidleyMetricHandler
x { flush = mustFlush }) [RidleyMetricHandler]
handlers)
      LogEnv -> IORef UTCTime -> [RidleyMetricHandler] -> IO a
forall a. LogEnv -> IORef UTCTime -> [RidleyMetricHandler] -> IO a
handlersLoop LogEnv
le IORef UTCTime
lastUpdateRef [RidleyMetricHandler]
handlers

serveMetrics :: MonadIO m => Int -> P.Path -> IO RegistrySample -> m ()
#if (MIN_VERSION_prometheus(2,2,2))
serveMetrics :: forall (m :: * -> *).
MonadIO m =>
Int -> Path -> IO RegistrySample -> m ()
serveMetrics = Int -> Path -> IO RegistrySample -> m ()
forall (m :: * -> *).
MonadIO m =>
Int -> Path -> IO RegistrySample -> m ()
P.serveMetrics
#else
serveMetrics = P.serveHttpTextMetrics
#endif

--------------------------------------------------------------------------------
updateHandlers :: LogEnv -> [RidleyMetricHandler] -> IO ()
updateHandlers :: LogEnv -> [RidleyMetricHandler] -> IO ()
updateHandlers LogEnv
le [RidleyMetricHandler]
hs = (RidleyMetricHandler -> IO ()) -> [RidleyMetricHandler] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\h :: RidleyMetricHandler
h@RidleyMetricHandler{c
Bool
CallStack
Text
c -> Bool -> IO ()
flush :: RidleyMetricHandler -> Bool
metric :: c
updateMetric :: c -> Bool -> IO ()
flush :: Bool
label :: Text
_cs :: CallStack
metric :: ()
updateMetric :: ()
label :: RidleyMetricHandler -> Text
_cs :: RidleyMetricHandler -> CallStack
..} -> RidleyMetricHandler -> IO ()
runHandler RidleyMetricHandler
h IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> (SomeException -> m a) -> m a
`Ex.catchAny` (LogEnv -> Text -> CallStack -> SomeException -> IO ()
logFailedUpdate LogEnv
le Text
label CallStack
_cs)) [RidleyMetricHandler]
hs

logFailedUpdate :: LogEnv -> T.Text -> CallStack -> Ex.SomeException -> IO ()
logFailedUpdate :: LogEnv -> Text -> CallStack -> SomeException -> IO ()
logFailedUpdate LogEnv
le Text
lbl CallStack
cs SomeException
ex =
  LogEnv -> () -> Namespace -> KatipContextT IO () -> IO ()
forall c (m :: * -> *) a.
LogItem c =>
LogEnv -> c -> Namespace -> KatipContextT m a -> m a
runKatipContextT LogEnv
le () Namespace
"errors" (KatipContextT IO () -> IO ()) -> KatipContextT IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      $(logTM) Severity
ErrorS (LogStr -> KatipContextT IO ()) -> LogStr -> KatipContextT IO ()
forall a b. (a -> b) -> a -> b
$
        String -> LogStr
forall a. IsString a => String -> a
fromString (String -> LogStr) -> String -> LogStr
forall a b. (a -> b) -> a -> b
$ String
"Couldn't update handler for "
                  String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
lbl String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\""
                  String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" due to "
                  String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall e. Exception e => e -> String
Ex.displayException SomeException
ex
                  String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" originally defined at "
                  String -> String -> String
forall a. Semigroup a => a -> a -> a
<> CallStack -> String
prettyCallStack CallStack
cs