{-# 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 :: RidleyOptions -> LogEnv -> ProcessID -> [Text] -> IO Double
logAndReturnFDs RidleyOptions
opts LogEnv
le ProcessID
pid [Text]
descriptors = do
  let !descriptorsNums :: Int
descriptorsNums = [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
descriptors
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
descriptorsNums Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= RidleyOptions
opts RidleyOptions -> Getting Int RidleyOptions Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int RidleyOptions Int
Lens' RidleyOptions Int
openFDWarningTreshold) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    RidleyOptions -> LogEnv -> Ridley () -> IO ()
forall a. RidleyOptions -> LogEnv -> Ridley a -> IO a
runRidley RidleyOptions
opts LogEnv
le (Ridley () -> IO ()) -> Ridley () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      $(logTM) Severity
WarningS (LogStr -> Ridley ()) -> LogStr -> Ridley ()
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
"Careful, number of open file descriptors for process " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ProcessID -> String
forall a. Show a => a -> String
show ProcessID
pid String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" exceeded warning threshold (" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (RidleyOptions
opts RidleyOptions -> Getting Int RidleyOptions Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int RidleyOptions Int
Lens' RidleyOptions Int
openFDWarningTreshold) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"):\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack ([Text] -> Text
T.unlines [Text]
descriptors)
  Double -> IO Double
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> IO Double) -> Double -> IO Double
forall a b. (a -> b) -> a -> b
$ (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Double) -> Int -> Double
forall a b. (a -> b) -> a -> b
$ Int
descriptorsNums)

--------------------------------------------------------------------------------
getOpenFD_unix :: RidleyOptions -> LogEnv -> ProcessID -> IO Double
getOpenFD_unix :: RidleyOptions -> LogEnv -> ProcessID -> IO Double
getOpenFD_unix RidleyOptions
opts LogEnv
le ProcessID
pid = do
  [Text]
descriptors <- 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.lines (Text -> [Text]) -> (Text -> Text) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip (Text -> [Text]) -> Sh Text -> Sh [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [Text] -> Sh Text
run String
"ls" [Text
"-l", Text
"/proc/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (ProcessID -> String
forall a. Show a => a -> String
show ProcessID
pid) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/fd", Text
"|"
                         ,Text
"grep", Text
"^l"
                         ]
  RidleyOptions -> LogEnv -> ProcessID -> [Text] -> IO Double
logAndReturnFDs RidleyOptions
opts LogEnv
le ProcessID
pid [Text]
descriptors

--------------------------------------------------------------------------------
getOpenFD_darwin :: RidleyOptions -> LogEnv -> ProcessID -> IO Double
getOpenFD_darwin :: RidleyOptions -> LogEnv -> ProcessID -> IO Double
getOpenFD_darwin RidleyOptions
opts LogEnv
le ProcessID
pid = do
  [Text]
descriptors <- 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.lines (Text -> [Text]) -> (Text -> Text) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip (Text -> [Text]) -> Sh Text -> Sh [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [Text] -> Sh Text
run String
"lsof" [Text
"-p", String -> Text
T.pack (ProcessID -> String
forall a. Show a => a -> String
show ProcessID
pid), Text
"|"
                           ,Text
"grep", Text
"REG", Text
"|", Text
"awk", Text
"'{print $9}'"
                           ]
  RidleyOptions -> LogEnv -> ProcessID -> [Text] -> IO Double
logAndReturnFDs RidleyOptions
opts LogEnv
le ProcessID
pid [Text]
descriptors

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

--------------------------------------------------------------------------------
-- | Monitors the number of open file descriptors for a given `ProcessID`.
processOpenFD :: ProcessID
              -> Ridley RidleyMetricHandler
processOpenFD :: ProcessID -> Ridley RidleyMetricHandler
processOpenFD ProcessID
pid = do
  RidleyOptions
opts <- RidleyT (RegistryT (KatipContextT IO)) RidleyOptions
forall r (m :: * -> *). MonadReader r m => m r
ask
  LogEnv
le   <- RidleyT (RegistryT (KatipContextT IO)) LogEnv
forall (m :: * -> *). Katip m => m LogEnv
getLogEnv
  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 <- RegistryT (KatipContextT IO) Gauge
-> RidleyT (RegistryT (KatipContextT IO)) Gauge
forall (m :: * -> *) a. Monad m => m a -> RidleyT m a
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_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 -> Ridley RidleyMetricHandler
forall a. a -> RidleyT (RegistryT (KatipContextT IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (RidleyMetricHandler -> Ridley RidleyMetricHandler)
-> RidleyMetricHandler -> Ridley 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 (RidleyOptions -> LogEnv -> ProcessID -> Gauge -> Bool -> IO ()
updateOpenFD RidleyOptions
opts LogEnv
le ProcessID
pid) Bool
False