{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
module System.Metrics.Prometheus.Ridley.Metrics.PhysicalMemory where

import           Control.Monad.IO.Class
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)

{- 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 :: IO FreeReport
getFreeStats = do
  [Word64]
rawOutput <- Sh [Word64] -> IO [Word64]
forall (m :: * -> *) a. MonadIO m => Sh a -> m a
shelly (Sh [Word64] -> IO [Word64]) -> Sh [Word64] -> IO [Word64]
forall a b. (a -> b) -> a -> b
$ Sh [Word64] -> Sh [Word64]
forall a. Sh a -> Sh a
silently (Sh [Word64] -> Sh [Word64]) -> Sh [Word64] -> Sh [Word64]
forall a b. (a -> b) -> a -> b
$ Bool -> Sh [Word64] -> Sh [Word64]
forall a. Bool -> Sh a -> Sh a
escaping Bool
False (Sh [Word64] -> Sh [Word64]) -> Sh [Word64] -> Sh [Word64]
forall a b. (a -> b) -> a -> b
$
    (Text -> Maybe Word64) -> [Text] -> [Word64]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Read Word64 => String -> Maybe Word64
forall a. Read a => String -> Maybe a
readMaybe @Word64 (String -> Maybe Word64)
-> (Text -> String) -> Text -> Maybe Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) ([Text] -> [Word64]) -> (Text -> [Text]) -> Text -> [Word64]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.words (Text -> [Text]) -> (Text -> Text) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip (Text -> [Word64]) -> Sh Text -> Sh [Word64]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [Text] -> Sh Text
run String
"free" [Text
"-m" ,Text
"|" , Text
"tail", Text
"-n", Text
"-2" , Text
"|", Text
"awk", Text
"-F", Text
"\" \"", Text
"'{printf \"%s %s %s %s %s %s %s\", $2, $3, $4, $5, $6, $7, $8}'"]
  case [Word64]
rawOutput of
    [   Word64
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
      ] -> FreeReport -> IO FreeReport
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FreeReport -> IO FreeReport) -> FreeReport -> IO FreeReport
forall a b. (a -> b) -> a -> b
$ FreeReport :: Word64
-> Word64
-> Word64
-> Word64
-> Word64
-> Word64
-> Word64
-> Word64
-> Word64
-> FreeReport
FreeReport{Word64
free_swap_free_mb :: Word64
free_swap_used_mb :: Word64
free_swap_total_mb :: Word64
free_mem_available_mb :: Word64
free_mem_buff_cache_mb :: Word64
free_mem_shared_mb :: Word64
free_mem_free_mb :: Word64
free_mem_used_mb :: Word64
free_mem_total_mb :: Word64
free_swap_free_mb :: Word64
free_swap_used_mb :: Word64
free_swap_total_mb :: Word64
free_mem_available_mb :: Word64
free_mem_buff_cache_mb :: Word64
free_mem_shared_mb :: Word64
free_mem_free_mb :: Word64
free_mem_used_mb :: Word64
free_mem_total_mb :: Word64
..}
    [Word64]
_ -> FreeReport -> IO FreeReport
forall (f :: * -> *) a. Applicative f => a -> f a
pure FreeReport
emptyFreeReport

--------------------------------------------------------------------------------
updateFreeStats :: FreeGauges -> Bool -> IO ()
updateFreeStats :: FreeGauges -> Bool -> IO ()
updateFreeStats FreeGauges{Gauge
free_swap_free_mb_g :: FreeGauges -> Gauge
free_swap_used_mb_g :: FreeGauges -> Gauge
free_swap_total_mb_g :: FreeGauges -> Gauge
free_mem_available_mb_g :: FreeGauges -> Gauge
free_mem_buff_cache_mb_g :: FreeGauges -> Gauge
free_mem_shared_mb_g :: FreeGauges -> Gauge
free_mem_free_mb_g :: FreeGauges -> Gauge
free_mem_used_mb_g :: FreeGauges -> Gauge
free_mem_total_mb_g :: FreeGauges -> Gauge
free_swap_free_mb_g :: Gauge
free_swap_used_mb_g :: Gauge
free_swap_total_mb_g :: Gauge
free_mem_available_mb_g :: Gauge
free_mem_buff_cache_mb_g :: Gauge
free_mem_shared_mb_g :: Gauge
free_mem_free_mb_g :: Gauge
free_mem_used_mb_g :: Gauge
free_mem_total_mb_g :: Gauge
..} Bool
_ = do
#ifdef darwin_HOST_OS
  let FreeReport{..} = emptyFreeReport-- "free" is not available on Darwin.
#else
  FreeReport{Word64
free_swap_free_mb :: Word64
free_swap_used_mb :: Word64
free_swap_total_mb :: Word64
free_mem_available_mb :: Word64
free_mem_buff_cache_mb :: Word64
free_mem_shared_mb :: Word64
free_mem_free_mb :: Word64
free_mem_used_mb :: Word64
free_mem_total_mb :: Word64
free_swap_free_mb :: FreeReport -> Word64
free_swap_used_mb :: FreeReport -> Word64
free_swap_total_mb :: FreeReport -> Word64
free_mem_available_mb :: FreeReport -> Word64
free_mem_buff_cache_mb :: FreeReport -> Word64
free_mem_shared_mb :: FreeReport -> Word64
free_mem_free_mb :: FreeReport -> Word64
free_mem_used_mb :: FreeReport -> Word64
free_mem_total_mb :: FreeReport -> Word64
..} <- IO FreeReport
getFreeStats
#endif
  Double -> Gauge -> IO ()
P.set (Word64 -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac Word64
free_mem_total_mb      ) Gauge
free_mem_total_mb_g
  Double -> Gauge -> IO ()
P.set (Word64 -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac Word64
free_mem_used_mb       ) Gauge
free_mem_used_mb_g
  Double -> Gauge -> IO ()
P.set (Word64 -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac Word64
free_mem_free_mb       ) Gauge
free_mem_free_mb_g
  Double -> Gauge -> IO ()
P.set (Word64 -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac Word64
free_mem_shared_mb     ) Gauge
free_mem_shared_mb_g
  Double -> Gauge -> IO ()
P.set (Word64 -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac Word64
free_mem_buff_cache_mb ) Gauge
free_mem_buff_cache_mb_g
  Double -> Gauge -> IO ()
P.set (Word64 -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac Word64
free_mem_available_mb  ) Gauge
free_mem_available_mb_g
  Double -> Gauge -> IO ()
P.set (Word64 -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac Word64
free_swap_total_mb     ) Gauge
free_swap_total_mb_g
  Double -> Gauge -> IO ()
P.set (Word64 -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac Word64
free_swap_used_mb      ) Gauge
free_swap_used_mb_g
  Double -> Gauge -> IO ()
P.set (Word64 -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac Word64
free_swap_free_mb      ) Gauge
free_swap_free_mb_g

data FreeReport =
  FreeReport {
    FreeReport -> Word64
free_mem_total_mb      :: !Word64
  , FreeReport -> Word64
free_mem_used_mb       :: !Word64
  , FreeReport -> Word64
free_mem_free_mb       :: !Word64
  , FreeReport -> Word64
free_mem_shared_mb     :: !Word64
  , FreeReport -> Word64
free_mem_buff_cache_mb :: !Word64
  , FreeReport -> Word64
free_mem_available_mb  :: !Word64
  , FreeReport -> Word64
free_swap_total_mb     :: !Word64
  , FreeReport -> Word64
free_swap_used_mb      :: !Word64
  , FreeReport -> Word64
free_swap_free_mb      :: !Word64
  } deriving (Int -> FreeReport -> ShowS
[FreeReport] -> ShowS
FreeReport -> String
(Int -> FreeReport -> ShowS)
-> (FreeReport -> String)
-> ([FreeReport] -> ShowS)
-> Show FreeReport
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FreeReport] -> ShowS
$cshowList :: [FreeReport] -> ShowS
show :: FreeReport -> String
$cshow :: FreeReport -> String
showsPrec :: Int -> FreeReport -> ShowS
$cshowsPrec :: Int -> FreeReport -> ShowS
Show, FreeReport -> FreeReport -> Bool
(FreeReport -> FreeReport -> Bool)
-> (FreeReport -> FreeReport -> Bool) -> Eq FreeReport
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FreeReport -> FreeReport -> Bool
$c/= :: FreeReport -> FreeReport -> Bool
== :: FreeReport -> FreeReport -> Bool
$c== :: FreeReport -> FreeReport -> Bool
Eq)

emptyFreeReport :: FreeReport
emptyFreeReport :: FreeReport
emptyFreeReport = FreeReport :: Word64
-> Word64
-> Word64
-> Word64
-> Word64
-> Word64
-> Word64
-> Word64
-> Word64
-> FreeReport
FreeReport
  { free_mem_total_mb :: Word64
free_mem_total_mb      = Word64
0
  , free_mem_used_mb :: Word64
free_mem_used_mb       = Word64
0
  , free_mem_free_mb :: Word64
free_mem_free_mb       = Word64
0
  , free_mem_shared_mb :: Word64
free_mem_shared_mb     = Word64
0
  , free_mem_buff_cache_mb :: Word64
free_mem_buff_cache_mb = Word64
0
  , free_mem_available_mb :: Word64
free_mem_available_mb  = Word64
0
  , free_swap_total_mb :: Word64
free_swap_total_mb     = Word64
0
  , free_swap_used_mb :: Word64
free_swap_used_mb      = Word64
0
  , free_swap_free_mb :: Word64
free_swap_free_mb      = Word64
0
  }


data FreeGauges =
  FreeGauges {
    FreeGauges -> Gauge
free_mem_total_mb_g      :: !P.Gauge
  , FreeGauges -> Gauge
free_mem_used_mb_g       :: !P.Gauge
  , FreeGauges -> Gauge
free_mem_free_mb_g       :: !P.Gauge
  , FreeGauges -> Gauge
free_mem_shared_mb_g     :: !P.Gauge
  , FreeGauges -> Gauge
free_mem_buff_cache_mb_g :: !P.Gauge
  , FreeGauges -> Gauge
free_mem_available_mb_g  :: !P.Gauge
  , FreeGauges -> Gauge
free_swap_total_mb_g     :: !P.Gauge
  , FreeGauges -> Gauge
free_swap_used_mb_g      :: !P.Gauge
  , FreeGauges -> Gauge
free_swap_free_mb_g      :: !P.Gauge
  }

--------------------------------------------------------------------------------
-- | Returns the physical memory total and free as sampled from 'free'.
systemPhysicalMemory :: MonadIO m
                     => RidleyOptions
                     -> P.RegistryT m RidleyMetricHandler
systemPhysicalMemory :: RidleyOptions -> RegistryT m RidleyMetricHandler
systemPhysicalMemory 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
  FreeGauges
gauges <- Gauge
-> Gauge
-> Gauge
-> Gauge
-> Gauge
-> Gauge
-> Gauge
-> Gauge
-> Gauge
-> FreeGauges
FreeGauges (Gauge
 -> Gauge
 -> Gauge
 -> Gauge
 -> Gauge
 -> Gauge
 -> Gauge
 -> Gauge
 -> Gauge
 -> FreeGauges)
-> RegistryT m Gauge
-> RegistryT
     m
     (Gauge
      -> Gauge
      -> Gauge
      -> Gauge
      -> Gauge
      -> Gauge
      -> Gauge
      -> Gauge
      -> FreeGauges)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Labels -> RegistryT m Gauge
forall (m :: * -> *).
MonadIO m =>
Name -> Labels -> RegistryT m Gauge
P.registerGauge Name
"free_mem_total_mb" (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)
                       RegistryT
  m
  (Gauge
   -> Gauge
   -> Gauge
   -> Gauge
   -> Gauge
   -> Gauge
   -> Gauge
   -> Gauge
   -> FreeGauges)
-> RegistryT m Gauge
-> RegistryT
     m
     (Gauge
      -> Gauge
      -> Gauge
      -> Gauge
      -> Gauge
      -> Gauge
      -> Gauge
      -> FreeGauges)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> Labels -> RegistryT m Gauge
forall (m :: * -> *).
MonadIO m =>
Name -> Labels -> RegistryT m Gauge
P.registerGauge Name
"free_mem_used_mb" (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)
                       RegistryT
  m
  (Gauge
   -> Gauge
   -> Gauge
   -> Gauge
   -> Gauge
   -> Gauge
   -> Gauge
   -> FreeGauges)
-> RegistryT m Gauge
-> RegistryT
     m
     (Gauge -> Gauge -> Gauge -> Gauge -> Gauge -> Gauge -> FreeGauges)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> Labels -> RegistryT m Gauge
forall (m :: * -> *).
MonadIO m =>
Name -> Labels -> RegistryT m Gauge
P.registerGauge Name
"free_mem_free_mb" (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)
                       RegistryT
  m
  (Gauge -> Gauge -> Gauge -> Gauge -> Gauge -> Gauge -> FreeGauges)
-> RegistryT m Gauge
-> RegistryT
     m (Gauge -> Gauge -> Gauge -> Gauge -> Gauge -> FreeGauges)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> Labels -> RegistryT m Gauge
forall (m :: * -> *).
MonadIO m =>
Name -> Labels -> RegistryT m Gauge
P.registerGauge Name
"free_mem_shared_mb" (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)
                       RegistryT
  m (Gauge -> Gauge -> Gauge -> Gauge -> Gauge -> FreeGauges)
-> RegistryT m Gauge
-> RegistryT m (Gauge -> Gauge -> Gauge -> Gauge -> FreeGauges)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> Labels -> RegistryT m Gauge
forall (m :: * -> *).
MonadIO m =>
Name -> Labels -> RegistryT m Gauge
P.registerGauge Name
"free_mem_buff_cache_mb" (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)
                       RegistryT m (Gauge -> Gauge -> Gauge -> Gauge -> FreeGauges)
-> RegistryT m Gauge
-> RegistryT m (Gauge -> Gauge -> Gauge -> FreeGauges)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> Labels -> RegistryT m Gauge
forall (m :: * -> *).
MonadIO m =>
Name -> Labels -> RegistryT m Gauge
P.registerGauge Name
"free_mem_available_mb" (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)
                       RegistryT m (Gauge -> Gauge -> Gauge -> FreeGauges)
-> RegistryT m Gauge -> RegistryT m (Gauge -> Gauge -> FreeGauges)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> Labels -> RegistryT m Gauge
forall (m :: * -> *).
MonadIO m =>
Name -> Labels -> RegistryT m Gauge
P.registerGauge Name
"free_swap_total_mb" (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)
                       RegistryT m (Gauge -> Gauge -> FreeGauges)
-> RegistryT m Gauge -> RegistryT m (Gauge -> FreeGauges)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> Labels -> RegistryT m Gauge
forall (m :: * -> *).
MonadIO m =>
Name -> Labels -> RegistryT m Gauge
P.registerGauge Name
"free_swap_used_mb" (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)
                       RegistryT m (Gauge -> FreeGauges)
-> RegistryT m Gauge -> RegistryT m FreeGauges
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> Labels -> RegistryT m Gauge
forall (m :: * -> *).
MonadIO m =>
Name -> Labels -> RegistryT m Gauge
P.registerGauge Name
"free_swap_free_mb" (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
-> FreeGauges
-> (FreeGauges -> Bool -> IO ())
-> Bool
-> RidleyMetricHandler
forall c.
HasCallStack =>
Text -> c -> (c -> Bool -> IO ()) -> Bool -> RidleyMetricHandler
mkRidleyMetricHandler Text
"ridley-physical-memory-statistics" FreeGauges
gauges FreeGauges -> Bool -> IO ()
updateFreeStats Bool
False