{-# 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
, 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
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)
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"
#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
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