{-# OPTIONS_GHC -fno-warn-type-defaults #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NumericUnderscores #-}
{-# 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 (ask)
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           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 -> Port -> IO RidleyCtx
startRidley RidleyOptions
opts Path
path Port
port = do
  Store
store <- IO Store
EKG.newStore
  Store -> IO ()
EKG.registerGcMetrics Store
store
  RidleyOptions -> Path -> Port -> Store -> IO RidleyCtx
startRidleyWithStore RidleyOptions
opts Path
path Port
port Store
store

--------------------------------------------------------------------------------
registerMetrics :: [RidleyMetric] -> Ridley [RidleyMetricHandler]
registerMetrics :: [RidleyMetric] -> Ridley [RidleyMetricHandler]
registerMetrics [] = [RidleyMetricHandler] -> Ridley [RidleyMetricHandler]
forall (m :: * -> *) a. Monad m => a -> m a
return []
registerMetrics (RidleyMetric
x:[RidleyMetric]
xs) = do
  RidleyOptions
opts <- RidleyT (RegistryT (KatipContextT IO)) RidleyOptions
forall r (m :: * -> *). MonadReader r m => m r
ask
  let popts :: PrometheusOptions
popts = 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
  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
  case RidleyMetric
x of
    CustomMetric Text
metricName Maybe Port
mb_timeout forall (m :: * -> *).
MonadIO m =>
RidleyOptions -> RegistryT m RidleyMetricHandler
custom -> do
      RidleyMetricHandler
customMetric <- case Maybe Port
mb_timeout of
        Maybe Port
Nothing   -> RegistryT (KatipContextT IO) RidleyMetricHandler
-> RidleyT (RegistryT (KatipContextT IO)) RidleyMetricHandler
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RidleyOptions -> RegistryT (KatipContextT IO) RidleyMetricHandler
forall (m :: * -> *).
MonadIO m =>
RidleyOptions -> RegistryT m RidleyMetricHandler
custom RidleyOptions
opts)
        Just Port
microseconds -> do
          RidleyMetricHandler c
mtr c -> Bool -> IO ()
upd Bool
flsh Text
lbl CallStack
cs <- RegistryT (KatipContextT IO) RidleyMetricHandler
-> RidleyT (RegistryT (KatipContextT IO)) RidleyMetricHandler
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RidleyOptions -> RegistryT (KatipContextT IO) RidleyMetricHandler
forall (m :: * -> *).
MonadIO m =>
RidleyOptions -> RegistryT m RidleyMetricHandler
custom RidleyOptions
opts)
          IO ()
doUpdate <- IO (IO ()) -> RidleyT (RegistryT (KatipContextT IO)) (IO ())
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 :: IO ()
updateAction = c -> Bool -> IO ()
upd c
mtr Bool
flsh IO () -> (SomeException -> IO ()) -> IO ()
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 :: Port
updateFreq   = Port
microseconds
                        }
          RidleyMetricHandler
-> RidleyT (RegistryT (KatipContextT IO)) RidleyMetricHandler
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RidleyMetricHandler
 -> RidleyT (RegistryT (KatipContextT IO)) RidleyMetricHandler)
-> RidleyMetricHandler
-> RidleyT (RegistryT (KatipContextT IO)) 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
      $(Port
String
String -> String -> String -> CharPos -> CharPos -> Loc
Maybe Loc
-> Severity -> LogStr -> RidleyT (RegistryT (KatipContextT IO)) ()
Loc -> Maybe Loc
forall a. a -> Maybe a
forall (m :: * -> *).
(Applicative m, KatipContext m, HasCallStack) =>
Maybe Loc -> Severity -> LogStr -> m ()
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
customMetric RidleyMetricHandler
-> [RidleyMetricHandler] -> [RidleyMetricHandler]
forall a. a -> [a] -> [a]
:) ([RidleyMetricHandler] -> [RidleyMetricHandler])
-> Ridley [RidleyMetricHandler] -> Ridley [RidleyMetricHandler]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([RidleyMetric] -> Ridley [RidleyMetricHandler]
registerMetrics [RidleyMetric]
xs)
    RidleyMetric
ProcessMemory -> do
      Gauge
processReservedMemory <- RegistryT (KatipContextT IO) Gauge
-> RidleyT (RegistryT (KatipContextT IO)) Gauge
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 = Gauge -> RidleyMetricHandler
processMemory Gauge
processReservedMemory
      $(Port
String
String -> String -> String -> CharPos -> CharPos -> Loc
Maybe Loc
-> Severity -> LogStr -> RidleyT (RegistryT (KatipContextT IO)) ()
Loc -> Maybe Loc
forall a. a -> Maybe a
forall (m :: * -> *).
(Applicative m, KatipContext m, HasCallStack) =>
Maybe Loc -> Severity -> LogStr -> m ()
logTM) Severity
sev LogStr
"Registering ProcessMemory metric..."
      (RidleyMetricHandler
m RidleyMetricHandler
-> [RidleyMetricHandler] -> [RidleyMetricHandler]
forall a. a -> [a] -> [a]
:) ([RidleyMetricHandler] -> [RidleyMetricHandler])
-> Ridley [RidleyMetricHandler] -> Ridley [RidleyMetricHandler]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([RidleyMetric] -> Ridley [RidleyMetricHandler]
registerMetrics [RidleyMetric]
xs)
    RidleyMetric
CPULoad -> do
      Gauge
cpu1m  <- RegistryT (KatipContextT IO) Gauge
-> RidleyT (RegistryT (KatipContextT IO)) Gauge
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 (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 (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)
      $(Port
String
String -> String -> String -> CharPos -> CharPos -> Loc
Maybe Loc
-> Severity -> LogStr -> RidleyT (RegistryT (KatipContextT IO)) ()
Loc -> Maybe Loc
forall a. a -> Maybe a
forall (m :: * -> *).
(Applicative m, KatipContext m, HasCallStack) =>
Maybe Loc -> Severity -> LogStr -> m ()
logTM) Severity
sev LogStr
"Registering CPULoad metric..."
      (RidleyMetricHandler
cpu RidleyMetricHandler
-> [RidleyMetricHandler] -> [RidleyMetricHandler]
forall a. a -> [a] -> [a]
:) ([RidleyMetricHandler] -> [RidleyMetricHandler])
-> Ridley [RidleyMetricHandler] -> Ridley [RidleyMetricHandler]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([RidleyMetric] -> Ridley [RidleyMetricHandler]
registerMetrics [RidleyMetric]
xs)
    RidleyMetric
GHCConc -> do
      -- 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 (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 (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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Port
getNumCapabilities IO Port -> (Port -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Port
cap -> Port -> Counter -> IO ()
add (Port -> Port
forall a b. (Integral a, Num b) => a -> b
fromIntegral Port
cap) Counter
numCaps)
      IO () -> RidleyT (RegistryT (KatipContextT IO)) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Port
getNumProcessors IO Port -> (Port -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Port
cap -> Port -> Counter -> IO ()
add (Port -> Port
forall a b. (Integral a, Num b) => a -> b
fromIntegral Port
cap) Counter
numPros)
      $(Port
String
String -> String -> String -> CharPos -> CharPos -> Loc
Maybe Loc
-> Severity -> LogStr -> RidleyT (RegistryT (KatipContextT IO)) ()
Loc -> Maybe Loc
forall a. a -> Maybe a
forall (m :: * -> *).
(Applicative m, KatipContext m, HasCallStack) =>
Maybe Loc -> Severity -> LogStr -> m ()
logTM) Severity
sev LogStr
"Registering GHCConc metric..."
      [RidleyMetric] -> Ridley [RidleyMetricHandler]
registerMetrics [RidleyMetric]
xs
    -- Ignore `Wai` as we will use an external library for that.
    RidleyMetric
Wai     -> [RidleyMetric] -> Ridley [RidleyMetricHandler]
registerMetrics [RidleyMetric]
xs
    RidleyMetric
DiskUsage -> do
      [DiskStats]
diskStats <- IO [DiskStats]
-> RidleyT (RegistryT (KatipContextT IO)) [DiskStats]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [DiskStats]
getDiskStats
      DiskUsageMetrics
dmap   <- RegistryT (KatipContextT IO) DiskUsageMetrics
-> RidleyT (RegistryT (KatipContextT IO)) DiskUsageMetrics
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RegistryT (KatipContextT IO) DiskUsageMetrics
 -> RidleyT (RegistryT (KatipContextT IO)) DiskUsageMetrics)
-> RegistryT (KatipContextT IO) DiskUsageMetrics
-> RidleyT (RegistryT (KatipContextT IO)) DiskUsageMetrics
forall a b. (a -> b) -> a -> b
$ (DiskUsageMetrics
 -> DiskStats -> RegistryT (KatipContextT IO) DiskUsageMetrics)
-> DiskUsageMetrics
-> [DiskStats]
-> RegistryT (KatipContextT IO) DiskUsageMetrics
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Labels
-> DiskUsageMetrics
-> DiskStats
-> RegistryT (KatipContextT IO) DiskUsageMetrics
forall (m :: * -> *).
MonadIO m =>
Labels
-> DiskUsageMetrics -> DiskStats -> RegistryT m DiskUsageMetrics
mkDiskGauge (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)) DiskUsageMetrics
forall k a. Map k a
M.empty [DiskStats]
diskStats
      let !diskUsage :: RidleyMetricHandler
diskUsage = DiskUsageMetrics -> RidleyMetricHandler
diskUsageMetrics DiskUsageMetrics
dmap
      $(Port
String
String -> String -> String -> CharPos -> CharPos -> Loc
Maybe Loc
-> Severity -> LogStr -> RidleyT (RegistryT (KatipContextT IO)) ()
Loc -> Maybe Loc
forall a. a -> Maybe a
forall (m :: * -> *).
(Applicative m, KatipContext m, HasCallStack) =>
Maybe Loc -> Severity -> LogStr -> m ()
logTM) Severity
sev LogStr
"Registering DiskUsage metric..."
      (RidleyMetricHandler
diskUsage RidleyMetricHandler
-> [RidleyMetricHandler] -> [RidleyMetricHandler]
forall a. a -> [a] -> [a]
:) ([RidleyMetricHandler] -> [RidleyMetricHandler])
-> Ridley [RidleyMetricHandler] -> Ridley [RidleyMetricHandler]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RidleyMetric] -> Ridley [RidleyMetricHandler]
registerMetrics [RidleyMetric]
xs
    RidleyMetric
Network -> do
#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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [IfData]
getNetworkMetrics
      NetworkMetrics
imap   <- RegistryT (KatipContextT IO) NetworkMetrics
-> RidleyT (RegistryT (KatipContextT IO)) NetworkMetrics
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
      $(Port
String
String -> String -> String -> CharPos -> CharPos -> Loc
Maybe Loc
-> Severity -> LogStr -> RidleyT (RegistryT (KatipContextT IO)) ()
Loc -> Maybe Loc
forall a. a -> Maybe a
forall (m :: * -> *).
(Applicative m, KatipContext m, HasCallStack) =>
Maybe Loc -> Severity -> LogStr -> m ()
logTM) Severity
sev LogStr
"Registering Network metric..."
      (RidleyMetricHandler
network RidleyMetricHandler
-> [RidleyMetricHandler] -> [RidleyMetricHandler]
forall a. a -> [a] -> [a]
:) ([RidleyMetricHandler] -> [RidleyMetricHandler])
-> Ridley [RidleyMetricHandler] -> Ridley [RidleyMetricHandler]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RidleyMetric] -> Ridley [RidleyMetricHandler]
registerMetrics [RidleyMetric]
xs

--------------------------------------------------------------------------------
startRidleyWithStore :: RidleyOptions
                     -> P.Path
                     -> Port
                     -> EKG.Store
                     -> IO RidleyCtx
startRidleyWithStore :: RidleyOptions -> Path -> Port -> Store -> IO RidleyCtx
startRidleyWithStore RidleyOptions
opts Path
path Port
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 (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 (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
_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
_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 (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 <- [RidleyMetric] -> Ridley [RidleyMetricHandler]
registerMetrics (Set RidleyMetric -> [RidleyMetric]
forall a. Set a -> [a]
Set.toList (Set RidleyMetric -> [RidleyMetric])
-> Set RidleyMetric -> [RidleyMetric]
forall a b. (a -> b) -> a -> b
$ 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 (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 (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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Port
-> Path -> IO RegistrySample -> RegistryT (KatipContextT IO) ()
forall (m :: * -> *).
MonadIO m =>
Port -> Path -> IO RegistrySample -> m ()
serveMetrics Port
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
          $(Port
String
String -> String -> String -> CharPos -> CharPos -> Loc
Maybe Loc -> Severity -> LogStr -> KatipContextT IO ()
Loc -> Maybe Loc
forall a. a -> Maybe a
forall (m :: * -> *).
(Applicative m, KatipContext m, HasCallStack) =>
Maybe Loc -> Severity -> LogStr -> m ()
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 (m :: * -> *) a. Monad m => a -> m a
return ()

    handlersLoop :: LogEnv -> IORef UTCTime -> [RidleyMetricHandler] -> IO a
    handlersLoop :: LogEnv -> IORef UTCTime -> [RidleyMetricHandler] -> IO a
handlersLoop LogEnv
le IORef UTCTime
lastUpdateRef [RidleyMetricHandler]
handlers = do
      let freq :: Port
freq = RidleyOptions
opts RidleyOptions -> Getting Port RidleyOptions Port -> Port
forall s a. s -> Getting a s a -> a
^. (PrometheusOptions -> Const Port PrometheusOptions)
-> RidleyOptions -> Const Port RidleyOptions
Lens' RidleyOptions PrometheusOptions
prometheusOptions ((PrometheusOptions -> Const Port PrometheusOptions)
 -> RidleyOptions -> Const Port RidleyOptions)
-> ((Port -> Const Port Port)
    -> PrometheusOptions -> Const Port PrometheusOptions)
-> Getting Port RidleyOptions Port
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Port -> Const Port Port)
-> PrometheusOptions -> Const Port PrometheusOptions
Lens' PrometheusOptions Port
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 (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 (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            Bool
False -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      Port -> IO ()
threadDelay (Port
freq Port -> Port -> Port
forall a. Num a => a -> a -> a
* Port
10Port -> Integer -> Port
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 :: Bool
flush = Bool
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 :: Port -> Path -> IO RegistrySample -> m ()
serveMetrics = Port -> Path -> IO RegistrySample -> m ()
forall (m :: * -> *).
MonadIO m =>
Port -> 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 ()
_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 IO () -> (SomeException -> IO ()) -> IO ()
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 =
  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
      $(Port
String
String -> String -> String -> CharPos -> CharPos -> Loc
Maybe Loc -> Severity -> LogStr -> KatipContextT IO ()
Loc -> Maybe Loc
forall a. a -> Maybe a
forall (m :: * -> *).
(Applicative m, KatipContext m, HasCallStack) =>
Maybe Loc -> Severity -> LogStr -> m ()
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