diff --git a/ridley.cabal b/ridley.cabal --- a/ridley.cabal +++ b/ridley.cabal @@ -1,5 +1,5 @@ name: ridley -version: 0.3.3.1 +version: 0.3.4.0 synopsis: Quick metrics to grow your app strong. description: A collection of Prometheus metrics to monitor your app. Please see README.md homepage: https://github.com/iconnect/ridley#README @@ -44,6 +44,7 @@ wai-middleware-metrics < 0.3.0.0, template-haskell, ekg-core, + exceptions < 0.11, time, text >= 1.2.4.0, mtl, @@ -59,7 +60,8 @@ ekg-prometheus-adapter >= 0.1.0.3, inline-c, vector, - unix + unix, + unliftio-core c-sources: cbits/helpers.c cc-options: -Wall -std=c99 default-language: Haskell2010 diff --git a/src/System/Metrics/Prometheus/Ridley.hs b/src/System/Metrics/Prometheus/Ridley.hs --- a/src/System/Metrics/Prometheus/Ridley.hs +++ b/src/System/Metrics/Prometheus/Ridley.hs @@ -3,6 +3,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE CPP #-} module System.Metrics.Prometheus.Ridley ( @@ -31,7 +32,7 @@ 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.Reader (asks) import Control.Monad.Trans.Class (lift) import Data.IORef import qualified Data.List as List @@ -44,6 +45,7 @@ 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)) @@ -73,66 +75,110 @@ startRidleyWithStore opts path port store -------------------------------------------------------------------------------- -registerMetrics :: [RidleyMetric] -> Ridley [RidleyMetricHandler] -registerMetrics [] = return [] -registerMetrics (x:xs) = do - opts <- ask - let popts = opts ^. prometheusOptions - let sev = opts ^. katipSeverity - le <- getLogEnv - case x of - CustomMetric metricName mb_timeout custom -> do - customMetric <- case mb_timeout of - Nothing -> lift (custom opts) - Just microseconds -> do - RidleyMetricHandler mtr upd flsh lbl cs <- lift (custom opts) - doUpdate <- liftIO $ Auto.mkAutoUpdate Auto.defaultUpdateSettings - { updateAction = upd mtr flsh `Ex.catch` logFailedUpdate le lbl cs - , updateFreq = microseconds - } - pure $ RidleyMetricHandler mtr (\_ _ -> doUpdate) flsh lbl cs - $(logTM) sev $ "Registering CustomMetric '" <> fromString (T.unpack metricName) <> "'..." - (customMetric :) <$> (registerMetrics xs) - ProcessMemory -> do - processReservedMemory <- lift $ P.registerGauge "process_memory_kb" (popts ^. labels) - let !m = processMemory processReservedMemory - $(logTM) sev "Registering ProcessMemory metric..." - (m :) <$> (registerMetrics xs) - CPULoad -> do - cpu1m <- lift $ P.registerGauge "cpu_load1" (popts ^. labels) - cpu5m <- lift $ P.registerGauge "cpu_load5" (popts ^. labels) - cpu15m <- lift $ P.registerGauge "cpu_load15" (popts ^. labels) - let !cpu = processCPULoad (cpu1m, cpu5m, cpu15m) - $(logTM) sev "Registering CPULoad metric..." - (cpu :) <$> (registerMetrics xs) - GHCConc -> do - -- We don't want to keep updating this as it's a one-shot measure. - numCaps <- lift $ P.registerCounter "ghc_conc_num_capabilities" (popts ^. labels) - numPros <- lift $ P.registerCounter "ghc_conc_num_processors" (popts ^. labels) - liftIO (getNumCapabilities >>= \cap -> add (fromIntegral cap) numCaps) - liftIO (getNumProcessors >>= \cap -> add (fromIntegral cap) numPros) - $(logTM) sev "Registering GHCConc metric..." - registerMetrics xs - -- Ignore `Wai` as we will use an external library for that. - Wai -> registerMetrics xs - DiskUsage -> do - diskStats <- liftIO getDiskStats - dmap <- lift $ foldM (mkDiskGauge (popts ^. labels)) M.empty diskStats - let !diskUsage = diskUsageMetrics dmap - $(logTM) sev "Registering DiskUsage metric..." - (diskUsage :) <$> registerMetrics xs - Network -> do +registerMetrics :: Set.Set RidleyMetric -> Ridley [RidleyMetricHandler] +registerMetrics = foldM registerSingleMetric [] + where + registerSingleMetric :: [RidleyMetricHandler] -> RidleyMetric -> Ridley [RidleyMetricHandler] + registerSingleMetric !acc x = case x of + CustomMetric metricName mb_timeout custom + -> tryRegister x acc $ registerCustomMetric metricName mb_timeout custom + ProcessMemory + -> tryRegister x acc registerProcessMemory + CPULoad + -> tryRegister x acc registerCPULoad + GHCConc + -> tryRegister x acc registerGHCConc + Wai + -> pure acc -- Ignore `Wai` as we will use an external library for that. + DiskUsage + -> tryRegister x acc registerDiskUsage + Network + -> tryRegister x acc registerNetworkMetric + +tryRegister :: RidleyMetric -> [RidleyMetricHandler] -> Ridley RidleyMetricHandler -> Ridley [RidleyMetricHandler] +tryRegister metric !acc doRegister = do + registrationResult <- Ex.tryAny doRegister + case registrationResult of + Left ex -> do + $(logTM) ErrorS $ ls $ T.pack $ "Registration of metric '" <> show metric <> "' failed due to: " <> show ex + pure acc + Right metricHandler -> pure $! metricHandler : acc + +registerProcessMemory :: Ridley RidleyMetricHandler +registerProcessMemory = do + sev <- asks (view katipSeverity) + popts <- asks (view prometheusOptions) + logger <- ioLogger + processReservedMemory <- lift $ P.registerGauge "process_memory_kb" (popts ^. labels) + let !m = processMemory logger processReservedMemory + $(logTM) sev "Registering ProcessMemory metric..." + pure m + +registerCPULoad :: Ridley RidleyMetricHandler +registerCPULoad = do + sev <- asks (view katipSeverity) + popts <- asks (view prometheusOptions) + cpu1m <- lift $ P.registerGauge "cpu_load1" (popts ^. labels) + cpu5m <- lift $ P.registerGauge "cpu_load5" (popts ^. labels) + cpu15m <- lift $ P.registerGauge "cpu_load15" (popts ^. labels) + let !cpu = processCPULoad (cpu1m, cpu5m, cpu15m) + $(logTM) sev "Registering CPULoad metric..." + pure cpu + +registerGHCConc :: Ridley RidleyMetricHandler +registerGHCConc = do + sev <- asks (view katipSeverity) + popts <- asks (view prometheusOptions) + -- We don't want to keep updating this as it's a one-shot measure. + numCaps <- lift $ P.registerCounter "ghc_conc_num_capabilities" (popts ^. labels) + numPros <- lift $ P.registerCounter "ghc_conc_num_processors" (popts ^. labels) + liftIO (getNumCapabilities >>= \cap -> add (fromIntegral cap) numCaps) + liftIO (getNumProcessors >>= \cap -> add (fromIntegral cap) numPros) + $(logTM) sev "Registering GHCConc metric..." + pure $ mkRidleyMetricHandler "ridley-ghc-conc" (numCaps, numPros) noUpdate False + +registerDiskUsage :: Ridley RidleyMetricHandler +registerDiskUsage = do + sev <- asks (view katipSeverity) + diskUsage <- newDiskUsageMetrics + $(logTM) sev "Registering DiskUsage metric..." + pure diskUsage + +registerCustomMetric :: T.Text + -> Maybe Int + -> (forall m. MonadIO m => RidleyOptions -> P.RegistryT m RidleyMetricHandler) + -> Ridley RidleyMetricHandler +registerCustomMetric metricName mb_timeout custom = do + opts <- getRidleyOptions + let sev = opts ^. katipSeverity + le <- getLogEnv + customMetric <- case mb_timeout of + Nothing -> lift (custom opts) + Just microseconds -> do + RidleyMetricHandler mtr upd flsh lbl cs <- lift (custom opts) + doUpdate <- liftIO $ Auto.mkAutoUpdate Auto.defaultUpdateSettings + { updateAction = upd mtr flsh `Ex.catch` logFailedUpdate le lbl cs + , updateFreq = microseconds + } + pure $ RidleyMetricHandler mtr (\_ _ -> doUpdate) flsh lbl cs + $(logTM) sev $ "Registering CustomMetric '" <> fromString (T.unpack metricName) <> "'..." + pure customMetric + +registerNetworkMetric :: Ridley RidleyMetricHandler +registerNetworkMetric = do + sev <- asks (view katipSeverity) + popts <- asks (view prometheusOptions) #if defined darwin_HOST_OS - (ifaces, dtor) <- liftIO getNetworkMetrics - imap <- lift $ foldM (mkInterfaceGauge (popts ^. labels)) M.empty ifaces - liftIO dtor + (ifaces, dtor) <- liftIO getNetworkMetrics + imap <- lift $ foldM (mkInterfaceGauge (popts ^. labels)) M.empty ifaces + liftIO dtor #else - ifaces <- liftIO getNetworkMetrics - imap <- lift $ foldM (mkInterfaceGauge (popts ^. labels)) M.empty ifaces + ifaces <- liftIO getNetworkMetrics + imap <- lift $ foldM (mkInterfaceGauge (popts ^. labels)) M.empty ifaces #endif - let !network = networkMetrics imap - $(logTM) sev "Registering Network metric..." - (network :) <$> registerMetrics xs + let !network = networkMetrics imap + $(logTM) sev "Registering Network metric..." + pure network -------------------------------------------------------------------------------- startRidleyWithStore :: RidleyOptions @@ -162,7 +208,7 @@ -- Start the server serverLoop <- async $ runRidley opts le' $ do lift $ registerEKGStore store (opts ^. prometheusOptions) - handlers <- registerMetrics (Set.toList $ opts ^. ridleyMetrics) + handlers <- registerMetrics (opts ^. ridleyMetrics) liftIO $ do lastUpdate <- newIORef =<< getCurrentTime diff --git a/src/System/Metrics/Prometheus/Ridley/Metrics/DiskUsage.hs b/src/System/Metrics/Prometheus/Ridley/Metrics/DiskUsage.hs --- a/src/System/Metrics/Prometheus/Ridley/Metrics/DiskUsage.hs +++ b/src/System/Metrics/Prometheus/Ridley/Metrics/DiskUsage.hs @@ -3,24 +3,27 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} module System.Metrics.Prometheus.Ridley.Metrics.DiskUsage ( - getDiskStats - , mkDiskGauge - , diskUsageMetrics + newDiskUsageMetrics ) where import Control.Monad import Control.Monad.IO.Class -import qualified Data.Map.Strict as M +import Control.Monad.Trans.Class import Data.Maybe -import qualified Data.Text as T +import Katip import Lens.Micro import Lens.Micro.TH +import System.Exit +import System.Metrics.Prometheus.Ridley.Types +import System.Metrics.Prometheus.Ridley.Types.Internal +import System.Process +import System.Remote.Monitoring.Prometheus (labels) +import Text.Read hiding (lift) +import qualified Data.Map.Strict as M +import qualified Data.Text as T import qualified System.Metrics.Prometheus.Metric.Gauge as P import qualified System.Metrics.Prometheus.MetricId as P import qualified System.Metrics.Prometheus.RegistryT as P -import System.Metrics.Prometheus.Ridley.Types -import System.Process -import Text.Read -------------------------------------------------------------------------------- @@ -42,12 +45,16 @@ type DiskUsageMetrics = M.Map T.Text DiskMetric -------------------------------------------------------------------------------- -getDiskStats :: IO [DiskStats] -getDiskStats = do +getDiskStats :: Logger -> IO [DiskStats] +getDiskStats logger = do let diskOnly = (\d -> "/dev" `T.isInfixOf` (d ^. diskFilesystem)) - let dropHeader = drop 1 - rawLines <- dropHeader . T.lines . T.strip . T.pack <$> readProcess "df" [] [] - return $ filter diskOnly . mapMaybe mkDiskStats $ rawLines + let dropHeader = drop 1 . T.lines . T.strip . T.pack + (exitCode, rawLines, errors) <- readProcessWithExitCode "df" [] [] + case exitCode of + ExitSuccess -> return $ filter diskOnly . mapMaybe mkDiskStats $ dropHeader rawLines + ExitFailure ec -> do + logger ErrorS $ "getDiskStats exited with error code " <> T.pack (show ec) <> ": " <> T.pack errors + pure mempty where mkDiskStats :: T.Text -> Maybe DiskStats mkDiskStats rawLine = case T.words rawLine of @@ -73,9 +80,9 @@ P.set (d ^. diskFree) _dskMetricFree -------------------------------------------------------------------------------- -updateDiskUsageMetrics :: DiskUsageMetrics -> Bool -> IO () -updateDiskUsageMetrics dmetrics flush = do - diskStats <- getDiskStats +updateDiskUsageMetrics :: Logger -> DiskUsageMetrics -> Bool -> IO () +updateDiskUsageMetrics logger dmetrics flush = do + diskStats <- getDiskStats logger forM_ diskStats $ \d -> do let key = d ^. diskFilesystem case M.lookup key dmetrics of @@ -83,10 +90,6 @@ Just m -> updateDiskUsageMetric m d flush -------------------------------------------------------------------------------- -diskUsageMetrics :: DiskUsageMetrics -> RidleyMetricHandler -diskUsageMetrics g = mkRidleyMetricHandler "ridley-disk-usage" g updateDiskUsageMetrics False - --------------------------------------------------------------------------------- mkDiskGauge :: MonadIO m => P.Labels -> DiskUsageMetrics -> DiskStats -> P.RegistryT m DiskUsageMetrics mkDiskGauge currentLabels dmap d = do let fs = d ^. diskFilesystem @@ -95,3 +98,12 @@ <*> P.registerGauge "disk_free_bytes_blocks" finalLabels liftIO $ updateDiskUsageMetric metric d False return $! M.insert fs metric $! dmap + +-- | Creates a new 'RidleyMetricHandler' to monitor disk usage. +newDiskUsageMetrics :: Ridley RidleyMetricHandler +newDiskUsageMetrics = do + logger <- ioLogger + opts <- getRidleyOptions + diskStats <- liftIO (getDiskStats logger) + metrics <- lift $ foldM (mkDiskGauge (opts ^. prometheusOptions . labels)) M.empty diskStats + pure $ mkRidleyMetricHandler "ridley-disk-usage" metrics (updateDiskUsageMetrics logger) False diff --git a/src/System/Metrics/Prometheus/Ridley/Metrics/Memory.hs b/src/System/Metrics/Prometheus/Ridley/Metrics/Memory.hs --- a/src/System/Metrics/Prometheus/Ridley/Metrics/Memory.hs +++ b/src/System/Metrics/Prometheus/Ridley/Metrics/Memory.hs @@ -3,11 +3,15 @@ processMemory ) where -import qualified System.Metrics.Prometheus.Metric.Gauge as P +import Katip +import System.Exit import System.Metrics.Prometheus.Ridley.Types +import System.Metrics.Prometheus.Ridley.Types.Internal import System.Posix.Process import System.Process import Text.Read +import qualified Data.Text as T +import qualified System.Metrics.Prometheus.Metric.Gauge as P -------------------------------------------------------------------------------- -- | Return the amount of occupied memory for this @@ -16,20 +20,26 @@ -- accurate, at least works on Darwin and Linux -- without using any CPP processor. -- Returns the memory in Kb. -getProcessMemory :: IO (Maybe Integer) -getProcessMemory = do +getProcessMemory :: Logger -> IO (Maybe Integer) +getProcessMemory logger = do myPid <- getProcessID - readMaybe <$> readProcess "ps" ["-o", "rss=", "-p", show myPid] [] + (exitCode, rawOutput, errors) <- readProcessWithExitCode "ps" ["-o", "rss=", "-p", show myPid] [] + case exitCode of + ExitSuccess -> pure $ readMaybe rawOutput + ExitFailure ec -> do + logger ErrorS $ "getProcessMemory exited with error code " <> T.pack (show ec) <> ": " <> T.pack errors + pure Nothing -------------------------------------------------------------------------------- -- | As this is a gauge, it makes no sense flushing it. -updateProcessMemory :: P.Gauge -> Bool -> IO () -updateProcessMemory g _ = do - mbMem <- getProcessMemory +updateProcessMemory :: Logger -> P.Gauge -> Bool -> IO () +updateProcessMemory logger g _ = do + mbMem <- getProcessMemory logger case mbMem of Nothing -> return () Just m -> P.set (fromIntegral m) g -------------------------------------------------------------------------------- -processMemory :: P.Gauge -> RidleyMetricHandler -processMemory g = mkRidleyMetricHandler "ridley-process-memory" g updateProcessMemory False +processMemory :: Logger -> P.Gauge -> RidleyMetricHandler +processMemory logger g = do + mkRidleyMetricHandler "ridley-process-memory" g (updateProcessMemory logger) False diff --git a/src/System/Metrics/Prometheus/Ridley/Types.hs b/src/System/Metrics/Prometheus/Ridley/Types.hs --- a/src/System/Metrics/Prometheus/Ridley/Types.hs +++ b/src/System/Metrics/Prometheus/Ridley/Types.hs @@ -30,24 +30,28 @@ , katipSeverity , dataRetentionPeriod , runHandler + , ioLogger + , getRidleyOptions + , noUpdate ) where import Control.Concurrent (ThreadId) +import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Reader (MonadReader) -import Control.Monad.Trans.Class +import Control.Monad.State.Strict import Control.Monad.Trans.Reader -import qualified Data.Set as Set -import qualified Data.Text as T import Data.Time import GHC.Stack import Katip import Lens.Micro.TH import Network.Wai.Metrics (WaiMetrics) +import System.Metrics.Prometheus.Ridley.Types.Internal +import System.Remote.Monitoring.Prometheus +import qualified Data.Set as Set +import qualified Data.Text as T import qualified System.Metrics.Prometheus.MetricId as P import qualified System.Metrics.Prometheus.RegistryT as P -import System.Remote.Monitoring.Prometheus -import System.Metrics.Prometheus.Ridley.Types.Internal -------------------------------------------------------------------------------- type Port = Int @@ -194,6 +198,14 @@ makeLenses ''RidleyCtx +instance MonadThrow Ridley where + throwM e = Ridley $ ReaderT $ \_ -> P.RegistryT $ StateT $ \_ -> throwM e + +instance MonadCatch Ridley where + catch r handler = + let unwrap opts = P.unRegistryT . flip runReaderT opts . _unRidley + in Ridley $ ReaderT $ \opts -> P.RegistryT $ catch (unwrap opts r) (unwrap opts . handler) + instance Katip Ridley where getLogEnv = Ridley $ lift (lift getLogEnv) localLogEnv f (Ridley (ReaderT m)) = @@ -211,3 +223,18 @@ runRidley :: RidleyOptions -> LogEnv -> Ridley a -> IO a runRidley opts le (Ridley ridley) = (runKatipContextT le (mempty :: SimpleLogPayload) mempty $ P.evalRegistryT $ (runReaderT ridley) opts) + +-- | Returns an IO logger which uses context defined in the 'Ridley' monad. Useful when we want to use +-- an IO logger in the update functions for the handlers, which run in plain 'IO'. +ioLogger :: Ridley Logger +ioLogger = do + le <- getLogEnv + ctx <- getKatipContext + ns <- getKatipNamespace + pure $ \sev txt -> runKatipContextT le ctx ns $ logLocM sev (ls txt) + +getRidleyOptions :: Ridley RidleyOptions +getRidleyOptions = Ridley ask + +noUpdate :: c -> Bool -> IO () +noUpdate _ _ = pure () diff --git a/src/System/Metrics/Prometheus/Ridley/Types/Internal.hs b/src/System/Metrics/Prometheus/Ridley/Types/Internal.hs --- a/src/System/Metrics/Prometheus/Ridley/Types/Internal.hs +++ b/src/System/Metrics/Prometheus/Ridley/Types/Internal.hs @@ -2,8 +2,10 @@ {-# LANGUAGE ExistentialQuantification #-} module System.Metrics.Prometheus.Ridley.Types.Internal ( RidleyMetricHandler(..) + , Logger ) where +import Katip import GHC.Stack import qualified Data.Text as T @@ -21,3 +23,4 @@ , _cs :: CallStack } +type Logger = Severity -> T.Text -> IO ()