{-# 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 = 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 -- 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 <- 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)
  -- We don't want to keep updating this as it's a one-shot measure.
  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"

      -- Register all the externally-passed Katip's Scribe
#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

      -- Start the server
      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