-----------------------------------------------------------------------------
-- |
-- Module      : System.Taffybar.Information.Network
-- Copyright   : (c) José A. Romero L.
-- License     : BSD3-style (see LICENSE)
--
-- Maintainer  : José A. Romero L. <escherdragon@gmail.com>
-- Stability   : unstable
-- Portability : unportable
--
-- Provides information about network traffic over selected interfaces,
-- obtained from parsing the @\/proc\/net\/dev@ file using some of the
-- facilities provided by the "System.Taffybar.Information.StreamInfo" module.
--
-----------------------------------------------------------------------------

module System.Taffybar.Information.Network where

import           Control.Applicative
import qualified Control.Concurrent.MVar as MV
import           Control.Exception (catch, SomeException)
import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Maybe (MaybeT(..))
import           Data.Maybe ( mapMaybe )
import           Data.Time.Clock
import           Data.Time.Clock.System
import           Safe ( atMay, initSafe, readDef )
import           System.Taffybar.Information.StreamInfo ( getParsedInfo )
import           System.Taffybar.Util

import           Prelude

networkInfoFile :: FilePath
networkInfoFile :: String
networkInfoFile = String
"/proc/net/dev"

-- | Returns a two-element list containing the current number of bytes received
-- and transmitted via the given network interface (e.g. \"wlan0\"), according
-- to the contents of the @\/proc\/dev\/net@ file.
getNetInfo :: String -> IO (Maybe [Int])
getNetInfo :: String -> IO (Maybe [Int])
getNetInfo String
iface = MaybeT IO [Int] -> IO (Maybe [Int])
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO [Int] -> IO (Maybe [Int]))
-> MaybeT IO [Int] -> IO (Maybe [Int])
forall a b. (a -> b) -> a -> b
$ do
  String -> MaybeT IO ()
isInterfaceUp String
iface
  IO [Int] -> MaybeT IO [Int]
forall a. IO a -> MaybeT IO a
handleFailure (IO [Int] -> MaybeT IO [Int]) -> IO [Int] -> MaybeT IO [Int]
forall a b. (a -> b) -> a -> b
$ String -> (String -> [(String, [Int])]) -> String -> IO [Int]
forall a. String -> (String -> [(String, [a])]) -> String -> IO [a]
getParsedInfo String
networkInfoFile String -> [(String, [Int])]
parseDevNet' String
iface

parseDevNet' :: String -> [(String, [Int])]
parseDevNet' :: String -> [(String, [Int])]
parseDevNet' String
input =
  ((String, (Int, Int)) -> (String, [Int]))
-> [(String, (Int, Int))] -> [(String, [Int])]
forall a b. (a -> b) -> [a] -> [b]
map (String, (Int, Int)) -> (String, [Int])
forall {a} {a}. (a, (a, a)) -> (a, [a])
makeList ([(String, (Int, Int))] -> [(String, [Int])])
-> [(String, (Int, Int))] -> [(String, [Int])]
forall a b. (a -> b) -> a -> b
$ String -> [(String, (Int, Int))]
parseDevNet String
input
  where makeList :: (a, (a, a)) -> (a, [a])
makeList (a
a, (a
u, a
d)) = (a
a, [a
u, a
d])

parseDevNet :: String -> [(String, (Int, Int))]
parseDevNet :: String -> [(String, (Int, Int))]
parseDevNet = (String -> Maybe (String, (Int, Int)))
-> [String] -> [(String, (Int, Int))]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([String] -> Maybe (String, (Int, Int))
getDeviceUpDown ([String] -> Maybe (String, (Int, Int)))
-> (String -> [String]) -> String -> Maybe (String, (Int, Int))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words) ([String] -> [(String, (Int, Int))])
-> (String -> [String]) -> String -> [(String, (Int, Int))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop Int
2 ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines

getDeviceUpDown :: [String] -> Maybe (String, (Int, Int))
getDeviceUpDown :: [String] -> Maybe (String, (Int, Int))
getDeviceUpDown [String]
s = do
  String
dev <- String -> String
forall a. [a] -> [a]
initSafe (String -> String) -> Maybe String -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
s [String] -> Int -> Maybe String
forall a. [a] -> Int -> Maybe a
`atMay` Int
0
  Int
down <- Int -> String -> Int
forall a. Read a => a -> String -> a
readDef (-Int
1) (String -> Int) -> Maybe String -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
s [String] -> Int -> Maybe String
forall a. [a] -> Int -> Maybe a
`atMay` Int
1
  Int
up <- Int -> String -> Int
forall a. Read a => a -> String -> a
readDef (-Int
1) (String -> Int) -> Maybe String -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
s [String] -> Int -> Maybe String
forall a. [a] -> Int -> Maybe a
`atMay` Int
out
  String
dev String -> Maybe (String, (Int, Int)) -> Maybe (String, (Int, Int))
forall a b. a -> b -> b
`seq` Int
down Int -> Maybe (String, (Int, Int)) -> Maybe (String, (Int, Int))
forall a b. a -> b -> b
`seq` Int
up Int -> Maybe (String, (Int, Int)) -> Maybe (String, (Int, Int))
forall a b. a -> b -> b
`seq` (String, (Int, Int)) -> Maybe (String, (Int, Int))
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
dev, (Int
down, Int
up))
  where
    out :: Int
out = [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
8

-- Nothing if interface does not exist or is down
isInterfaceUp :: String -> MaybeT IO ()
isInterfaceUp :: String -> MaybeT IO ()
isInterfaceUp String
iface = do
  String
state <- IO String -> MaybeT IO String
forall a. IO a -> MaybeT IO a
handleFailure (IO String -> MaybeT IO String) -> IO String -> MaybeT IO String
forall a b. (a -> b) -> a -> b
$ String -> IO String
readFile (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
"/sys/class/net/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
iface String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/operstate"
  case String
state of
    Char
'u' : String
_ -> () -> MaybeT IO ()
forall a. a -> MaybeT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    String
_ -> MaybeT IO ()
forall a. MaybeT IO a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

handleFailure :: IO a -> MaybeT IO a
handleFailure :: forall a. IO a -> MaybeT IO a
handleFailure IO a
action = IO (Maybe a) -> MaybeT IO a
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe a) -> MaybeT IO a) -> IO (Maybe a) -> MaybeT IO a
forall a b. (a -> b) -> a -> b
$ IO (Maybe a) -> (SomeException -> IO (Maybe a)) -> IO (Maybe a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> IO a -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
action) SomeException -> IO (Maybe a)
forall a. SomeException -> IO (Maybe a)
eToNothing
  where
    eToNothing :: SomeException -> IO (Maybe a)
    eToNothing :: forall a. SomeException -> IO (Maybe a)
eToNothing SomeException
_ = Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing

getDeviceSamples :: IO (Maybe [TxSample])
getDeviceSamples :: IO (Maybe [TxSample])
getDeviceSamples = MaybeT IO [TxSample] -> IO (Maybe [TxSample])
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO [TxSample] -> IO (Maybe [TxSample]))
-> MaybeT IO [TxSample] -> IO (Maybe [TxSample])
forall a b. (a -> b) -> a -> b
$ IO [TxSample] -> MaybeT IO [TxSample]
forall a. IO a -> MaybeT IO a
handleFailure (IO [TxSample] -> MaybeT IO [TxSample])
-> IO [TxSample] -> MaybeT IO [TxSample]
forall a b. (a -> b) -> a -> b
$ do
  String
contents <- String -> IO String
readFile String
networkInfoFile
  String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
contents Int -> IO () -> IO ()
forall a b. a -> b -> b
`seq` () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  SystemTime
time <- IO SystemTime -> IO SystemTime
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO SystemTime
getSystemTime
  let mkSample :: (String, (Int, Int)) -> TxSample
mkSample (String
device, (Int
up, Int
down)) =
          TxSample { sampleUp :: Int
sampleUp = Int
up
                   , sampleDown :: Int
sampleDown = Int
down
                   , sampleTime :: SystemTime
sampleTime = SystemTime
time
                   , sampleDevice :: String
sampleDevice = String
device
                   }
  [TxSample] -> IO [TxSample]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([TxSample] -> IO [TxSample]) -> [TxSample] -> IO [TxSample]
forall a b. (a -> b) -> a -> b
$ ((String, (Int, Int)) -> TxSample)
-> [(String, (Int, Int))] -> [TxSample]
forall a b. (a -> b) -> [a] -> [b]
map (String, (Int, Int)) -> TxSample
mkSample ([(String, (Int, Int))] -> [TxSample])
-> [(String, (Int, Int))] -> [TxSample]
forall a b. (a -> b) -> a -> b
$ String -> [(String, (Int, Int))]
parseDevNet String
contents

data TxSample = TxSample
  { TxSample -> Int
sampleUp :: Int
  , TxSample -> Int
sampleDown :: Int
  , TxSample -> SystemTime
sampleTime :: SystemTime
  , TxSample -> String
sampleDevice :: String
  } deriving (Int -> TxSample -> String -> String
[TxSample] -> String -> String
TxSample -> String
(Int -> TxSample -> String -> String)
-> (TxSample -> String)
-> ([TxSample] -> String -> String)
-> Show TxSample
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> TxSample -> String -> String
showsPrec :: Int -> TxSample -> String -> String
$cshow :: TxSample -> String
show :: TxSample -> String
$cshowList :: [TxSample] -> String -> String
showList :: [TxSample] -> String -> String
Show, TxSample -> TxSample -> Bool
(TxSample -> TxSample -> Bool)
-> (TxSample -> TxSample -> Bool) -> Eq TxSample
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TxSample -> TxSample -> Bool
== :: TxSample -> TxSample -> Bool
$c/= :: TxSample -> TxSample -> Bool
/= :: TxSample -> TxSample -> Bool
Eq)

monitorNetworkInterfaces
  :: RealFrac a1
  => a1 -> ([(String, (Rational, Rational))] -> IO ()) -> IO ()
monitorNetworkInterfaces :: forall a1.
RealFrac a1 =>
a1 -> ([(String, (Rational, Rational))] -> IO ()) -> IO ()
monitorNetworkInterfaces a1
interval [(String, (Rational, Rational))] -> IO ()
onUpdate = IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  MVar [(String, (TxSample, TxSample))]
samplesVar <- [(String, (TxSample, TxSample))]
-> IO (MVar [(String, (TxSample, TxSample))])
forall a. a -> IO (MVar a)
MV.newMVar []
  let sampleToSpeeds :: (a, (TxSample, TxSample)) -> (a, (Rational, Rational))
sampleToSpeeds (a
device, (TxSample
s1, TxSample
s2)) = (a
device, TxSample -> TxSample -> (Rational, Rational)
getSpeed TxSample
s1 TxSample
s2)
      doOnUpdate :: [(String, (TxSample, TxSample))]
-> IO [(String, (TxSample, TxSample))]
doOnUpdate [(String, (TxSample, TxSample))]
samples = do
        let speedInfo :: [(String, (Rational, Rational))]
speedInfo = ((String, (TxSample, TxSample)) -> (String, (Rational, Rational)))
-> [(String, (TxSample, TxSample))]
-> [(String, (Rational, Rational))]
forall a b. (a -> b) -> [a] -> [b]
map (String, (TxSample, TxSample)) -> (String, (Rational, Rational))
forall {a}. (a, (TxSample, TxSample)) -> (a, (Rational, Rational))
sampleToSpeeds [(String, (TxSample, TxSample))]
samples
        [(String, (Rational, Rational))] -> IO ()
onUpdate [(String, (Rational, Rational))]
speedInfo
        [(String, (TxSample, TxSample))]
-> IO [(String, (TxSample, TxSample))]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [(String, (TxSample, TxSample))]
samples
      doUpdate :: IO ()
doUpdate = MVar [(String, (TxSample, TxSample))]
-> ([(String, (TxSample, TxSample))]
    -> IO [(String, (TxSample, TxSample))])
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
MV.modifyMVar_ MVar [(String, (TxSample, TxSample))]
samplesVar ((IO [(String, (TxSample, TxSample))]
-> ([(String, (TxSample, TxSample))]
    -> IO [(String, (TxSample, TxSample))])
-> IO [(String, (TxSample, TxSample))]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [(String, (TxSample, TxSample))]
-> IO [(String, (TxSample, TxSample))]
doOnUpdate) (IO [(String, (TxSample, TxSample))]
 -> IO [(String, (TxSample, TxSample))])
-> ([(String, (TxSample, TxSample))]
    -> IO [(String, (TxSample, TxSample))])
-> [(String, (TxSample, TxSample))]
-> IO [(String, (TxSample, TxSample))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, (TxSample, TxSample))]
-> IO [(String, (TxSample, TxSample))]
updateSamples)
  a1 -> IO () -> IO ThreadId
forall (m :: * -> *) d.
(MonadIO m, RealFrac d) =>
d -> IO () -> m ThreadId
foreverWithDelay a1
interval IO ()
doUpdate

updateSamples ::
  [(String, (TxSample, TxSample))] ->
  IO [(String, (TxSample, TxSample))]
updateSamples :: [(String, (TxSample, TxSample))]
-> IO [(String, (TxSample, TxSample))]
updateSamples [(String, (TxSample, TxSample))]
currentSamples = do
  let getLast :: TxSample -> TxSample
getLast sample :: TxSample
sample@TxSample { sampleDevice :: TxSample -> String
sampleDevice = String
device } =
        TxSample
-> ((TxSample, TxSample) -> TxSample)
-> Maybe (TxSample, TxSample)
-> TxSample
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TxSample
sample (TxSample, TxSample) -> TxSample
forall a b. (a, b) -> a
fst (Maybe (TxSample, TxSample) -> TxSample)
-> Maybe (TxSample, TxSample) -> TxSample
forall a b. (a -> b) -> a -> b
$ String
-> [(String, (TxSample, TxSample))] -> Maybe (TxSample, TxSample)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
device [(String, (TxSample, TxSample))]
currentSamples
      getSamplePair :: TxSample -> (String, (TxSample, TxSample))
getSamplePair sample :: TxSample
sample@TxSample { sampleDevice :: TxSample -> String
sampleDevice = String
device } =
        let lastSample :: TxSample
lastSample = TxSample -> TxSample
getLast TxSample
sample
        in TxSample
lastSample TxSample
-> (String, (TxSample, TxSample)) -> (String, (TxSample, TxSample))
forall a b. a -> b -> b
`seq` (String
device, (TxSample
sample, TxSample
lastSample))
  [(String, (TxSample, TxSample))]
-> ([TxSample] -> [(String, (TxSample, TxSample))])
-> Maybe [TxSample]
-> [(String, (TxSample, TxSample))]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [(String, (TxSample, TxSample))]
currentSamples ((TxSample -> (String, (TxSample, TxSample)))
-> [TxSample] -> [(String, (TxSample, TxSample))]
forall a b. (a -> b) -> [a] -> [b]
map TxSample -> (String, (TxSample, TxSample))
getSamplePair) (Maybe [TxSample] -> [(String, (TxSample, TxSample))])
-> IO (Maybe [TxSample]) -> IO [(String, (TxSample, TxSample))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe [TxSample])
getDeviceSamples

getSpeed :: TxSample -> TxSample -> (Rational, Rational)
getSpeed :: TxSample -> TxSample -> (Rational, Rational)
getSpeed TxSample { sampleUp :: TxSample -> Int
sampleUp = Int
thisUp
                  , sampleDown :: TxSample -> Int
sampleDown = Int
thisDown
                  , sampleTime :: TxSample -> SystemTime
sampleTime = SystemTime
thisTime
                  }
         TxSample { sampleUp :: TxSample -> Int
sampleUp = Int
lastUp
                  , sampleDown :: TxSample -> Int
sampleDown = Int
lastDown
                  , sampleTime :: TxSample -> SystemTime
sampleTime = SystemTime
lastTime
                  } =
        let intervalDiffTime :: NominalDiffTime
intervalDiffTime =
              UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime
              (SystemTime -> UTCTime
systemToUTCTime SystemTime
thisTime)
              (SystemTime -> UTCTime
systemToUTCTime SystemTime
lastTime)
            intervalRatio :: Rational
intervalRatio =
              if NominalDiffTime
intervalDiffTime NominalDiffTime -> NominalDiffTime -> Bool
forall a. Eq a => a -> a -> Bool
== NominalDiffTime
0
              then Rational
0
              else NominalDiffTime -> Rational
forall a. Real a => a -> Rational
toRational (NominalDiffTime -> Rational) -> NominalDiffTime -> Rational
forall a b. (a -> b) -> a -> b
$ NominalDiffTime
1 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Fractional a => a -> a -> a
/ NominalDiffTime
intervalDiffTime
        in ( Int -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
thisDown Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
lastDown) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
intervalRatio
           , Int -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
thisUp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
lastUp) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
intervalRatio
           )

sumSpeeds :: [(Rational, Rational)] -> (Rational, Rational)
sumSpeeds :: [(Rational, Rational)] -> (Rational, Rational)
sumSpeeds = ((Rational, Rational)
 -> (Rational, Rational) -> (Rational, Rational))
-> [(Rational, Rational)] -> (Rational, Rational)
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (Rational, Rational)
-> (Rational, Rational) -> (Rational, Rational)
forall {a} {b}. (Num a, Num b) => (a, b) -> (a, b) -> (a, b)
sumOne
  where
    sumOne :: (a, b) -> (a, b) -> (a, b)
sumOne (a
d1, b
u1) (a
d2, b
u2) = (a
d1 a -> a -> a
forall a. Num a => a -> a -> a
+ a
d2, b
u1 b -> b -> b
forall a. Num a => a -> a -> a
+ b
u2)