{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module System.Metrics.Prometheus.Ridley.Metrics.FD where

import           Control.Monad.IO.Class
import           Data.Maybe (fromMaybe)
import           Data.Monoid
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)

--------------------------------------------------------------------------------
getOpenFD_unix :: ProcessID -> IO Double
getOpenFD_unix :: ProcessID -> IO Double
getOpenFD_unix ProcessID
pid = do
  Text
rawOutput <- Sh Text -> IO Text
forall (m :: * -> *) a. MonadIO m => Sh a -> m a
shelly (Sh Text -> IO Text) -> Sh Text -> IO Text
forall a b. (a -> b) -> a -> b
$ Sh Text -> Sh Text
forall a. Sh a -> Sh a
silently (Sh Text -> Sh Text) -> Sh Text -> Sh Text
forall a b. (a -> b) -> a -> b
$ Bool -> Sh Text -> Sh Text
forall a. Bool -> Sh a -> Sh a
escaping Bool
False (Sh Text -> Sh Text) -> Sh Text -> Sh Text
forall a b. (a -> b) -> a -> b
$
    Text -> Text
T.strip (Text -> Text) -> Sh Text -> Sh Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> [Text] -> Sh Text
run FilePath
"ls" [Text
"-l", Text
"/proc/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (ProcessID -> FilePath
forall a. Show a => a -> FilePath
show ProcessID
pid) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/fd", Text
"|"
                         ,Text
"wc", Text
"-l"
                         ]
  Double -> IO Double
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> IO Double) -> Double -> IO Double
forall a b. (a -> b) -> a -> b
$ Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
0.0 (FilePath -> Maybe Double
forall a. Read a => FilePath -> Maybe a
readMaybe (FilePath -> Maybe Double)
-> (Text -> FilePath) -> Text -> Maybe Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack (Text -> Maybe Double) -> Text -> Maybe Double
forall a b. (a -> b) -> a -> b
$ Text
rawOutput)

--------------------------------------------------------------------------------
getOpenFD_darwin :: ProcessID -> IO Double
getOpenFD_darwin :: ProcessID -> IO Double
getOpenFD_darwin ProcessID
pid = do
  Text
rawOutput <- Sh Text -> IO Text
forall (m :: * -> *) a. MonadIO m => Sh a -> m a
shelly (Sh Text -> IO Text) -> Sh Text -> IO Text
forall a b. (a -> b) -> a -> b
$ Sh Text -> Sh Text
forall a. Sh a -> Sh a
silently (Sh Text -> Sh Text) -> Sh Text -> Sh Text
forall a b. (a -> b) -> a -> b
$ Bool -> Sh Text -> Sh Text
forall a. Bool -> Sh a -> Sh a
escaping Bool
False (Sh Text -> Sh Text) -> Sh Text -> Sh Text
forall a b. (a -> b) -> a -> b
$
    Text -> Text
T.strip (Text -> Text) -> Sh Text -> Sh Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> [Text] -> Sh Text
run FilePath
"lsof" [Text
"-p", FilePath -> Text
T.pack (ProcessID -> FilePath
forall a. Show a => a -> FilePath
show ProcessID
pid), Text
"|"
                           ,Text
"wc", Text
"-l"
                           ]
  Double -> IO Double
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> IO Double) -> Double -> IO Double
forall a b. (a -> b) -> a -> b
$ Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
0.0 (FilePath -> Maybe Double
forall a. Read a => FilePath -> Maybe a
readMaybe (FilePath -> Maybe Double)
-> (Text -> FilePath) -> Text -> Maybe Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack (Text -> Maybe Double) -> Text -> Maybe Double
forall a b. (a -> b) -> a -> b
$ Text
rawOutput)

--------------------------------------------------------------------------------
updateOpenFD :: ProcessID -> P.Gauge -> Bool -> IO ()
updateOpenFD :: ProcessID -> Gauge -> Bool -> IO ()
updateOpenFD ProcessID
pid Gauge
gauge Bool
_ = do
#ifdef darwin_HOST_OS
  openFd <- getOpenFD_darwin pid
#else
  Double
openFd <- ProcessID -> IO Double
getOpenFD_unix ProcessID
pid
#endif
  Double -> Gauge -> IO ()
P.set Double
openFd Gauge
gauge

--------------------------------------------------------------------------------
-- | Monitors the number of open file descriptors for a given `ProcessID`.
processOpenFD :: MonadIO m
              => ProcessID
              -> RidleyOptions
              -> P.RegistryT m RidleyMetricHandler
processOpenFD :: ProcessID -> RidleyOptions -> RegistryT m RidleyMetricHandler
processOpenFD ProcessID
pid RidleyOptions
opts = do
  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
  Gauge
openFD <- Name -> Labels -> RegistryT m Gauge
forall (m :: * -> *).
MonadIO m =>
Name -> Labels -> RegistryT m Gauge
P.registerGauge Name
"process_open_fd" (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)
  RidleyMetricHandler -> RegistryT m RidleyMetricHandler
forall (m :: * -> *) a. Monad m => a -> m a
return (RidleyMetricHandler -> RegistryT m RidleyMetricHandler)
-> RidleyMetricHandler -> RegistryT m RidleyMetricHandler
forall a b. (a -> b) -> a -> b
$ Text
-> Gauge -> (Gauge -> Bool -> IO ()) -> Bool -> RidleyMetricHandler
forall c.
HasCallStack =>
Text -> c -> (c -> Bool -> IO ()) -> Bool -> RidleyMetricHandler
mkRidleyMetricHandler Text
"ridley-process-open-file-descriptors" Gauge
openFD (ProcessID -> Gauge -> Bool -> IO ()
updateOpenFD ProcessID
pid) Bool
False