diff --git a/example/Main.hs b/example/Main.hs --- a/example/Main.hs +++ b/example/Main.hs @@ -15,6 +15,7 @@ import System.IO import qualified Network.Wai as Wai import qualified Network.Wai.Handler.Warp as Warp +import Control.Monad.Reader webApp :: RidleyCtx -> IO () webApp ctx = Warp.run 8080 (app ctx) @@ -32,9 +33,10 @@ customExpensiveMetric = CustomMetric "my-expensive" (Just $ 60 * 1_000_000) get_metric where - get_metric :: MonadIO m => RidleyOptions -> P.RegistryT m RidleyMetricHandler - get_metric opts = do - m <- P.registerGauge "current_time" (opts ^. prometheusOptions . labels) + get_metric :: Ridley RidleyMetricHandler + get_metric = do + opts <- ask + m <- lift $ P.registerGauge "current_time" (opts ^. prometheusOptions . labels) return $ mkRidleyMetricHandler "current_time" m update False update :: P.Gauge -> Bool -> IO () @@ -47,9 +49,10 @@ customCrashfulMetric = CustomMetric "my-crashful" (Just $ 60 * 1_000_000) get_metric where - get_metric :: MonadIO m => RidleyOptions -> P.RegistryT m RidleyMetricHandler - get_metric opts = do - m <- P.registerGauge "crashful" (opts ^. prometheusOptions . labels) + get_metric :: Ridley RidleyMetricHandler + get_metric = do + opts <- ask + m <- lift $ P.registerGauge "crashful" (opts ^. prometheusOptions . labels) return $ mkRidleyMetricHandler "crashful" m (\_ _ -> throwIO $ userError "CRASH!!") False main :: IO () diff --git a/ridley.cabal b/ridley.cabal --- a/ridley.cabal +++ b/ridley.cabal @@ -1,5 +1,5 @@ name: ridley -version: 0.3.4.1 +version: 0.4.0.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 @@ -7,10 +7,11 @@ license-file: LICENSE author: Alfredo Di Napoli & the IRIS Connect Engineering Team maintainer: engineering@irisconnect.co.uk -copyright: 2023 IRIS Connect Ltd. +copyright: 2024 IRIS Connect Ltd. category: Web build-type: Simple cabal-version: >=1.10 +tested-with: GHC == 9.4.7 || == 9.4.8 || == 9.6.4 extra-source-files: cbits/helpers.c @@ -30,12 +31,22 @@ hs-source-dirs: src exposed-modules: System.Metrics.Prometheus.Ridley System.Metrics.Prometheus.Ridley.Types - System.Metrics.Prometheus.Ridley.Metrics.Memory - System.Metrics.Prometheus.Ridley.Metrics.DiskUsage System.Metrics.Prometheus.Ridley.Metrics.CPU + System.Metrics.Prometheus.Ridley.Metrics.DiskUsage + System.Metrics.Prometheus.Ridley.Metrics.FD + System.Metrics.Prometheus.Ridley.Metrics.Memory System.Metrics.Prometheus.Ridley.Metrics.Network System.Metrics.Prometheus.Ridley.Metrics.Network.Types + System.Metrics.Prometheus.Ridley.Metrics.PhysicalMemory + System.Metrics.Prometheus.Ridley.Metrics.VirtualMemory other-modules: System.Metrics.Prometheus.Ridley.Types.Internal + if os(darwin) + c-sources: src/System/Metrics/Prometheus/Ridley/Metrics/CPU/Darwin.c + other-modules: System.Metrics.Prometheus.Ridley.Metrics.Network.Darwin + System.Metrics.Prometheus.Ridley.Metrics.CPU.Darwin + else + other-modules: System.Metrics.Prometheus.Ridley.Metrics.Network.Unix + System.Metrics.Prometheus.Ridley.Metrics.CPU.Unix build-depends: async < 3.0.0, auto-update >= 0.1, @@ -58,7 +69,7 @@ microlens-th, process, string-conv, - ekg-prometheus-adapter >= 0.1.0.3, + ekg-prometheus-adapter >= 0.1.0.5, inline-c, vector, unix, @@ -69,13 +80,6 @@ default-language: Haskell2010 if flag(lib-Werror) ghc-options: -Wall -Werror - if os(darwin) - c-sources: src/System/Metrics/Prometheus/Ridley/Metrics/CPU/Darwin.c - other-modules: System.Metrics.Prometheus.Ridley.Metrics.Network.Darwin - System.Metrics.Prometheus.Ridley.Metrics.CPU.Darwin - else - other-modules: System.Metrics.Prometheus.Ridley.Metrics.Network.Unix - System.Metrics.Prometheus.Ridley.Metrics.CPU.Unix test-suite ridley-test type: exitcode-stdio-1.0 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 @@ -144,18 +144,15 @@ $(logTM) sev "Registering DiskUsage metric..." pure diskUsage -registerCustomMetric :: T.Text - -> Maybe Int - -> (forall m. MonadIO m => RidleyOptions -> P.RegistryT m RidleyMetricHandler) - -> Ridley RidleyMetricHandler +registerCustomMetric :: T.Text -> Maybe Int -> Ridley 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) + Nothing -> custom Just microseconds -> do - RidleyMetricHandler mtr upd flsh lbl cs <- lift (custom opts) + RidleyMetricHandler mtr upd flsh lbl cs <- custom doUpdate <- liftIO $ Auto.mkAutoUpdate Auto.defaultUpdateSettings { updateAction = upd mtr flsh `Ex.catch` logFailedUpdate le lbl cs , updateFreq = microseconds diff --git a/src/System/Metrics/Prometheus/Ridley/Metrics/FD.hs b/src/System/Metrics/Prometheus/Ridley/Metrics/FD.hs new file mode 100644 --- /dev/null +++ b/src/System/Metrics/Prometheus/Ridley/Metrics/FD.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +module System.Metrics.Prometheus.Ridley.Metrics.FD where + +import qualified Data.Text as T +import Lens.Micro +import Shelly +import Katip.Core +import qualified System.Metrics.Prometheus.Metric.Gauge as P +import qualified System.Metrics.Prometheus.RegistryT as P +import System.Metrics.Prometheus.Ridley.Types +import System.Posix.Types (ProcessID) +import System.Remote.Monitoring.Prometheus (labels) +import Katip.Monadic +import Data.String +import Control.Monad.Trans (lift) +import Control.Monad.Reader (ask) + +logAndReturnFDs :: RidleyOptions -> LogEnv -> ProcessID -> [T.Text] -> IO Double +logAndReturnFDs opts le pid descriptors = do + let !descriptorsNums = length descriptors + when (descriptorsNums >= opts ^. openFDWarningTreshold) $ + runRidley opts le $ do + $(logTM) WarningS $ fromString $ "Careful, number of open file descriptors for process " <> show pid <> " exceeded warning threshold (" <> show (opts ^. openFDWarningTreshold) <> "):\n" <> T.unpack (T.unlines descriptors) + return $ (fromIntegral $ descriptorsNums) + +-------------------------------------------------------------------------------- +getOpenFD_unix :: RidleyOptions -> LogEnv -> ProcessID -> IO Double +getOpenFD_unix opts le pid = do + descriptors <- shelly $ silently $ escaping False $ + T.lines . T.strip <$> run "ls" ["-l", "/proc/" <> T.pack (show pid) <> "/fd", "|" + ,"grep", "^l" + ] + logAndReturnFDs opts le pid descriptors + +-------------------------------------------------------------------------------- +getOpenFD_darwin :: RidleyOptions -> LogEnv -> ProcessID -> IO Double +getOpenFD_darwin opts le pid = do + descriptors <- shelly $ silently $ escaping False $ + T.lines . T.strip <$> run "lsof" ["-p", T.pack (show pid), "|" + ,"grep", "REG", "|", "awk", "'{print $9}'" + ] + logAndReturnFDs opts le pid descriptors + +-------------------------------------------------------------------------------- +updateOpenFD :: RidleyOptions -> LogEnv -> ProcessID -> P.Gauge -> Bool -> IO () +updateOpenFD opts le pid gauge _ = do +#ifdef darwin_HOST_OS + openFd <- getOpenFD_darwin opts le pid +#else + openFd <- getOpenFD_unix opts le pid +#endif + P.set openFd gauge + +-------------------------------------------------------------------------------- +-- | Monitors the number of open file descriptors for a given `ProcessID`. +processOpenFD :: ProcessID + -> Ridley RidleyMetricHandler +processOpenFD pid = do + opts <- ask + le <- getLogEnv + let popts = opts ^. prometheusOptions + openFD <- lift $ P.registerGauge "process_open_fd" (popts ^. labels) + return $ mkRidleyMetricHandler "ridley-process-open-file-descriptors" openFD (updateOpenFD opts le pid) False diff --git a/src/System/Metrics/Prometheus/Ridley/Metrics/PhysicalMemory.hs b/src/System/Metrics/Prometheus/Ridley/Metrics/PhysicalMemory.hs new file mode 100644 --- /dev/null +++ b/src/System/Metrics/Prometheus/Ridley/Metrics/PhysicalMemory.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +module System.Metrics.Prometheus.Ridley.Metrics.PhysicalMemory where + +import Data.Maybe (mapMaybe) +import Data.Word +import qualified Data.Text as T +import Lens.Micro +import Shelly +import qualified System.Metrics.Prometheus.Metric.Gauge as P +import qualified System.Metrics.Prometheus.RegistryT as P +import System.Metrics.Prometheus.Ridley.Types +import System.Remote.Monitoring.Prometheus (labels) +import Text.Read (readMaybe) +import Control.Monad.Reader + +{- Calling 'free' will report +[service-runner@hermes-devel ~]$ free -k + total used free shared buff/cache available +Mem: 962 377 251 36 333 377 +Swap: 4095 0 4095 +-} + +-------------------------------------------------------------------------------- +getFreeStats :: IO FreeReport +getFreeStats = do + rawOutput <- shelly $ silently $ escaping False $ + mapMaybe (readMaybe @Word64 . T.unpack) . T.words . T.strip <$> run "free" ["-m" ,"|" , "tail", "-n", "-2" , "|", "awk", "-F", "\" \"", "'{printf \"%s %s %s %s %s %s %s\", $2, $3, $4, $5, $6, $7, $8}'"] + case rawOutput of + [ free_mem_total_mb + , free_mem_used_mb + , free_mem_free_mb + , free_mem_shared_mb + , free_mem_buff_cache_mb + , free_mem_available_mb + , free_swap_total_mb + , free_swap_used_mb + , free_swap_free_mb + ] -> pure $ FreeReport{..} + _ -> pure emptyFreeReport + +-------------------------------------------------------------------------------- +updateFreeStats :: FreeGauges -> Bool -> IO () +updateFreeStats FreeGauges{..} _ = do +#ifdef darwin_HOST_OS + let FreeReport{..} = emptyFreeReport-- "free" is not available on Darwin. +#else + FreeReport{..} <- getFreeStats +#endif + P.set (realToFrac free_mem_total_mb ) free_mem_total_mb_g + P.set (realToFrac free_mem_used_mb ) free_mem_used_mb_g + P.set (realToFrac free_mem_free_mb ) free_mem_free_mb_g + P.set (realToFrac free_mem_shared_mb ) free_mem_shared_mb_g + P.set (realToFrac free_mem_buff_cache_mb ) free_mem_buff_cache_mb_g + P.set (realToFrac free_mem_available_mb ) free_mem_available_mb_g + P.set (realToFrac free_swap_total_mb ) free_swap_total_mb_g + P.set (realToFrac free_swap_used_mb ) free_swap_used_mb_g + P.set (realToFrac free_swap_free_mb ) free_swap_free_mb_g + +data FreeReport = + FreeReport { + free_mem_total_mb :: !Word64 + , free_mem_used_mb :: !Word64 + , free_mem_free_mb :: !Word64 + , free_mem_shared_mb :: !Word64 + , free_mem_buff_cache_mb :: !Word64 + , free_mem_available_mb :: !Word64 + , free_swap_total_mb :: !Word64 + , free_swap_used_mb :: !Word64 + , free_swap_free_mb :: !Word64 + } deriving (Show, Eq) + +emptyFreeReport :: FreeReport +emptyFreeReport = FreeReport + { free_mem_total_mb = 0 + , free_mem_used_mb = 0 + , free_mem_free_mb = 0 + , free_mem_shared_mb = 0 + , free_mem_buff_cache_mb = 0 + , free_mem_available_mb = 0 + , free_swap_total_mb = 0 + , free_swap_used_mb = 0 + , free_swap_free_mb = 0 + } + + +data FreeGauges = + FreeGauges { + free_mem_total_mb_g :: !P.Gauge + , free_mem_used_mb_g :: !P.Gauge + , free_mem_free_mb_g :: !P.Gauge + , free_mem_shared_mb_g :: !P.Gauge + , free_mem_buff_cache_mb_g :: !P.Gauge + , free_mem_available_mb_g :: !P.Gauge + , free_swap_total_mb_g :: !P.Gauge + , free_swap_used_mb_g :: !P.Gauge + , free_swap_free_mb_g :: !P.Gauge + } + +-------------------------------------------------------------------------------- +-- | Returns the physical memory total and free as sampled from 'free'. +systemPhysicalMemory :: Ridley RidleyMetricHandler +systemPhysicalMemory = do + opts <- ask + let popts = opts ^. prometheusOptions + gauges <- lift $ FreeGauges <$> P.registerGauge "free_mem_total_mb" (popts ^. labels) + <*> P.registerGauge "free_mem_used_mb" (popts ^. labels) + <*> P.registerGauge "free_mem_free_mb" (popts ^. labels) + <*> P.registerGauge "free_mem_shared_mb" (popts ^. labels) + <*> P.registerGauge "free_mem_buff_cache_mb" (popts ^. labels) + <*> P.registerGauge "free_mem_available_mb" (popts ^. labels) + <*> P.registerGauge "free_swap_total_mb" (popts ^. labels) + <*> P.registerGauge "free_swap_used_mb" (popts ^. labels) + <*> P.registerGauge "free_swap_free_mb" (popts ^. labels) + return $ mkRidleyMetricHandler "ridley-physical-memory-statistics" gauges updateFreeStats False diff --git a/src/System/Metrics/Prometheus/Ridley/Metrics/VirtualMemory.hs b/src/System/Metrics/Prometheus/Ridley/Metrics/VirtualMemory.hs new file mode 100644 --- /dev/null +++ b/src/System/Metrics/Prometheus/Ridley/Metrics/VirtualMemory.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +module System.Metrics.Prometheus.Ridley.Metrics.VirtualMemory where + +import Control.Monad.Reader (ask, lift) +import Data.Maybe (mapMaybe) +import Data.Word +import Lens.Micro +import Shelly +import System.Metrics.Prometheus.Ridley.Types +import System.Remote.Monitoring.Prometheus (labels) +import Text.Read (readMaybe) +import qualified Data.Text as T +import qualified System.Metrics.Prometheus.Metric.Gauge as P +import qualified System.Metrics.Prometheus.RegistryT as P + +{- Calling 'vmstat' will report + +[centos@atlas-eu ~]$ vmstat -S M -s + 130701440 M total memory + 52971728 M used memory + 92670416 M active memory + 33348008 M inactive memory + 852768 M free memory + 0 M buffer memory + 76876944 M swap cache + 0 M total swap + 0 M used swap + 0 M free swap + ... +-} + +-------------------------------------------------------------------------------- +getVmStats :: IO VmStatReport +getVmStats = do + rawOutput <- shelly $ silently $ escaping False $ + mapMaybe (readMaybe @Word64 . T.unpack) . T.words . T.strip + <$> run "vmstat" ["-S", "M", "-s" ,"|" , "head", "-n", "10" , "|" , "awk", "-F", "\" \"" , "'{print $1}'" ] + case rawOutput of + [ vmstat_total_memory_mb + , vmstat_used_memory_mb + , vmstat_active_memory_mb + , vmstat_inactive_memory_mb + , vmstat_free_memory_mb + , vmstat_buffer_memory_mb + , vmstat_swap_cache_mb + , vmstat_total_swap_mb + , vmstat_used_swap_mb + , vmstat_free_swap_mb + ] -> pure $ VmStatReport{..} + _ -> pure emptyVmStatReport + +-------------------------------------------------------------------------------- +updateVmStat :: VmStatGauges -> Bool -> IO () +updateVmStat VmStatGauges{..} _ = do +#ifdef darwin_HOST_OS + let VmStatReport{..} = emptyVmStatReport-- "vmstat" is not available on Darwin. +#else + VmStatReport{..} <- getVmStats +#endif + P.set (realToFrac vmstat_total_memory_mb ) vmstat_total_memory_mb_g + P.set (realToFrac vmstat_used_memory_mb ) vmstat_used_memory_mb_g + P.set (realToFrac vmstat_active_memory_mb ) vmstat_active_memory_mb_g + P.set (realToFrac vmstat_inactive_memory_mb ) vmstat_inactive_memory_mb_g + P.set (realToFrac vmstat_free_memory_mb ) vmstat_free_memory_mb_g + P.set (realToFrac vmstat_buffer_memory_mb ) vmstat_buffer_memory_mb_g + P.set (realToFrac vmstat_swap_cache_mb ) vmstat_swap_cache_mb_g + P.set (realToFrac vmstat_total_swap_mb ) vmstat_total_swap_mb_g + P.set (realToFrac vmstat_used_swap_mb ) vmstat_used_swap_mb_g + P.set (realToFrac vmstat_free_swap_mb ) vmstat_free_swap_mb_g + +data VmStatReport = + VmStatReport { + vmstat_total_memory_mb :: !Word64 + , vmstat_used_memory_mb :: !Word64 + , vmstat_active_memory_mb :: !Word64 + , vmstat_inactive_memory_mb :: !Word64 + , vmstat_free_memory_mb :: !Word64 + , vmstat_buffer_memory_mb :: !Word64 + , vmstat_swap_cache_mb :: !Word64 + , vmstat_total_swap_mb :: !Word64 + , vmstat_used_swap_mb :: !Word64 + , vmstat_free_swap_mb :: !Word64 + } deriving (Show, Eq) + +emptyVmStatReport :: VmStatReport +emptyVmStatReport = VmStatReport + { vmstat_total_memory_mb = 0 + , vmstat_used_memory_mb = 0 + , vmstat_active_memory_mb = 0 + , vmstat_inactive_memory_mb = 0 + , vmstat_free_memory_mb = 0 + , vmstat_buffer_memory_mb = 0 + , vmstat_swap_cache_mb = 0 + , vmstat_total_swap_mb = 0 + , vmstat_used_swap_mb = 0 + , vmstat_free_swap_mb = 0 + } + + +data VmStatGauges = + VmStatGauges { + vmstat_total_memory_mb_g :: !P.Gauge + , vmstat_used_memory_mb_g :: !P.Gauge + , vmstat_active_memory_mb_g :: !P.Gauge + , vmstat_inactive_memory_mb_g :: !P.Gauge + , vmstat_free_memory_mb_g :: !P.Gauge + , vmstat_buffer_memory_mb_g :: !P.Gauge + , vmstat_swap_cache_mb_g :: !P.Gauge + , vmstat_total_swap_mb_g :: !P.Gauge + , vmstat_used_swap_mb_g :: !P.Gauge + , vmstat_free_swap_mb_g :: !P.Gauge + } + +-------------------------------------------------------------------------------- +-- | Returns the virtual memory total and free as sampled from 'vmstat'. +systemVirtualMemory :: Ridley RidleyMetricHandler +systemVirtualMemory = do + opts <- ask + let popts = opts ^. prometheusOptions + gauges <- lift $ VmStatGauges <$> P.registerGauge "vmstat_total_memory_mb" (popts ^. labels) + <*> P.registerGauge "vmstat_used_memory_mb" (popts ^. labels) + <*> P.registerGauge "vmstat_active_memory_mb" (popts ^. labels) + <*> P.registerGauge "vmstat_inactive_memory_mb" (popts ^. labels) + <*> P.registerGauge "vmstat_free_memory_mb" (popts ^. labels) + <*> P.registerGauge "vmstat_buffer_memory_mb" (popts ^. labels) + <*> P.registerGauge "vmstat_swap_cache_mb" (popts ^. labels) + <*> P.registerGauge "vmstat_total_swap_mb" (popts ^. labels) + <*> P.registerGauge "vmstat_used_swap_mb" (popts ^. labels) + <*> P.registerGauge "vmstat_free_swap_mb" (popts ^. labels) + return $ mkRidleyMetricHandler "ridley-virtual-memory-statistics" gauges updateVmStat 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 @@ -29,6 +29,7 @@ , katipScribes , katipSeverity , dataRetentionPeriod + , openFDWarningTreshold , runHandler , ioLogger , getRidleyOptions @@ -86,7 +87,7 @@ -- will be updated using Ridley top-level setting, -- if 'Just' the underlying 'IO' action will be run -- only every @n@ seconds, or cached otherwise. - (forall m. MonadIO m => RidleyOptions -> P.RegistryT m RidleyMetricHandler) + (Ridley RidleyMetricHandler) -- ^ An action to generate the handler. -- ^ A user-defined metric, identified by a name. @@ -159,12 +160,11 @@ , _katipScribes :: (Katip.Namespace, [(T.Text, Katip.Scribe)]) , _katipSeverity :: Katip.Severity , _dataRetentionPeriod :: Maybe NominalDiffTime + , _openFDWarningTreshold :: !Int -- ^ How much to retain the data, in seconds. -- Pass `Nothing` to not flush the metrics. } -makeLenses ''RidleyOptions - -------------------------------------------------------------------------------- defaultMetrics :: [RidleyMetric] defaultMetrics = [ProcessMemory, CPULoad, GHCConc, Network, Wai, DiskUsage] @@ -179,6 +179,7 @@ , _katipSeverity = InfoS , _katipScribes = mempty , _dataRetentionPeriod = Nothing + , _openFDWarningTreshold = 100 } -------------------------------------------------------------------------------- @@ -196,8 +197,6 @@ , _ridleyWaiMetrics :: Maybe WaiMetrics } -makeLenses ''RidleyCtx - instance MonadThrow Ridley where throwM e = Ridley $ ReaderT $ \_ -> P.RegistryT $ StateT $ \_ -> throwM e @@ -238,3 +237,7 @@ noUpdate :: c -> Bool -> IO () noUpdate _ _ = pure () + +makeLenses ''RidleyCtx +makeLenses ''RidleyOptions +