{-# LANGUAGE CPP #-} {- Module: Tshark.Capture Description : Description Maintainer : matt Portability : Linux -} module Tshark.Capture -- ( -- tsharkLoop -- ) where -- mptcpanalyzer imports import Net.Tcp.Connection import Net.Tcp.Constants import MptcpAnalyzer.Stream (StreamIdMptcp) import Net.Mptcp.Connection import Tshark.Live import MptcpAnalyzer.Types import Tshark.Main (csvDelimiter, defaultTsharkPrefs) import MptcpAnalyzer.Pcap import MptcpAnalyzer.ArtificialFields import Net.Tcp.Stats (getTcpStatsFromAFrame) import Net.Mptcp.Stats import Control.Monad.State (MonadState(get), StateT, gets, modify') import qualified Data.Map.Strict as Map import GHC.IO.Handle import Pipes (Effect) import Frames import qualified Data.Text as T import Frames.CSV (columnSeparator, ReadRec, ParserOptions, readRow, defaultParser) import qualified Pipes as P import qualified Pipes.Parse as P import qualified Pipes.Prelude as P import Pipes ((>->)) import Pipes hiding (Proxy) import Debug.Trace (trace, traceShow, traceShowId) import System.Console.ANSI import Data.Vinyl.Functor (getCompose) import qualified Control.Foldl as Foldl import Control.Lens ((^.), (.~)) import qualified Data.Set as Set import Data.Maybe (fromJust) import Data.Either (rights) import Control.Arrow (first) import qualified Data.Foldable as F import qualified Frames as F import qualified Frames.InCore as F pipeTableEitherOpt' :: (Monad m, ReadRec rs) => ParserOptions -> P.Pipe T.Text (Rec (Either T.Text :. ElField) rs) m () pipeTableEitherOpt' opts = do -- when (isNothing (headerOverride opts)) (() <$ P.await) P.map (readRow opts) -- produceFrameChunks -- inCoreAoS -- --capture-comment -- TODO return the frame/ stats tsharkLoopTcp :: LiveStatsConfig -> Handle -> Effect (StateT (LiveStatsTcp) IO) () tsharkLoopTcp lsConfig hout = do ls <- for (P.fromHandle hout) $ \x -> do _ <- liftIO $ putStrLn "newLine" -- (frame :: FrameRec HostCols) <- lift ( inCoreAoS (pipeLines (try. T.hGetLine) hout >-> pipeTableEitherOpt popts >-> P.map fromEither )) -- let x2 :: Text = "1633468309.759952583|eno1|2a01:cb14:11ac:8200:542:7cd1:4615:5e05||2606:4700:10::6814:14ec|||||||||||127|||21.118721618||794|1481|51210|0x00000018|31||3300|443|3||" (frame :: FrameRec HostCols) <- liftIO $ inCoreAoS (yield (T.pack x) >-> pipeTableEitherOpt' popts >-> P.map fromEither ) -- showFrame [csvDelimiter defaultTsharkPrefs] frame liftIO $ putStrLn $ showFrame [csvDelimiter defaultTsharkPrefs] frame let frameWithDest = addTcpDestinationsToAFrame (FrameTcp (lsConnection lsConfig) frame) -- stFrame <- gets lsFrame modify' (updateTcpStats frameWithDest) -- liftIO $ cursorUp 1 liveStats <- get let output = showLiveStatsTcp liveStats liftIO $ cursorUpLine $ (+) 1 (Prelude.length $ T.lines output) liftIO clearFromCursorToScreenEnd liftIO $ (putStrLn . T.unpack) output -- liftIO $ (putStrLn . T.unpack . showLiveStatsTcp) ls pure ls where -- tokenize = tokenizeRow popts popts = defaultParser { columnSeparator = T.pack $ [csvDelimiter defaultTsharkPrefs] } fromEither x = case recEither x of Left _txt -> error ( "eitherProcessed failure : " ++ T.unpack _txt) Right pkt -> pkt -- updateStatsFrame :: FrameRec HostCols -> LiveStatsTcp -> LiveStatsTcp -- updateStatsFrame frame lstats = foldl updateStats lstats frame updateTcpStats frameWithDest tstats = tstats <> genLiveStatsTcp frameWithDest recEither = rtraverse getCompose updateMptcpStats :: ( -- TcpDest F.∈ rs MptcpDsn F.∈ rs, TcpSeq F.∈ rs, IpDest F.∈ rs, IpSource F.∈ rs , TcpLen F.∈ rs , PacketId F.∈ rs , TcpDestPort F.∈ rs, MptcpRecvToken F.∈ rs , TcpFlags F.∈ rs, TcpSrcPort F.∈ rs, TcpStream F.∈ rs, RelTime F.∈ rs , rs F.⊆ HostCols , F.RecVec rs ) => FrameFiltered MptcpConnection (F.Record rs) updateMptcpStats = undefined -- Tricky function: -- Contrary to TCP we have to filter on the master subflow but as we can't update the filter as we discover -- the subflows, we configure tshark to capture all MPTCP traffic and filter it in the application -- 1/ first we need to find the master subflow tsharkLoopMptcp :: LiveStatsConfig -> Handle -> Effect (StateT LiveStatsMptcp IO) () tsharkLoopMptcp config hout = do -- hSetBuffering hout LineBuffering -- ls <- for (tsharkProducer hout) $ \x -> do ls <- for (P.fromHandle hout) $ \x -> do -- (frame :: FrameRec HostCols) <- lift ( inCoreAoS (pipeLines (try. T.hGetLine) hout >-> pipeTableEitherOpt popts >-> P.map fromEither )) -- let x2 :: Text = "1633468309.759952583|eno1|2a01:cb14:11ac:8200:542:7cd1:4615:5e05||2606:4700:10::6814:14ec|||||||||||127|||21.118721618||794|1481|51210|0x00000018|31||3300|443|3||" (frame :: FrameRec HostCols) <- liftIO $ inCoreAoS (yield (T.pack x) >-> pipeTableEitherOpt' popts >-> P.map fromEither ) -- showFrame [csvDelimiter defaultTsharkPrefs] frame liftIO $ putStrLn $ showFrame [csvDelimiter defaultTsharkPrefs] frame -- if we have no master subflow yet, we should check against it -- so now we should mptcpstats <- gets _lsmStats -- TODO should be a fmap considering the complexity modify' (updateStatsFrame frame) -- liftIO $ cursorUp 1 liveStatsMptcp <- get -- showLiveStatsTcp liveStats let output = showLiveStatsMptcp liveStatsMptcp -- liftIO $ cursorUpLine $ (+) 1 (Prelude.length $ T.lines output) liftIO clearFromCursorToScreenEnd liftIO $ (putStrLn . T.unpack) output -- liftIO $ putStrLn $ "length " ++ show (frameLength stFrame) -- lift $ hPutStrLn stdout "test" -- liftIO $ (putStrLn . T.unpack . showLiveStatsTcp) ls pure ls where -- tokenize = tokenizeRow popts popts = defaultParser { columnSeparator = T.pack $ [csvDelimiter defaultTsharkPrefs] } fromEither x = case recEither x of Left _txt -> error ( "eitherProcessed failure : " ++ T.unpack _txt) Right pkt -> pkt recEither = rtraverse getCompose -- expects a frame and a LiveStatsMptcp updateStatsFrame :: FrameRec HostCols -> LiveStatsMptcp -> LiveStatsMptcp updateStatsFrame frame lstats = foldl updateStats lstats frame updateStats :: LiveStatsMptcp -> Record HostCols -> LiveStatsMptcp -- case where the master subflow was already identified updateStats lstats@(LiveStatsMptcp (Just main) _ _ subflows stats) row = case mbSubflow of -- Not a registered subflow yet Nothing -> case row ^. mptcpRecvToken of Nothing -> #ifdef DEBUG_CAPTURE trace "No rcv token" #endif lstats Just rcvToken -> let subflow = buildSubflowFromRecord row in #ifdef DEBUG_CAPTURE trace "Rcv token received" #endif ( -- if token of client then subflow initiated by server if tokenBelongToConnection rcvToken main then lstats { _lsmMaster = #ifdef DEBUG_CAPTURE trace "Adding new subflow" #endif (Just (mptcpConnAddSubflow main subflow)) } else #ifdef DEBUG_CAPTURE trace ("ignoring flow " ++ show subflow) #endif lstats ) Just subflowStats -> case getSubflowFromStreamId main (row ^. tcpStream) of Nothing -> error "Could not find the subflow :s " Just subflow -> let -- TODO update tcp stats for th -- TODO change connection staths when seeing dataFin -- TODO update subflow stats and mptcp stats -- if row ^. mptcpDataFin -- subflow = master tcpAframe :: FrameFiltered TcpConnection Packet tcpAframe = FrameTcp (sfConn subflow) frame newMptcpStats :: LiveStats MptcpUnidirectionalStats Packet newMptcpStats = genLiveStatsMptcp mptcpAframe subflowUpdatedStats :: LiveStatsTcp subflowUpdatedStats = genLiveStatsTcp (addTcpDestinationsToAFrame tcpAframe) in #ifdef DEBUG_CAPTURE trace "known subflow: update stats" #endif (lstats { -- TODO we should have stats in both direction ! -- _lsmStats = (lstats ^. lsmStats) <> newMptcpStats _lsmStats = (lstats ^. lsmStats) <> newMptcpStats , _lsmSubflows = Map.insert (row ^. tcpStream) (subflowStats <> subflowUpdatedStats) (lstats ^. lsmSubflows) }) where tuple = traceShowId (buildTcpConnectionTupleFromRecord row) mptcpAframe :: FrameFiltered MptcpConnection Packet mptcpAframe = FrameTcp main frame frame :: FrameRec HostCols frame = boxedFrame [row] mbSubflow = Map.lookup (row ^. tcpStream) (_lsmSubflows lstats) updateStats lstats@(LiveStatsMptcp Nothing (Just clientCfg) (Just serverCfg) _subflows stats) row = error "should not happen" -- in updateStats newStats row -- attempts to fetch client mptcp key/token from the initial syn (mptcp version 0) updateStats lstats@(LiveStatsMptcp Nothing _ _ _ stats) row = -- synPackets = filterFrame (\x -> TcpFlagSyn `elem` (x ^. tcpFlags)) streamPackets if hasClientKey then -- streamPackets = filterFrame (\x -> x ^. mptcpStream == mympconStreamId) frame -- subflows = map (buildSubflowFromTcpStreamId frame) (getTcpStreams streamPackets) #ifdef DEBUG_CAPTURE trace "SYN FOUND! retreiving client key" #endif lstats { _lsmClient = traceShowId mptcpConfig , _lsmMaster = finalizeLiveStatsMptcp mptcpConfig (_lsmServer lstats) , _lsmSubflows = Map.singleton (row ^. tcpStream) (genLiveStatsTcp (FrameTcp (sfConn subflow) mempty)) -- Set.fromList $ map ffCon (rights subflows) } else if isSynAck then -- lstats & set (traceShowId mptcpConfig) #ifdef DEBUG_CAPTURE trace "SYNACK FOUND! retreiving server key" #endif lstats { _lsmServer = traceShowId mptcpConfig , _lsmMaster = finalizeLiveStatsMptcp (_lsmClient lstats) mptcpConfig } else #ifdef DEBUG_CAPTURE trace "No syn\n" #endif lstats where tuple = traceShowId (buildTcpConnectionTupleFromRecord row) -- tcpAframe = buildA -- TcpFlagSyn `elem` (row ^. tcpFlags) && hasClientKey = (row ^. mptcpSendKey ) /= Nothing && lsConnection config == tcpConnectionFromOriented tuple isSynAck = TcpFlagSyn `elem` (row ^. tcpFlags) && TcpFlagAck `elem` (row ^. tcpFlags) && lsConnection config == tcpConnectionFromOriented (reverseTcpConnectionTuple tuple) mptcpConfig = genMptcpEndpointConfigFromRow row subflow :: MptcpSubflow subflow = (MptcpSubflow (buildTcpConnectionFromRecord row) Nothing Nothing 0 0 Nothing) mympconStreamId :: Maybe StreamIdMptcp mympconStreamId = row ^. mptcpStream finalizeLiveStatsMptcp :: Maybe MptcpEndpointConfiguration -> Maybe MptcpEndpointConfiguration -> Maybe MptcpConnection finalizeLiveStatsMptcp mclientCfg mserverCfg = case (mclientCfg, mserverCfg) of (Just clientCfg, Just serverCfg) -> #ifdef DEBUG_CAPTURE trace "FINALIZING MPTCP connection" #endif (Just $ MptcpConnection { -- get it from map.singleton mpconStreamId = fromJust $ mympconStreamId -- fromJust $ synAckPacket ^. mptcpSendKey , _mpconServerConfig = serverCfg , _mpconClientConfig = clientCfg -- , mptcpNegotiatedVersion = mptcpVersion (serverCfg) -- TODO fix -- , mpconSubflows = Set.fromList $ map ffCon (rights subflows) , _mpconSubflows = Set.singleton subflow }) _ -> Nothing