Merge pull request #49 from iconnect/adinapoli/issue-48

Log actual open FDs if they exceeds threshold

ridley-extras/ridley-extras.cabal

@@ -1,5 +1,5 @@
 name:                ridley-extras
-version:             0.1.3.0
+version:             0.1.4.0
 synopsis:            Handy metrics that don't belong to ridley.
 description:         See README.md
 homepage:            https://github.com/iconnect/ridley/ridley-extras#readme
@@ -27,6 +27,7 @@ library
   build-depends:       base >= 4.7 && < 5,
                        text,
                        prometheus < 3,
+                       katip < 0.9.0.0,
                        shelly < 1.9.0.0,
                        microlens,
                        ekg-prometheus-adapter < 0.3.0.0,

ridley-extras/src/System/Metrics/Prometheus/Ridley/Metrics/FD.hs

@@ -1,5 +1,7 @@
+{-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP               #-}
+{-# LANGUAGE BangPatterns      #-}
 module System.Metrics.Prometheus.Ridley.Metrics.FD where
 
 import           Control.Monad.IO.Class
@@ -8,48 +10,61 @@ import           Data.Monoid
 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           Text.Read (readMaybe)
+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 :: ProcessID -> IO Double
-getOpenFD_unix pid = do
-  rawOutput <- shelly $ silently $ escaping False $
-    T.strip <$> run "ls" ["-l", "/proc/" <> T.pack (show pid) <> "/fd", "|"
-                         ,"wc", "-l"
+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"
                          ]
-  return $ fromMaybe 0.0 (readMaybe . T.unpack $ rawOutput)
+  logAndReturnFDs opts le pid descriptors
 
 --------------------------------------------------------------------------------
-getOpenFD_darwin :: ProcessID -> IO Double
-getOpenFD_darwin pid = do
-  rawOutput <- shelly $ silently $ escaping False $
-    T.strip <$> run "lsof" ["-p", T.pack (show pid), "|"
-                           ,"wc", "-l"
+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}'"
                            ]
-  return $ fromMaybe 0.0 (readMaybe . T.unpack $ rawOutput)
+  logAndReturnFDs opts le pid descriptors
 
 --------------------------------------------------------------------------------
-updateOpenFD :: ProcessID -> P.Gauge -> Bool -> IO ()
-updateOpenFD pid gauge _ = do
+updateOpenFD :: RidleyOptions -> LogEnv -> ProcessID -> P.Gauge -> Bool -> IO ()
+updateOpenFD opts le pid gauge _ = do
 #ifdef darwin_HOST_OS
-  openFd <- getOpenFD_darwin pid
+  openFd <- getOpenFD_darwin opts le pid
 #else
-  openFd <- getOpenFD_unix pid
+  openFd <- getOpenFD_unix opts le pid
 #endif
   P.set openFd gauge
 
 --------------------------------------------------------------------------------
 -- | Monitors the number of open file descriptors for a given `ProcessID`.
-processOpenFD :: MonadIO m
-              => ProcessID
-              -> RidleyOptions
-              -> P.RegistryT m RidleyMetricHandler
-processOpenFD pid opts = do
+processOpenFD :: ProcessID
+              -> Ridley RidleyMetricHandler
+processOpenFD pid = do
+  opts <- ask
+  le   <- getLogEnv
   let popts = opts ^. prometheusOptions
-  openFD <- P.registerGauge "process_open_fd" (popts ^. labels)
-  return $ mkRidleyMetricHandler "ridley-process-open-file-descriptors" openFD (updateOpenFD pid) False
+  openFD <- lift $ P.registerGauge "process_open_fd" (popts ^. labels)
+  return $ mkRidleyMetricHandler "ridley-process-open-file-descriptors" openFD (updateOpenFD opts le pid) False

ridley-extras/src/System/Metrics/Prometheus/Ridley/Metrics/PhysicalMemory.hs

@@ -17,6 +17,7 @@ import           System.Metrics.Prometheus.Ridley.Types
 import           System.Posix.Types (ProcessID)
 import           System.Remote.Monitoring.Prometheus (labels)
 import           Text.Read (readMaybe)
+import Control.Monad.Reader
 
 {- Calling 'free' will report
 [service-runner@hermes-devel ~]$ free -k
@@ -103,18 +104,17 @@ data FreeGauges =
 
 --------------------------------------------------------------------------------
 -- | Returns the physical memory total and free as sampled from 'free'.
-systemPhysicalMemory :: MonadIO m
-                     => RidleyOptions
-                     -> P.RegistryT m RidleyMetricHandler
-systemPhysicalMemory opts = do
+systemPhysicalMemory :: Ridley RidleyMetricHandler
+systemPhysicalMemory = do
+  opts <- ask
   let popts = opts ^. prometheusOptions
-  gauges <- 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)
+  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

ridley-extras/src/System/Metrics/Prometheus/Ridley/Metrics/VirtualMemory.hs

@@ -5,18 +5,19 @@
 module System.Metrics.Prometheus.Ridley.Metrics.VirtualMemory where
 
 import           Control.Monad.IO.Class
+import           Control.Monad.Reader (ask, lift)
 import           Data.Maybe (fromMaybe, mapMaybe)
 import           Data.Monoid
 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.Posix.Types (ProcessID)
 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
 
@@ -118,19 +119,18 @@ data VmStatGauges =
 
 --------------------------------------------------------------------------------
 -- | Returns the virtual memory total and free as sampled from 'vmstat'.
-systemVirtualMemory :: MonadIO m
-                    => RidleyOptions
-                    -> P.RegistryT m RidleyMetricHandler
-systemVirtualMemory opts = do
+systemVirtualMemory :: Ridley RidleyMetricHandler
+systemVirtualMemory = do
+  opts <- ask
   let popts = opts ^. prometheusOptions
-  gauges <- 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)
+  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

ridley/example/Main.hs

@@ -15,6 +15,7 @@ import           Katip
 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 :: RidleyMetric
 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 :: RidleyMetric
 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 ()

ridley/ridley.cabal

@@ -1,5 +1,5 @@
 name:                ridley
-version:             0.3.4.1
+version:             0.3.5.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

ridley/src/System/Metrics/Prometheus/Ridley.hs

@@ -144,18 +144,15 @@ registerDiskUsage = do
   $(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

ridley/src/System/Metrics/Prometheus/Ridley/Types.hs

@@ -29,6 +29,7 @@ module System.Metrics.Prometheus.Ridley.Types (
   , katipScribes
   , katipSeverity
   , dataRetentionPeriod
+  , openFDWarningTreshold
   , runHandler
   , ioLogger
   , getRidleyOptions
@@ -86,7 +87,7 @@ data RidleyMetric = ProcessMemory
                                  -- 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 @@ data RidleyOptions = RidleyOptions {
   , _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 @@ newOptions appLabels metrics = RidleyOptions {
   , _katipSeverity     = InfoS
   , _katipScribes      = mempty
   , _dataRetentionPeriod = Nothing
+  , _openFDWarningTreshold = 100
   }
 
 --------------------------------------------------------------------------------
@@ -196,8 +197,6 @@ data RidleyCtx = RidleyCtx {
   , _ridleyWaiMetrics :: Maybe WaiMetrics
   }
 
-makeLenses ''RidleyCtx
-
 instance MonadThrow Ridley where
   throwM e = Ridley $ ReaderT $ \_ -> P.RegistryT $ StateT $ \_ -> throwM e
 
@@ -238,3 +237,7 @@ getRidleyOptions = Ridley ask
 
 noUpdate :: c -> Bool -> IO ()
 noUpdate _ _ = pure ()
+
+makeLenses ''RidleyCtx
+makeLenses ''RidleyOptions
+