{-# 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 = 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 forall (m :: * -> *).
MonadIO m =>
RidleyOptions -> RegistryT m RidleyMetricHandler
custom
-> RidleyMetric
-> [RidleyMetricHandler]
-> Ridley RidleyMetricHandler
-> Ridley [RidleyMetricHandler]
tryRegister RidleyMetric
x [RidleyMetricHandler]
acc forall a b. (a -> b) -> a -> b
$ Text
-> Maybe Int
-> (forall (m :: * -> *).
MonadIO m =>
RidleyOptions -> RegistryT m RidleyMetricHandler)
-> Ridley RidleyMetricHandler
registerCustomMetric Text
metricName Maybe Int
mb_timeout forall (m :: * -> *).
MonadIO m =>
RidleyOptions -> RegistryT m 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
-> 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 <- forall (m :: * -> *) a.
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 forall a b. (a -> b) -> a -> b
$ forall a. StringConv a Text => a -> LogStr
ls forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ String
"Registration of metric '" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show RidleyMetric
metric forall a. Semigroup a => a -> a -> a
<> String
"' failed due to: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show SomeException
ex
forall (f :: * -> *) a. Applicative f => a -> f a
pure [RidleyMetricHandler]
acc
Right RidleyMetricHandler
metricHandler -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! RidleyMetricHandler
metricHandler forall a. a -> [a] -> [a]
: [RidleyMetricHandler]
acc
registerProcessMemory :: Ridley RidleyMetricHandler
registerProcessMemory :: Ridley RidleyMetricHandler
registerProcessMemory = do
Severity
sev <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall a s. Getting a s a -> s -> a
view Lens' RidleyOptions Severity
katipSeverity)
PrometheusOptions
popts <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall a s. Getting a s a -> s -> a
view Lens' RidleyOptions PrometheusOptions
prometheusOptions)
Logger
logger <- Ridley Logger
ioLogger
Gauge
processReservedMemory <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
Name -> Labels -> RegistryT m Gauge
P.registerGauge Name
"process_memory_kb" (PrometheusOptions
popts forall s a. s -> Getting a s a -> a
^. Lens' PrometheusOptions Labels
labels)
let !m :: RidleyMetricHandler
m = Logger -> Gauge -> RidleyMetricHandler
processMemory Logger
logger Gauge
processReservedMemory
$(logTM) Severity
sev LogStr
"Registering ProcessMemory metric..."
forall (f :: * -> *) a. Applicative f => a -> f a
pure RidleyMetricHandler
m
registerCPULoad :: Ridley RidleyMetricHandler
registerCPULoad :: Ridley RidleyMetricHandler
registerCPULoad = do
Severity
sev <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall a s. Getting a s a -> s -> a
view Lens' RidleyOptions Severity
katipSeverity)
PrometheusOptions
popts <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall a s. Getting a s a -> s -> a
view Lens' RidleyOptions PrometheusOptions
prometheusOptions)
Gauge
cpu1m <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
Name -> Labels -> RegistryT m Gauge
P.registerGauge Name
"cpu_load1" (PrometheusOptions
popts forall s a. s -> Getting a s a -> a
^. Lens' PrometheusOptions Labels
labels)
Gauge
cpu5m <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
Name -> Labels -> RegistryT m Gauge
P.registerGauge Name
"cpu_load5" (PrometheusOptions
popts forall s a. s -> Getting a s a -> a
^. Lens' PrometheusOptions Labels
labels)
Gauge
cpu15m <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
Name -> Labels -> RegistryT m Gauge
P.registerGauge Name
"cpu_load15" (PrometheusOptions
popts forall s a. s -> Getting a s a -> a
^. 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..."
forall (f :: * -> *) a. Applicative f => a -> f a
pure RidleyMetricHandler
cpu
registerGHCConc :: Ridley RidleyMetricHandler
registerGHCConc :: Ridley RidleyMetricHandler
registerGHCConc = do
Severity
sev <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall a s. Getting a s a -> s -> a
view Lens' RidleyOptions Severity
katipSeverity)
PrometheusOptions
popts <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall a s. Getting a s a -> s -> a
view Lens' RidleyOptions PrometheusOptions
prometheusOptions)
Counter
numCaps <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
Name -> Labels -> RegistryT m Counter
P.registerCounter Name
"ghc_conc_num_capabilities" (PrometheusOptions
popts forall s a. s -> Getting a s a -> a
^. Lens' PrometheusOptions Labels
labels)
Counter
numPros <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
Name -> Labels -> RegistryT m Counter
P.registerCounter Name
"ghc_conc_num_processors" (PrometheusOptions
popts forall s a. s -> Getting a s a -> a
^. Lens' PrometheusOptions Labels
labels)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int
getNumCapabilities forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
cap -> Int -> Counter -> IO ()
add (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
cap) Counter
numCaps)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int
getNumProcessors forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
cap -> Int -> Counter -> IO ()
add (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
cap) Counter
numPros)
$(logTM) Severity
sev LogStr
"Registering GHCConc metric..."
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall c.
HasCallStack =>
Text -> c -> (c -> Bool -> IO ()) -> Bool -> RidleyMetricHandler
mkRidleyMetricHandler Text
"ridley-ghc-conc" (Counter
numCaps, Counter
numPros) forall c. c -> Bool -> IO ()
noUpdate Bool
False
registerDiskUsage :: Ridley RidleyMetricHandler
registerDiskUsage :: Ridley RidleyMetricHandler
registerDiskUsage = do
Severity
sev <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall a s. Getting a s a -> s -> a
view Lens' RidleyOptions Severity
katipSeverity)
RidleyMetricHandler
diskUsage <- Ridley RidleyMetricHandler
newDiskUsageMetrics
$(logTM) Severity
sev LogStr
"Registering DiskUsage metric..."
forall (f :: * -> *) a. Applicative f => a -> f a
pure RidleyMetricHandler
diskUsage
registerCustomMetric :: T.Text
-> Maybe Int
-> (forall m. MonadIO m => RidleyOptions -> P.RegistryT m RidleyMetricHandler)
-> Ridley RidleyMetricHandler
registerCustomMetric :: Text
-> Maybe Int
-> (forall (m :: * -> *).
MonadIO m =>
RidleyOptions -> RegistryT m RidleyMetricHandler)
-> Ridley RidleyMetricHandler
registerCustomMetric Text
metricName Maybe Int
mb_timeout forall (m :: * -> *).
MonadIO m =>
RidleyOptions -> RegistryT m RidleyMetricHandler
custom = do
RidleyOptions
opts <- Ridley RidleyOptions
getRidleyOptions
let sev :: Severity
sev = RidleyOptions
opts forall s a. s -> Getting a s a -> a
^. Lens' RidleyOptions Severity
katipSeverity
LogEnv
le <- forall (m :: * -> *). Katip m => m LogEnv
getLogEnv
RidleyMetricHandler
customMetric <- case Maybe Int
mb_timeout of
Maybe Int
Nothing -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *).
MonadIO m =>
RidleyOptions -> RegistryT m RidleyMetricHandler
custom RidleyOptions
opts)
Just Int
microseconds -> do
RidleyMetricHandler c
mtr c -> Bool -> IO ()
upd Bool
flsh Text
lbl CallStack
cs <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *).
MonadIO m =>
RidleyOptions -> RegistryT m RidleyMetricHandler
custom RidleyOptions
opts)
IO ()
doUpdate <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. UpdateSettings a -> IO (IO a)
Auto.mkAutoUpdate UpdateSettings ()
Auto.defaultUpdateSettings
{ updateAction :: IO ()
updateAction = c -> Bool -> IO ()
upd c
mtr Bool
flsh forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`Ex.catch` LogEnv -> Text -> CallStack -> SomeException -> IO ()
logFailedUpdate LogEnv
le Text
lbl CallStack
cs
, updateFreq :: Int
updateFreq = Int
microseconds
}
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ LogStr
"Registering CustomMetric '" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString (Text -> String
T.unpack Text
metricName) forall a. Semigroup a => a -> a -> a
<> LogStr
"'..."
forall (f :: * -> *) a. Applicative f => a -> f a
pure RidleyMetricHandler
customMetric
registerNetworkMetric :: Ridley RidleyMetricHandler
registerNetworkMetric :: Ridley RidleyMetricHandler
registerNetworkMetric = do
Severity
sev <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall a s. Getting a s a -> s -> a
view Lens' RidleyOptions Severity
katipSeverity)
PrometheusOptions
popts <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall a s. Getting a s a -> s -> a
view 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [IfData]
getNetworkMetrics
NetworkMetrics
imap <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (forall (m :: * -> *).
MonadIO m =>
Labels -> NetworkMetrics -> IfData -> RegistryT m NetworkMetrics
mkInterfaceGauge (PrometheusOptions
popts forall s a. s -> Getting a s a -> a
^. Lens' PrometheusOptions Labels
labels)) 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..."
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 forall a. Ord a => a -> Set a -> Bool
Set.member RidleyMetric
Wai (RidleyOptions
opts forall s a. s -> Getting a s a -> a
^. Lens' RidleyOptions (Set RidleyMetric)
ridleyMetrics) of
Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Bool
True -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Store -> IO WaiMetrics
registerWaiMetrics Store
store
forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall a b. (a -> b) -> a -> b
$ do
MVar (Async Any)
x <- forall a. IO (MVar a)
newEmptyMVar
LogEnv
le <- Namespace -> Environment -> IO LogEnv
initLogEnv (RidleyOptions
opts forall s a. s -> Getting a s a -> a
^. Lens' RidleyOptions (Namespace, [(Text, Scribe)])
katipScribes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field1 s t a b => Lens s t a b
_1) Environment
"production"
#if (MIN_VERSION_katip(0,5,0))
LogEnv
le' <- 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 forall s a. s -> Getting a s a -> a
^. Lens' RidleyOptions (Namespace, [(Text, Scribe)])
katipScribes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2)
#else
let le' = List.foldl' (\le0 (n,s) -> registerScribe n s le0) le (opts ^. katipScribes . _2)
#endif
Async ()
serverLoop <- forall a. IO a -> IO (Async a)
async forall a b. (a -> b) -> a -> b
$ forall a. RidleyOptions -> LogEnv -> Ridley a -> IO a
runRidley RidleyOptions
opts LogEnv
le' forall a b. (a -> b) -> a -> b
$ do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
Store -> PrometheusOptions -> RegistryT m ()
registerEKGStore Store
store (RidleyOptions
opts forall s a. s -> Getting a s a -> a
^. Lens' RidleyOptions PrometheusOptions
prometheusOptions)
[RidleyMetricHandler]
handlers <- Set RidleyMetric -> Ridley [RidleyMetricHandler]
registerMetrics (RidleyOptions
opts forall s a. s -> Getting a s a -> a
^. Lens' RidleyOptions (Set RidleyMetric)
ridleyMetrics)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
IORef UTCTime
lastUpdate <- forall a. a -> IO (IORef a)
newIORef forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO UTCTime
getCurrentTime
Async Any
updateLoop <- forall a. IO a -> IO (Async a)
async forall a b. (a -> b) -> a -> b
$ forall a. LogEnv -> IORef UTCTime -> [RidleyMetricHandler] -> IO a
handlersLoop LogEnv
le' IORef UTCTime
lastUpdate [RidleyMetricHandler]
handlers
forall a. MVar a -> a -> IO ()
putMVar MVar (Async Any)
x Async Any
updateLoop
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Monad m => RegistryT m (IO RegistrySample)
P.sample forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *).
MonadIO m =>
Int -> Path -> IO RegistrySample -> m ()
serveMetrics Int
port Path
path
Async Any
ul <- forall a. MVar a -> IO a
takeMVar MVar (Async Any)
x
forall a b. Async a -> Async b -> IO ()
link2 Async ()
serverLoop Async Any
ul
Either SomeException Any
res <- forall a. Async a -> IO (Either SomeException a)
waitCatch Async Any
ul
case Either SomeException Any
res of
Left SomeException
e -> forall c (m :: * -> *) a.
LogItem c =>
LogEnv -> c -> Namespace -> KatipContextT m a -> m a
runKatipContextT LogEnv
le' () Namespace
"errors" forall a b. (a -> b) -> a -> b
$ do
$(logTM) Severity
ErrorS (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show SomeException
e)
Right Any
_ -> 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 forall s a. s -> Getting a s a -> a
^. Lens' RidleyOptions PrometheusOptions
prometheusOptions forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' PrometheusOptions Int
samplingFrequency
let flushPeriod :: Maybe NominalDiffTime
flushPeriod = RidleyOptions
opts forall s a. s -> Getting a s a -> a
^. Lens' RidleyOptions (Maybe NominalDiffTime)
dataRetentionPeriod
Bool
mustFlush <- case Maybe NominalDiffTime
flushPeriod of
Maybe NominalDiffTime
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Just NominalDiffTime
p -> do
UTCTime
now <- IO UTCTime
getCurrentTime
UTCTime
lastUpdate <- forall a. IORef a -> IO a
readIORef IORef UTCTime
lastUpdateRef
case UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
lastUpdate UTCTime
now forall a. Ord a => a -> a -> Bool
>= NominalDiffTime
p of
Bool
True -> do
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef UTCTime
lastUpdateRef (forall a b. a -> b -> a
const UTCTime
now)
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Int -> IO ()
threadDelay (Int
freq forall a. Num a => a -> a -> a
* Int
10forall a b. (Num a, Integral b) => a -> b -> a
^Integer
6)
LogEnv -> [RidleyMetricHandler] -> IO ()
updateHandlers LogEnv
le (forall a b. (a -> b) -> [a] -> [b]
List.map (\RidleyMetricHandler
x -> RidleyMetricHandler
x { flush :: Bool
flush = Bool
mustFlush }) [RidleyMetricHandler]
handlers)
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 = 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 = 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 ()
_cs :: RidleyMetricHandler -> CallStack
label :: RidleyMetricHandler -> Text
updateMetric :: ()
metric :: ()
_cs :: CallStack
label :: Text
flush :: Bool
updateMetric :: c -> Bool -> IO ()
metric :: c
flush :: RidleyMetricHandler -> Bool
..} -> RidleyMetricHandler -> IO ()
runHandler RidleyMetricHandler
h forall (m :: * -> *) a.
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 =
forall c (m :: * -> *) a.
LogItem c =>
LogEnv -> c -> Namespace -> KatipContextT m a -> m a
runKatipContextT LogEnv
le () Namespace
"errors" forall a b. (a -> b) -> a -> b
$ do
$(logTM) Severity
ErrorS forall a b. (a -> b) -> a -> b
$
forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ String
"Couldn't update handler for "
forall a. Semigroup a => a -> a -> a
<> String
"\"" forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
lbl forall a. Semigroup a => a -> a -> a
<> String
"\""
forall a. Semigroup a => a -> a -> a
<> String
" due to "
forall a. Semigroup a => a -> a -> a
<> forall e. Exception e => e -> String
Ex.displayException SomeException
ex
forall a. Semigroup a => a -> a -> a
<> String
" originally defined at "
forall a. Semigroup a => a -> a -> a
<> CallStack -> String
prettyCallStack CallStack
cs