-----------------------------------------------------------------------------
-- |
-- 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 :: FilePath
networkInfoFile = FilePath
"/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 :: FilePath -> IO (Maybe [Int])
getNetInfo FilePath
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
  FilePath -> MaybeT IO ()
isInterfaceUp FilePath
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
$ FilePath
-> (FilePath -> [(FilePath, [Int])]) -> FilePath -> IO [Int]
forall a.
FilePath -> (FilePath -> [(FilePath, [a])]) -> FilePath -> IO [a]
getParsedInfo FilePath
networkInfoFile FilePath -> [(FilePath, [Int])]
parseDevNet' FilePath
iface

parseDevNet' :: String -> [(String, [Int])]
parseDevNet' :: FilePath -> [(FilePath, [Int])]
parseDevNet' FilePath
input =
  ((FilePath, (Int, Int)) -> (FilePath, [Int]))
-> [(FilePath, (Int, Int))] -> [(FilePath, [Int])]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, (Int, Int)) -> (FilePath, [Int])
forall a a. (a, (a, a)) -> (a, [a])
makeList ([(FilePath, (Int, Int))] -> [(FilePath, [Int])])
-> [(FilePath, (Int, Int))] -> [(FilePath, [Int])]
forall a b. (a -> b) -> a -> b
$ FilePath -> [(FilePath, (Int, Int))]
parseDevNet FilePath
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 :: FilePath -> [(FilePath, (Int, Int))]
parseDevNet = (FilePath -> Maybe (FilePath, (Int, Int)))
-> [FilePath] -> [(FilePath, (Int, Int))]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([FilePath] -> Maybe (FilePath, (Int, Int))
getDeviceUpDown ([FilePath] -> Maybe (FilePath, (Int, Int)))
-> (FilePath -> [FilePath])
-> FilePath
-> Maybe (FilePath, (Int, Int))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
words) ([FilePath] -> [(FilePath, (Int, Int))])
-> (FilePath -> [FilePath]) -> FilePath -> [(FilePath, (Int, Int))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [FilePath] -> [FilePath]
forall a. Int -> [a] -> [a]
drop Int
2 ([FilePath] -> [FilePath])
-> (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
lines

getDeviceUpDown :: [String] -> Maybe (String, (Int, Int))
getDeviceUpDown :: [FilePath] -> Maybe (FilePath, (Int, Int))
getDeviceUpDown [FilePath]
s = do
  FilePath
dev <- FilePath -> FilePath
forall a. [a] -> [a]
initSafe (FilePath -> FilePath) -> Maybe FilePath -> Maybe FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FilePath]
s [FilePath] -> Int -> Maybe FilePath
forall a. [a] -> Int -> Maybe a
`atMay` Int
0
  Int
down <- Int -> FilePath -> Int
forall a. Read a => a -> FilePath -> a
readDef (-Int
1) (FilePath -> Int) -> Maybe FilePath -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FilePath]
s [FilePath] -> Int -> Maybe FilePath
forall a. [a] -> Int -> Maybe a
`atMay` Int
1
  Int
up <- Int -> FilePath -> Int
forall a. Read a => a -> FilePath -> a
readDef (-Int
1) (FilePath -> Int) -> Maybe FilePath -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FilePath]
s [FilePath] -> Int -> Maybe FilePath
forall a. [a] -> Int -> Maybe a
`atMay` Int
out
  FilePath
dev FilePath
-> Maybe (FilePath, (Int, Int)) -> Maybe (FilePath, (Int, Int))
`seq` Int
down Int -> Maybe (FilePath, (Int, Int)) -> Maybe (FilePath, (Int, Int))
`seq` Int
up Int -> Maybe (FilePath, (Int, Int)) -> Maybe (FilePath, (Int, Int))
`seq` (FilePath, (Int, Int)) -> Maybe (FilePath, (Int, Int))
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
dev, (Int
down, Int
up))
  where
    out :: Int
out = [FilePath] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FilePath]
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 :: FilePath -> MaybeT IO ()
isInterfaceUp FilePath
iface = do
  FilePath
state <- IO FilePath -> MaybeT IO FilePath
forall a. IO a -> MaybeT IO a
handleFailure (IO FilePath -> MaybeT IO FilePath)
-> IO FilePath -> MaybeT IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
readFile (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
"/sys/class/net/" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
iface FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"/operstate"
  case FilePath
state of
    Char
'u' : FilePath
_ -> () -> MaybeT IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    FilePath
_ -> MaybeT IO ()
forall (m :: * -> *) a. MonadPlus m => m a
mzero

handleFailure :: IO a -> MaybeT IO a
handleFailure :: 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 :: SomeException -> IO (Maybe a)
eToNothing SomeException
_ = Maybe a -> IO (Maybe 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
  FilePath
contents <- FilePath -> IO FilePath
readFile FilePath
networkInfoFile
  FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
contents Int -> IO () -> IO ()
`seq` () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  SystemTime
time <- IO SystemTime -> IO SystemTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO SystemTime
getSystemTime
  let mkSample :: (FilePath, (Int, Int)) -> TxSample
mkSample (FilePath
device, (Int
up, Int
down)) =
          TxSample :: Int -> Int -> SystemTime -> FilePath -> TxSample
TxSample { sampleUp :: Int
sampleUp = Int
up
                   , sampleDown :: Int
sampleDown = Int
down
                   , sampleTime :: SystemTime
sampleTime = SystemTime
time
                   , sampleDevice :: FilePath
sampleDevice = FilePath
device
                   }
  [TxSample] -> IO [TxSample]
forall (m :: * -> *) a. Monad m => a -> m a
return ([TxSample] -> IO [TxSample]) -> [TxSample] -> IO [TxSample]
forall a b. (a -> b) -> a -> b
$ ((FilePath, (Int, Int)) -> TxSample)
-> [(FilePath, (Int, Int))] -> [TxSample]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, (Int, Int)) -> TxSample
mkSample ([(FilePath, (Int, Int))] -> [TxSample])
-> [(FilePath, (Int, Int))] -> [TxSample]
forall a b. (a -> b) -> a -> b
$ FilePath -> [(FilePath, (Int, Int))]
parseDevNet FilePath
contents

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

monitorNetworkInterfaces
  :: RealFrac a1
  => a1 -> ([(String, (Rational, Rational))] -> IO ()) -> IO ()
monitorNetworkInterfaces :: a1 -> ([(FilePath, (Rational, Rational))] -> IO ()) -> IO ()
monitorNetworkInterfaces a1
interval [(FilePath, (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 [(FilePath, (TxSample, TxSample))]
samplesVar <- [(FilePath, (TxSample, TxSample))]
-> IO (MVar [(FilePath, (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 :: [(FilePath, (TxSample, TxSample))]
-> IO [(FilePath, (TxSample, TxSample))]
doOnUpdate [(FilePath, (TxSample, TxSample))]
samples = do
        let speedInfo :: [(FilePath, (Rational, Rational))]
speedInfo = ((FilePath, (TxSample, TxSample))
 -> (FilePath, (Rational, Rational)))
-> [(FilePath, (TxSample, TxSample))]
-> [(FilePath, (Rational, Rational))]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, (TxSample, TxSample))
-> (FilePath, (Rational, Rational))
forall a. (a, (TxSample, TxSample)) -> (a, (Rational, Rational))
sampleToSpeeds [(FilePath, (TxSample, TxSample))]
samples
        [(FilePath, (Rational, Rational))] -> IO ()
onUpdate [(FilePath, (Rational, Rational))]
speedInfo
        [(FilePath, (TxSample, TxSample))]
-> IO [(FilePath, (TxSample, TxSample))]
forall (m :: * -> *) a. Monad m => a -> m a
return [(FilePath, (TxSample, TxSample))]
samples
      doUpdate :: IO ()
doUpdate = MVar [(FilePath, (TxSample, TxSample))]
-> ([(FilePath, (TxSample, TxSample))]
    -> IO [(FilePath, (TxSample, TxSample))])
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
MV.modifyMVar_ MVar [(FilePath, (TxSample, TxSample))]
samplesVar ((IO [(FilePath, (TxSample, TxSample))]
-> ([(FilePath, (TxSample, TxSample))]
    -> IO [(FilePath, (TxSample, TxSample))])
-> IO [(FilePath, (TxSample, TxSample))]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [(FilePath, (TxSample, TxSample))]
-> IO [(FilePath, (TxSample, TxSample))]
doOnUpdate) (IO [(FilePath, (TxSample, TxSample))]
 -> IO [(FilePath, (TxSample, TxSample))])
-> ([(FilePath, (TxSample, TxSample))]
    -> IO [(FilePath, (TxSample, TxSample))])
-> [(FilePath, (TxSample, TxSample))]
-> IO [(FilePath, (TxSample, TxSample))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(FilePath, (TxSample, TxSample))]
-> IO [(FilePath, (TxSample, TxSample))]
updateSamples)
  a1 -> IO () -> IO ThreadId
forall d a. RealFrac d => d -> IO a -> IO ThreadId
foreverWithDelay a1
interval IO ()
doUpdate

updateSamples ::
  [(String, (TxSample, TxSample))] ->
  IO [(String, (TxSample, TxSample))]
updateSamples :: [(FilePath, (TxSample, TxSample))]
-> IO [(FilePath, (TxSample, TxSample))]
updateSamples [(FilePath, (TxSample, TxSample))]
currentSamples = do
  let getLast :: TxSample -> TxSample
getLast sample :: TxSample
sample@TxSample { sampleDevice :: TxSample -> FilePath
sampleDevice = FilePath
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
$ FilePath
-> [(FilePath, (TxSample, TxSample))] -> Maybe (TxSample, TxSample)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
device [(FilePath, (TxSample, TxSample))]
currentSamples
      getSamplePair :: TxSample -> (FilePath, (TxSample, TxSample))
getSamplePair sample :: TxSample
sample@TxSample { sampleDevice :: TxSample -> FilePath
sampleDevice = FilePath
device } =
        let lastSample :: TxSample
lastSample = TxSample -> TxSample
getLast TxSample
sample
        in TxSample
lastSample TxSample
-> (FilePath, (TxSample, TxSample))
-> (FilePath, (TxSample, TxSample))
`seq` (FilePath
device, (TxSample
sample, TxSample
lastSample))
  [(FilePath, (TxSample, TxSample))]
-> ([TxSample] -> [(FilePath, (TxSample, TxSample))])
-> Maybe [TxSample]
-> [(FilePath, (TxSample, TxSample))]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [(FilePath, (TxSample, TxSample))]
currentSamples ((TxSample -> (FilePath, (TxSample, TxSample)))
-> [TxSample] -> [(FilePath, (TxSample, TxSample))]
forall a b. (a -> b) -> [a] -> [b]
map TxSample -> (FilePath, (TxSample, TxSample))
getSamplePair) (Maybe [TxSample] -> [(FilePath, (TxSample, TxSample))])
-> IO (Maybe [TxSample]) -> IO [(FilePath, (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 (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)