Live.hs

{-
Module:  MptcpAnalyzer.Commands.Plots.Live
Description :  Description
Maintainer  : matt
Portability : Linux
-}
module MptcpAnalyzer.Plots.Live
where

import qualified Data.Map as Map
import qualified Data.Text as T
import MptcpAnalyzer.ArtificialFields
import MptcpAnalyzer.Cache
import MptcpAnalyzer.Plots.Types
import MptcpAnalyzer.Prelude
import MptcpAnalyzer.Utils.Text
import Net.Tcp
import qualified Polysemy.Embed as P
import qualified Polysemy.Log as Log
import System.Process hiding (runCommand)
import Tshark.Live
import Tshark.Main

import Polysemy (Final, Members, Sem, runFinal)
import qualified Polysemy as P
import qualified Polysemy.Embed as P
import qualified Polysemy.IO as P
import qualified Polysemy.Internal as P
import Polysemy.Log (Log)
import qualified Polysemy.Log as Log
import Polysemy.Log.Colog (interpretLogStdout)
import qualified Polysemy.State as P
import Polysemy.Trace (trace)
import qualified Polysemy.Trace as P

-- import MptcpAnalyzer.Commands.Definitions as CMD
import Control.Monad.State (execStateT)
import Data.Maybe (fromMaybe, fromJust)
import GHC.IO.Handle
import Pipes (runEffect)
import System.Exit
import System.IO (stdout)
import Tshark.Fields
import Tshark.Capture
import Net.Mptcp.Connection
import Control.Lens ((^.))

configureLivePlotTcp :: Members '[Log, P.Trace, P.Embed IO] r
  => LivePlotTcpSettings
  -> Sem r LiveStatsTcp
configureLivePlotTcp (LivePlotTcpSettings connectionFilter mbFake mbConnectionRole ifname) = do
    let
      fields = Map.elems $ Map.map tfieldFullname baseFields

      -- stats/packetCount/Frame
      -- keeping it light for now
      destination = fromMaybe RoleServer mbConnectionRole
      lsConfig = LiveStatsConfig connectionFilter destination

      -- initialLiveStats :: LiveStatsTcp = LiveStats mempty 0 mempty
      toLoad = case mbFake of
        Just filename -> Right filename
        Nothing -> Left ifname

      --capture-comment
      tsharkPrefs = defaultTsharkPrefs {
        tsharkReadFilter = Just $ genReadFilterFromTcpConnection connectionFilter (Just destination)
        }
      (RawCommand bin genArgs) = generateCsvCommand fields toLoad tsharkPrefs
      -- args = genArgs ++ ["--capture-comment='Generated by mptcpanalyzer'"]
      args = genArgs ++ [ "-l"]
      createProc :: CreateProcess
      createProc = (proc bin args) {
            std_err = CreatePipe
            -- Inherit,
            , std_out = CreatePipe
            -- lets the child handle Ctrl-c
            , delegate_ctlc = True
          }

    Log.info $ "Looking at destination " <> tshow destination

    trace $ "Command run: " ++ show (RawCommand bin args)
    trace $ "Command run: " ++ showCommandForUser bin args
    -- Log.info $ "Starting " <> tshow bin <> tshow args
    ls <- P.embed $ startLivePlot lsConfig createProc
    pure ls

startLivePlot :: LiveStatsConfig -> CreateProcess -> IO LiveStatsTcp
startLivePlot lsConfig createProc = do
  let initialLiveStats :: LiveStatsTcp = LiveStats mempty mempty 0 mempty False

  (_, Just hout, Just herr, ph) <-  createProcess_ "error when creating process" createProc
  -- hSetBuffering stdout NoBuffering
  hSetBuffering stdout LineBuffering

  -- non blocking
  exitCode <- getProcessExitCode ph
  case exitCode of
    Just code -> putStrLn "Finished" >> pure initialLiveStats
    _ -> do
      -- hSetBuffering hout LineBuffering
      -- hSetBuffering herr NoBuffering
      putStrLn $ "Starting live TCP plot with initial stats: (before): " ++ show (lsPackets initialLiveStats)
      liveStats <- execStateT (runEffect (tsharkLoopTcp lsConfig hout)) initialLiveStats
      putStrLn $ "Live stats (after): " ++ show (lsPackets liveStats)
      -- putStrLn $ "Live stats (after): " ++ (T.unpack . showLiveStatsTcp) liveStats
      -- blocking
      putStrLn $ "Live stats (after): " ++ (T.unpack . showLiveStatsTcp) liveStats
      putStrLn $ "Waiting for process"
      exitCode2 <- waitForProcess ph
      case exitCode2 of
        ExitSuccess -> putStrLn "Success" >> pure liveStats
        _  -> do
          putStrLn "hGetContents"
          hGetContents herr >>= putStrLn >> pure initialLiveStats
  -- putStrLn $ "final exitCode"

-- LiveStatsMptcp
startMptcpCapture :: 
-- Members '[Log, P.Trace, P.Embed IO] r =>
   LiveStatsConfig 
   -> LiveStatsMptcp
   -> CreateProcess
   -> IO LiveStatsMptcp

startMptcpCapture lsConfig initialLiveStats createProc = do
  (_, Just hout, Just herr, ph) <- createProcess_ "error when creating process" createProc
  hSetBuffering stdout LineBuffering
  -- non blocking
  exitCode <- getProcessExitCode ph
  case exitCode of
    Just code -> putStrLn "Finished" >> pure initialLiveStats
    _ -> do
      -- hSetBuffering hout LineBuffering
      -- hSetBuffering herr NoBuffering
      putStrLn $ "Starting live mptcp plotting stats (before): "
      liveStats <- execStateT (runEffect (tsharkLoopMptcp lsConfig hout)) initialLiveStats
      case liveStats ^. lsmMaster of
        Nothing -> putStrLn "Could not detect the mptcp connection"
        Just master -> putStrLn $ "Live stats (after): " ++ (T.unpack $ showMptcpConnectionText master)
      -- putStrLn $ "Live stats (after): " ++ (T.unpack $ showMptcpConnectionText (fromJust $ liveStats ^. lsmMaster))
      putStrLn $ "Live stats (after): " ++ (T.unpack . showLiveStatsMptcp) liveStats
      -- putStrLn $ "Live stats (after): " ++ show (lsPackets liveStats)
      -- blocking
      exitCode2 <- waitForProcess ph
      case exitCode2 of
        ExitSuccess -> putStrLn "Success" >> pure liveStats
        _  -> do
          putStrLn "hGetContents"
          hGetContents herr >>= putStrLn >> pure liveStats
  -- putStrLn $ "final exitCode"

{- | Starts live analysis of an MPTCP flow
One needs to filter
-}
configureLivePlotMptcp :: Members '[Log, Cache, P.Trace, P.Embed IO] r =>
       LivePlotTcpSettings
    -- -> CaptureSettingsMptcp
    -> Sem r LiveStatsMptcp

configureLivePlotMptcp (LivePlotTcpSettings connectionFilter mbFake mbConnectionRole ifname) = do
    let
      destination = fromMaybe RoleServer mbConnectionRole

      lpConfig = LiveStatsConfig connectionFilter destination
      initialLiveStats = mkLiveStatsMptcp
      fields = Map.elems $ Map.map tfieldFullname baseFields

      -- stats/packetCount/Frame
      -- keeping it light for now
      toLoad = case mbFake of
        Just filename -> Right filename
        Nothing -> Left ifname

      --capture-comment
      tsharkPrefs = defaultTsharkPrefs {
        tsharkReadFilter = Just $ genReadFilterMptcpFromMptcpConnection
        }
      (RawCommand bin genArgs) = generateCsvCommand fields toLoad tsharkPrefs
      -- args = genArgs ++ ["--capture-comment='Generated by mptcpanalyzer'"]
      args = genArgs ++ [ "-l"]
      createProc :: CreateProcess
      createProc = (proc bin args) {
            std_err = CreatePipe
            -- Inherit,
            , std_out = CreatePipe
            -- lets the child handle Ctrl-c
            , delegate_ctlc = True
          }

    Log.info $ "Looking at destination " <> tshow destination

    trace $ "Command run: " ++ show (RawCommand bin args)
    trace $ "Command run: " ++ showCommandForUser bin args
    -- Log.info $ "Starting " <> tshow bin <> tshow args
    ls <- P.embed $ startMptcpCapture lpConfig initialLiveStats createProc
    pure ls