Live.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-|
Module: Tshark.Live
Description : Load incrementally a PCAP into a frame
Maintainer  : matt
Portability : Linux
-}
module Tshark.Live (
    showLiveStatsTcp
  , showLiveStatsMptcp
  , LiveStats(..)
  , LiveStatsTcp
  , LiveStatsConfig(..)
  , LiveStatsMptcp(..)
  , lsmMaster, lsmSubflows, lsmStats
  , mkLiveStatsMptcp
  , genLiveStatsMptcp
  , genLiveStatsTcp
  -- , CaptureSettingsMptcp
)
where


import Tshark.Main (csvDelimiter, defaultTsharkPrefs)
import Net.Stream
import Net.Mptcp.Stats

import Data.Text as T
import qualified Data.Map.Strict as Map
import Control.Lens

import GHC.IO.Handle
import Pipes ((>->))
import Pipes hiding (Proxy)
-- import Control.Monad.Primitive
import Control.Exception (IOException, try)
import Control.Monad (liftM, unless, when)
import Data.Maybe (isNothing)
import qualified Data.Text.Encoding as T
import qualified Data.Text.IO as T
import qualified Data.Map.Strict as Map
import Data.Vinyl.Functor (Compose(..), (:.))
import Debug.Trace (trace, traceShow, traceShowId)
import Frames
import Frames.CSV
       ( ParserOptions
       , ReadRec
       , columnSeparator
       , defaultParser
       , headerOverride
       , pipeTableEitherOpt
       , pipeTableMaybeOpt
       , readRecEither
       , readRow
       , tokenizeRow
       )
import Frames.Exploration
import MptcpAnalyzer.Types (HostCols, Packet, PacketWithTcpDest)
import qualified Pipes as P
import qualified Pipes.Parse as P
import qualified Pipes.Prelude as P
import qualified Pipes.Safe as P

import Control.Monad.State (MonadState(get), StateT, gets, modify')
import Control.Monad.State.Lazy (execStateT)
import Data.Text.IO (hPutStrLn)
import MptcpAnalyzer (FrameFiltered(ffFrame))
import MptcpAnalyzer.ArtificialFields
import MptcpAnalyzer.Pcap (addTcpDestinationsToAFrame)
import MptcpAnalyzer.Types (FrameFiltered(FrameTcp))
import Net.Mptcp.Stats (MptcpUnidirectionalStats)
import Net.Mptcp.Connection (MptcpConnection(MptcpConnection))
import Net.Mptcp.Stats (MptcpUnidirectionalStats, showMptcpUnidirectionalStats, TcpSubflowUnidirectionalStats)
import Net.Tcp (TcpConnection)
import Net.Tcp.Stats
       (TcpUnidirectionalStats, getTcpStatsFromAFrame, showTcpUnidirectionalStats)
import System.Console.ANSI
import System.IO (stdout)
import Net.Mptcp.Connection
import qualified Data.Set as Set
import GHC.Word (Word64, Word32)
import MptcpAnalyzer.Utils.Text


-- --         +--------+-- A 'Producer' that yields 'String's
-- --         |        |
-- --         |        |      +-- Every monad transformer has a base monad.
-- --         |        |      |   This time the base monad is 'IO'.
-- --         |        |      |
-- --         |        |      |  +-- Every monadic action has a return value.
-- --         |        |      |  |   This action returns '()' when finished
-- --         v        v      v  v
-- stdinLn :: Producer String IO ()
-- stdinLn = do
--     eof <- lift isEOF        -- 'lift' an 'IO' action from the base monad
--     unless eof $ do
--         res <- lift getLine
--         yield res            -- 'yield' the 'String'
--         stdinLn              -- Loop

-- loop :: Effect IO ()
-- loop = for stdinLn $ \x -> do  -- Read this like: "for str in stdinLn"
--     lift $ putStrLn x

-- | Opens a file (in 'P.MonadSafe') and repeatedly applies the given
-- function to the 'Handle' to obtain lines to yield. Adapted from the
-- moribund pipes-text package.
pipeLines :: P.MonadSafe m
          => (Handle -> IO (Either IOException T.Text))
          -> Handle
          -> P.Producer T.Text m ()
pipeLines pgetLine h =
  let loop = do txt <- P.liftIO (pgetLine h)
                case txt of
                  Left _e -> return ()
                  Right y -> P.yield y >> loop
  in loop

-- | Produce lines of 'T.Text'.
-- produceTextLines :: P.MonadSafe m => FilePath -> P.Producer T.Text m ()
-- produceTextLines = pipeLines (try . T.hGetLine)

-- | Show live stats TCP
-- showLiveStatsTcp :: LiveStatsTcp -> Text
-- showLiveStatsTcp stats = T.unlines [
--   showLiveStats (SomeStats stats)
--   , showTcpUnidirectionalStats (lsStats stats)
--   ]

data SomeStats where
  SomeStats :: LiveStats a b -> SomeStats


showLiveStatsTcp :: LiveStatsTcp -> Text
showLiveStatsTcp  liveStats =
      T.unlines (
           [ "Completed ?: " <> tshow (lsHasFinished liveStats) ]
        -- ++ if lsDestination liveStats == RoleServer then else []
        ++ ["Showing towards server: ", showTcpUnidirectionalStats (lsForwardStats liveStats)]
        -- ++ if lsDestination liveStats == RoleClient then else []
        ++ ["Showing towards client: ", showTcpUnidirectionalStats (lsBackwardStats liveStats)]
        )



-- type UpdateFrameFunc a b = Frame a -> Frame a -> (Frame a, b)

-- | Hold information on a connection
-- data LiveStats = LiveStats {
--   -- lsCon :: MptcpConnection,
--   lsStats :: MptcpUnidirectionalStats
--   , lsPackets :: Int
--   -- , lsFrame :: FrameFiltered TcpConnection Packet
--   , lsFrame :: FrameRec HostCols
--   }

-- TODO rename to liveplotConfig ?
data LiveStatsConfig = LiveStatsConfig {
    lsConnection :: TcpConnection
  , lsDestination :: ConnectionRole
  }

-- TODO should be instance of a Monoid !
-- | for now unidirectional ?
data LiveStats stats packet = LiveStats {
  -- lsCon :: MptcpConnection,
    lsForwardStats :: stats
  , lsBackwardStats :: stats
  -- keep to check everything worked fine? else we can retreive the count from lsFrame
  , lsPackets :: Int
  -- , lsConnection :: TcpConnection
  , lsFrame :: Frame packet
  -- , lsFrame :: FrameFiltered con packet
  , lsHasFinished :: Bool
  -- ^ True once it sees a FIN
  -- , lsFrame :: FrameRec HostCols
  }

instance Semigroup stats => Semigroup (LiveStats stats packets) where
  (<>) a b = LiveStats {
        lsForwardStats = lsForwardStats a <> lsForwardStats b
      , lsBackwardStats = lsBackwardStats a <> lsBackwardStats b
      , lsPackets = lsPackets a + lsPackets b
      , lsFrame = lsFrame a <> lsFrame b
      , lsHasFinished = (lsHasFinished a) || (lsHasFinished b)
    }


instance Monoid stats => Monoid (LiveStats stats packets) where
  mempty = LiveStats {
      lsForwardStats = mempty
    , lsBackwardStats = mempty
    -- keep to check everything worked fine? else we can retreive the count from lsFrame
    , lsPackets = 0
    -- , lsConnection :: TcpConnection
    , lsFrame = mempty
    -- , lsFrame :: FrameFiltered con packet
    , lsHasFinished = False
    }

type LiveStatsTcp = LiveStats TcpUnidirectionalStats Packet

-- data LiveStatsTcp = LiveStatsTcp {
--     _lstConn :: Maybe TcpConnection
--   , _lstStats :: LiveStats TcpUnidirectionalStats Packet
--   }
-- type LiveStatsMptcp = LiveStats MptcpUnidirectionalStats MptcpConnection Packet

-- should be richer
data LiveStatsMptcp = LiveStatsMptcp {
    -- tcpStreamId
    _lsmMaster :: Maybe MptcpConnection

  , _lsmClient :: Maybe MptcpEndpointConfiguration
  -- ^ Key / Token
  , _lsmServer :: Maybe MptcpEndpointConfiguration
  -- ^ (Key, Token)
  , _lsmSubflows :: Map.Map StreamIdTcp LiveStatsTcp
        -- (TcpSubflowUnidirectionalStats, TcpSubflowUnidirectionalStats)
  -- ^ TODO these should be subflow stats (dss/dsn)
  , _lsmStats :: LiveStats MptcpUnidirectionalStats Packet
  }

makeLenses ''LiveStatsMptcp

-- |Search for the master subflow
-- TODO could
getMasterSubflow :: [MptcpSubflow] -> Maybe MptcpSubflow
getMasterSubflow l = case Prelude.filter (isNothing . sfJoinToken) l of
  [] -> Nothing
  (x:_) -> Just x

-- helper to create LiveStatsMptcp
mkLiveStatsMptcp :: LiveStatsMptcp
mkLiveStatsMptcp = LiveStatsMptcp {
          _lsmMaster = Nothing
        , _lsmClient = Nothing
        , _lsmServer = Nothing
        , _lsmSubflows = mempty
        , _lsmStats = mempty
        }
-- type CaptureSettingsMptcp = LiveStatsMptcp

-- TODO 
genLiveStatsTcp :: FrameFiltered TcpConnection PacketWithTcpDest -> LiveStatsTcp
genLiveStatsTcp frameWithDest@(FrameTcp _ frame) = let
        forwardFrameWithDest = getTcpStatsFromAFrame frameWithDest RoleServer
        backwardFrameWithDest = getTcpStatsFromAFrame frameWithDest RoleClient
    in (mempty :: LiveStatsTcp) {
      lsPackets = frameLength frame
    -- , lsFrame = frame
    , lsForwardStats = let
        merged = 
          -- trace ("FRAMEWITH DEST\n" ++ showFrame [csvDelimiter defaultTsharkPrefs] (ffFrame frameWithDest) ++ "\n " ++ show forwardFrameWithDest)
          forwardFrameWithDest
        in merged
    , lsBackwardStats =  backwardFrameWithDest
    }


genLiveStatsMptcp :: FrameFiltered MptcpConnection Packet -> LiveStats MptcpUnidirectionalStats Packet
genLiveStatsMptcp mptcpAframe =  (mempty :: LiveStats MptcpUnidirectionalStats Packet) {
    lsPackets = frameLength $ ffFrame mptcpAframe
  , lsFrame = ffFrame mptcpAframe
  , lsForwardStats = getMptcpStats mptcpAframe RoleServer
  , lsBackwardStats = getMptcpStats mptcpAframe RoleClient
  }


showLiveStatsMptcp :: LiveStatsMptcp -> Text
showLiveStatsMptcp stats = T.unlines [
      "Forward: "  <> showMptcpUnidirectionalStats (lsForwardStats $ stats ^. lsmStats)
    , "Backward: " <> showMptcpUnidirectionalStats (lsBackwardStats $ stats ^. lsmStats)
    ]

showLiveStats :: SomeStats -> Text
showLiveStats (SomeStats liveStats) =
  T.unlines [
    "Number of packets: " <> tshow (lsPackets liveStats)
  ]


-- tsharkProducer :: Handle -> Producer Text TsharkMonad ()
-- tsharkProducer hout = do
--     liftIO $ trace ("show hout " ++ show hout) hSetBuffering hout NoBuffering
--     output <- liftIO $ trace "hgetline" hGetLine hout
--     trace "yield" yield (T.pack output)
--     tsharkProducer hout

---- Accept as input the different handles
--readTsharkOutputAndPlotIt :: Handle -> Handle -> IO ()
--readTsharkOutputAndPlotIt hout herr = do
--  -- use pipeTableEitherOpt to parse
--  output <- hGetContents hout
--  putStrLn output