{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module System.Metrics.Prometheus.Ridley.Metrics.Network.Unix
  ( networkMetrics
  , getNetworkMetrics
  , mkInterfaceGauge
  ) where

import           Control.Monad
import           Control.Monad.IO.Class
import qualified Data.Map.Strict as M
import           Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.IO as T
import           Prelude hiding (FilePath)
import qualified System.Metrics.Prometheus.Metric.Gauge as P
import qualified System.Metrics.Prometheus.MetricId as P
import qualified System.Metrics.Prometheus.RegistryT as P
import           System.Metrics.Prometheus.Ridley.Metrics.Network.Types
import           System.Metrics.Prometheus.Ridley.Types

--------------------------------------------------------------------------------
-- | Parse /proc/net/dev to get the relevant stats.
getNetworkMetrics :: IO [IfData]
getNetworkMetrics :: IO [IfData]
getNetworkMetrics = do
  [Text]
interfaces <- Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop Int
2 ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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]) -> IO Text -> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Text
T.readFile FilePath
"/proc/net/dev"
  [IfData] -> IO [IfData]
forall (m :: * -> *) a. Monad m => a -> m a
return ([IfData] -> IO [IfData]) -> [IfData] -> IO [IfData]
forall a b. (a -> b) -> a -> b
$! (Text -> Maybe IfData) -> [Text] -> [IfData]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe IfData
mkInterface [Text]
interfaces
  where
    mkInterface :: T.Text -> Maybe IfData
    mkInterface :: Text -> Maybe IfData
mkInterface Text
rawLine = case 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 -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Text
rawLine of
      [Text
iface, Text
ibytes, Text
ipackets, Text
ierrs, Text
idrop, Text
_, Text
_, Text
_, Text
imulticast, Text
obytes, Text
opackets, Text
oerrs, Text
_, Text
_, Text
_, Text
_, Text
_] ->
        IfData -> Maybe IfData
forall a. a -> Maybe a
Just (IfData -> Maybe IfData) -> IfData -> Maybe IfData
forall a b. (a -> b) -> a -> b
$ IfData :: Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> FilePath
-> Int
-> IfData
IfData {
            ifi_ipackets :: Int
ifi_ipackets = FilePath -> Int
forall a. Read a => FilePath -> a
read (FilePath -> Int) -> FilePath -> Int
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
ipackets
          , ifi_opackets :: Int
ifi_opackets = FilePath -> Int
forall a. Read a => FilePath -> a
read (FilePath -> Int) -> FilePath -> Int
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
opackets
          , ifi_ierrors :: Int
ifi_ierrors  = FilePath -> Int
forall a. Read a => FilePath -> a
read (FilePath -> Int) -> FilePath -> Int
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
ierrs
          , ifi_oerrors :: Int
ifi_oerrors  = FilePath -> Int
forall a. Read a => FilePath -> a
read (FilePath -> Int) -> FilePath -> Int
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
oerrs
          , ifi_ibytes :: Int
ifi_ibytes   = FilePath -> Int
forall a. Read a => FilePath -> a
read (FilePath -> Int) -> FilePath -> Int
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
ibytes
          , ifi_obytes :: Int
ifi_obytes   = FilePath -> Int
forall a. Read a => FilePath -> a
read (FilePath -> Int) -> FilePath -> Int
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
obytes
          , ifi_imcasts :: Int
ifi_imcasts  = FilePath -> Int
forall a. Read a => FilePath -> a
read (FilePath -> Int) -> FilePath -> Int
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
imulticast
          , ifi_omcasts :: Int
ifi_omcasts  = Int
0
          , ifi_iqdrops :: Int
ifi_iqdrops  = FilePath -> Int
forall a. Read a => FilePath -> a
read (FilePath -> Int) -> FilePath -> Int
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
idrop
          , ifi_name :: FilePath
ifi_name     = Text -> FilePath
T.unpack (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.init Text
iface
          , ifi_error :: Int
ifi_error    = Int
0
          }
      [Text]
_  -> Maybe IfData
forall a. Maybe a
Nothing

--------------------------------------------------------------------------------
updateNetworkMetric :: NetworkMetric -> IfData -> Bool -> IO ()
updateNetworkMetric :: NetworkMetric -> IfData -> Bool -> IO ()
updateNetworkMetric NetworkMetric{Gauge
receive_drop :: NetworkMetric -> Gauge
transmit_multicast :: NetworkMetric -> Gauge
receive_multicast :: NetworkMetric -> Gauge
transmit_bytes :: NetworkMetric -> Gauge
receive_bytes :: NetworkMetric -> Gauge
transmit_errs :: NetworkMetric -> Gauge
receive_errs :: NetworkMetric -> Gauge
transmit_packets :: NetworkMetric -> Gauge
receive_packets :: NetworkMetric -> Gauge
receive_drop :: Gauge
transmit_multicast :: Gauge
receive_multicast :: Gauge
transmit_bytes :: Gauge
receive_bytes :: Gauge
transmit_errs :: Gauge
receive_errs :: Gauge
transmit_packets :: Gauge
receive_packets :: Gauge
..} IfData{Int
FilePath
ifi_error :: Int
ifi_name :: FilePath
ifi_iqdrops :: Int
ifi_omcasts :: Int
ifi_imcasts :: Int
ifi_obytes :: Int
ifi_ibytes :: Int
ifi_oerrors :: Int
ifi_ierrors :: Int
ifi_opackets :: Int
ifi_ipackets :: Int
ifi_error :: IfData -> Int
ifi_name :: IfData -> FilePath
ifi_iqdrops :: IfData -> Int
ifi_omcasts :: IfData -> Int
ifi_imcasts :: IfData -> Int
ifi_obytes :: IfData -> Int
ifi_ibytes :: IfData -> Int
ifi_oerrors :: IfData -> Int
ifi_ierrors :: IfData -> Int
ifi_opackets :: IfData -> Int
ifi_ipackets :: IfData -> Int
..} Bool
_ = do
  Double -> Gauge -> IO ()
P.set (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ifi_ipackets) Gauge
receive_packets
  Double -> Gauge -> IO ()
P.set (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ifi_opackets) Gauge
transmit_packets
  Double -> Gauge -> IO ()
P.set (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ifi_ierrors) Gauge
receive_errs
  Double -> Gauge -> IO ()
P.set (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ifi_oerrors) Gauge
transmit_errs
  Double -> Gauge -> IO ()
P.set (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ifi_ibytes) Gauge
receive_bytes
  Double -> Gauge -> IO ()
P.set (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ifi_obytes) Gauge
transmit_bytes
  Double -> Gauge -> IO ()
P.set (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ifi_imcasts) Gauge
receive_multicast
  Double -> Gauge -> IO ()
P.set (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ifi_omcasts) Gauge
transmit_multicast
  Double -> Gauge -> IO ()
P.set (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ifi_iqdrops) Gauge
receive_drop

--------------------------------------------------------------------------------
updateNetworkMetrics :: NetworkMetrics -> Bool -> IO ()
updateNetworkMetrics :: NetworkMetrics -> Bool -> IO ()
updateNetworkMetrics NetworkMetrics
nmetrics Bool
mustFlush = do
  [IfData]
ifaces <- IO [IfData]
getNetworkMetrics
  [IfData] -> (IfData -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [IfData]
ifaces ((IfData -> IO ()) -> IO ()) -> (IfData -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \d :: IfData
d@IfData{Int
FilePath
ifi_error :: Int
ifi_name :: FilePath
ifi_iqdrops :: Int
ifi_omcasts :: Int
ifi_imcasts :: Int
ifi_obytes :: Int
ifi_ibytes :: Int
ifi_oerrors :: Int
ifi_ierrors :: Int
ifi_opackets :: Int
ifi_ipackets :: Int
ifi_error :: IfData -> Int
ifi_name :: IfData -> FilePath
ifi_iqdrops :: IfData -> Int
ifi_omcasts :: IfData -> Int
ifi_imcasts :: IfData -> Int
ifi_obytes :: IfData -> Int
ifi_ibytes :: IfData -> Int
ifi_oerrors :: IfData -> Int
ifi_ierrors :: IfData -> Int
ifi_opackets :: IfData -> Int
ifi_ipackets :: IfData -> Int
..} -> do
    let key :: Text
key = FilePath -> Text
T.pack FilePath
ifi_name
    case Text -> NetworkMetrics -> Maybe NetworkMetric
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
key NetworkMetrics
nmetrics of
      Maybe NetworkMetric
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just NetworkMetric
m  -> NetworkMetric -> IfData -> Bool -> IO ()
updateNetworkMetric NetworkMetric
m IfData
d Bool
mustFlush

--------------------------------------------------------------------------------
networkMetrics :: NetworkMetrics -> RidleyMetricHandler
networkMetrics :: NetworkMetrics -> RidleyMetricHandler
networkMetrics NetworkMetrics
g = Text
-> NetworkMetrics
-> (NetworkMetrics -> Bool -> IO ())
-> Bool
-> RidleyMetricHandler
forall c.
HasCallStack =>
Text -> c -> (c -> Bool -> IO ()) -> Bool -> RidleyMetricHandler
mkRidleyMetricHandler Text
"ridley-network-metrics" NetworkMetrics
g NetworkMetrics -> Bool -> IO ()
updateNetworkMetrics Bool
False

--------------------------------------------------------------------------------
mkInterfaceGauge :: MonadIO m => P.Labels -> NetworkMetrics -> IfData -> P.RegistryT m NetworkMetrics
mkInterfaceGauge :: Labels -> NetworkMetrics -> IfData -> RegistryT m NetworkMetrics
mkInterfaceGauge Labels
currentLabels NetworkMetrics
imap d :: IfData
d@IfData{Int
FilePath
ifi_error :: Int
ifi_name :: FilePath
ifi_iqdrops :: Int
ifi_omcasts :: Int
ifi_imcasts :: Int
ifi_obytes :: Int
ifi_ibytes :: Int
ifi_oerrors :: Int
ifi_ierrors :: Int
ifi_opackets :: Int
ifi_ipackets :: Int
ifi_error :: IfData -> Int
ifi_name :: IfData -> FilePath
ifi_iqdrops :: IfData -> Int
ifi_omcasts :: IfData -> Int
ifi_imcasts :: IfData -> Int
ifi_obytes :: IfData -> Int
ifi_ibytes :: IfData -> Int
ifi_oerrors :: IfData -> Int
ifi_ierrors :: IfData -> Int
ifi_opackets :: IfData -> Int
ifi_ipackets :: IfData -> Int
..} = do
  let iname :: Text
iname = FilePath -> Text
T.pack FilePath
ifi_name
  let finalLabels :: Labels
finalLabels = Text -> Text -> Labels -> Labels
P.addLabel Text
"interface" Text
iname Labels
currentLabels
  NetworkMetric
metric <- Gauge
-> Gauge
-> Gauge
-> Gauge
-> Gauge
-> Gauge
-> Gauge
-> Gauge
-> Gauge
-> NetworkMetric
NetworkMetric (Gauge
 -> Gauge
 -> Gauge
 -> Gauge
 -> Gauge
 -> Gauge
 -> Gauge
 -> Gauge
 -> Gauge
 -> NetworkMetric)
-> RegistryT m Gauge
-> RegistryT
     m
     (Gauge
      -> Gauge
      -> Gauge
      -> Gauge
      -> Gauge
      -> Gauge
      -> Gauge
      -> Gauge
      -> NetworkMetric)
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
"network_receive_packets"    Labels
finalLabels
                          RegistryT
  m
  (Gauge
   -> Gauge
   -> Gauge
   -> Gauge
   -> Gauge
   -> Gauge
   -> Gauge
   -> Gauge
   -> NetworkMetric)
-> RegistryT m Gauge
-> RegistryT
     m
     (Gauge
      -> Gauge
      -> Gauge
      -> Gauge
      -> Gauge
      -> Gauge
      -> Gauge
      -> NetworkMetric)
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
"network_transmit_packets"   Labels
finalLabels
                          RegistryT
  m
  (Gauge
   -> Gauge
   -> Gauge
   -> Gauge
   -> Gauge
   -> Gauge
   -> Gauge
   -> NetworkMetric)
-> RegistryT m Gauge
-> RegistryT
     m
     (Gauge
      -> Gauge -> Gauge -> Gauge -> Gauge -> Gauge -> NetworkMetric)
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
"network_receive_errs"       Labels
finalLabels
                          RegistryT
  m
  (Gauge
   -> Gauge -> Gauge -> Gauge -> Gauge -> Gauge -> NetworkMetric)
-> RegistryT m Gauge
-> RegistryT
     m (Gauge -> Gauge -> Gauge -> Gauge -> Gauge -> NetworkMetric)
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
"network_transmit_errs"      Labels
finalLabels
                          RegistryT
  m (Gauge -> Gauge -> Gauge -> Gauge -> Gauge -> NetworkMetric)
-> RegistryT m Gauge
-> RegistryT m (Gauge -> Gauge -> Gauge -> Gauge -> NetworkMetric)
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
"network_receive_bytes"      Labels
finalLabels
                          RegistryT m (Gauge -> Gauge -> Gauge -> Gauge -> NetworkMetric)
-> RegistryT m Gauge
-> RegistryT m (Gauge -> Gauge -> Gauge -> NetworkMetric)
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
"network_transmit_bytes"     Labels
finalLabels
                          RegistryT m (Gauge -> Gauge -> Gauge -> NetworkMetric)
-> RegistryT m Gauge
-> RegistryT m (Gauge -> Gauge -> NetworkMetric)
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
"network_receive_multicast"  Labels
finalLabels
                          RegistryT m (Gauge -> Gauge -> NetworkMetric)
-> RegistryT m Gauge -> RegistryT m (Gauge -> NetworkMetric)
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
"network_transmit_multicast" Labels
finalLabels
                          RegistryT m (Gauge -> NetworkMetric)
-> RegistryT m Gauge -> RegistryT m NetworkMetric
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
"network_receive_drop"       Labels
finalLabels
  IO () -> RegistryT m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RegistryT m ()) -> IO () -> RegistryT m ()
forall a b. (a -> b) -> a -> b
$ NetworkMetric -> IfData -> Bool -> IO ()
updateNetworkMetric NetworkMetric
metric IfData
d Bool
False
  NetworkMetrics -> RegistryT m NetworkMetrics
forall (m :: * -> *) a. Monad m => a -> m a
return (NetworkMetrics -> RegistryT m NetworkMetrics)
-> NetworkMetrics -> RegistryT m NetworkMetrics
forall a b. (a -> b) -> a -> b
$! Text -> NetworkMetric -> NetworkMetrics -> NetworkMetrics
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
iname NetworkMetric
metric (NetworkMetrics -> NetworkMetrics)
-> NetworkMetrics -> NetworkMetrics
forall a b. (a -> b) -> a -> b
$! NetworkMetrics
imap