{-| Module: MptcpAnalyzer.Pcap Maintainer : matt License : GPL-3 Pot-pourri -} {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE PackageImports #-} module MptcpAnalyzer.Pcap ( addTcpDestToFrame , addMptcpDestToFrame , addMptcpDest , addTcpDestinationsToAFrame , buildTcpConnectionFromStreamId , buildMptcpConnectionFromStreamId , defaultParserOptions , genTcpDestFrame , genTcpDestFrameFromAFrame , exportToCsv , loadRows , getTcpStreams , getMptcpStreams , buildSubflowFromRecord , buildSubflowFromTcpStreamId , buildTcpConnectionFromRecord , buildTcpConnectionTupleFromRecord , genMptcpEndpointConfigFromRow -- TODO remove ? use instance instead , showMptcpSubflowText , StreamConnection(..) , showConnection , scoreTcpCon , scoreMptcpCon -- , showMptcpSubflowText ) where import MptcpAnalyzer.ArtificialFields import MptcpAnalyzer.Stream import MptcpAnalyzer.Types import MptcpAnalyzer.Utils.Text import Net.Mptcp.Connection import Net.Tcp import Net.Stream import Net.Tcp.Constants (TcpFlag(..)) import Tshark.Fields import Tshark.TH -- hackage import Control.Lens ((^.)) import Data.Kind (Type) import Data.Monoid (First(..)) import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Data.Vector as V import Frames import Frames.CSV ( ParserOptions(..) , QuotingMode(..) , ReadRec , pipeTableEitherOpt , produceTextLines , readFileLatin1Ln , readTableMaybeOpt ) import Frames.Col import Frames.ColumnTypeable (Parseable(..), Parsed(..), parseIntish) import Frames.ShowCSV import Frames.TH import System.Exit import System.IO ( BufferMode(LineBuffering) , Handle , SeekMode(AbsoluteSeek) , hGetContents , hSeek , hSetBuffering ) import System.Process -- for Record -- import Frames.Rec (Record(..)) import Data.List (intercalate) import Net.IP -- for symbol -- import GHC.Types import qualified Control.Foldl as L import qualified Data.Set as Set -- import Language.Haskell.TH -- import Language.Haskell.TH.Syntax -- import Lens.Micro -- import Lens.Micro.Extras import Control.Lens import qualified Data.Foldable as F import Data.Maybe (catMaybes, fromJust, isNothing) import Data.Vinyl (ElField(..), Rec(..), rapply, rmapX, xrec) import Data.Vinyl.Class.Method import Data.Vinyl.Functor (Compose(..), (:.)) import Data.Word (Word16, Word32, Word64, Word8) import GHC.Base (Symbol) import GHC.List (foldl') import GHC.TypeLits (KnownSymbol) import Numeric (readHex) import Pipes (Producer, cat, (>->)) import qualified Pipes.Prelude as P -- import qualified Frames.InCore import Control.Exception (assert) import Data.Either (lefts, rights) import qualified Data.Map as Map import Debug.Trace import qualified Frames.InCore as I import GHC.IO.Handle (hClose) import System.Environment (getEnvironment) import System.IO.Temp import Tshark.Main -- tableTypes is a Template Haskell function, which means that it is executed at compile time. It generates a data type for our CSV, so we have everything under control with our types. -- on veut la generer -- [[t|Ident Int|], [t|Happiness|]] -- tableTypesExplicit' :: [Q Type] -> RowGen a -> FilePath -> DecsQ -- tableTypesExplicit' -- tableTypesExplicit' -- (getTypes baseFields) -- -- [ Field Word64 ] -- -- [[t| Word64|]] -- ((rowGen "data/test-1col.csv") -- { rowTypeName = "Packet" -- , separator = "," -- -- TODO I could generate it as well -- -- , columnNames -- }) -- -- path -- "data/test-simple.csv" -- shadow type to know if it was filtered or not -- Make it a record ? -- first argument allows to override csv header ("headerOverride") defaultParserOptions :: ParserOptions defaultParserOptions = ParserOptions Nothing (T.pack [csvDelimiter defaultTsharkPrefs]) NoQuoting -- nub => remove duplicates -- or just get the column getTcpStreams :: FrameRec HostCols -> [StreamIdTcp] getTcpStreams ps = L.fold L.nub (view tcpStream <$> ps) -- | to list getMptcpStreams :: FrameRec HostCols -> [StreamId Mptcp] getMptcpStreams ps = L.fold L.nub $ catMaybes $ F.toList (view mptcpStream <$> ps) -- filterFrame (\x -> x ^. mptcpStream == Just streamId) frame {- Export to CSV sets WIRESHARK_CONFIG_DIR so that the user profile doesn't influence the output -} exportToCsv :: TsharkParams -> FilePath -- ^Path to the pcap -> Handle -- ^ temporary file -- ^See haskell:readCreateProcessWithExitCode -> IO (ExitCode, String) exportToCsv params pcapPath tmpFileHandle = do curEnv <- getEnvironment withSystemTempFile "tshark-profile" $ \tempDir _ -> do let (RawCommand bin args) = generateCsvCommand fields (Right pcapPath) (params ) createProc :: CreateProcess createProc = (proc bin args) { std_err = CreatePipe, std_out = UseHandle tmpFileHandle, env = Just $ curEnv ++ [ ("WIRESHARK_CONFIG_DIR", tempDir) ], delegate_ctlc = True } putStrLn $ "Exporting fields " ++ show fields putStrLn $ "Command run: " ++ show (RawCommand bin args) -- TODO redirect stdout towards the out handle hSetBuffering tmpFileHandle LineBuffering hSeek tmpFileHandle AbsoluteSeek 0 >> T.hPutStrLn tmpFileHandle fieldHeader (_, _, Just herr, ph) <- createProcess_ "error" createProc exitCode <- waitForProcess ph -- TODO do it only in case of error ? err <- hGetContents herr hClose herr return (exitCode, err) where fields :: [T.Text] fields = Map.elems $ Map.map tfieldFullname baseFields csvSeparator = T.pack [csvDelimiter params] fieldHeader :: Text fieldHeader = T.intercalate csvSeparator (Map.keys baseFields) loadRows :: (I.RecVec a, ReadRec a) => FilePath -> IO (FrameRec a) loadRows path = inCoreAoS ( eitherProcessed path ) type ManEither = Rec (Either T.Text :. ElField) (RecordColumns Packet) -- pipteTable will tokenize on its own -- loadRowsEither :: MonadSafe m => FilePath -> Producer ManEither m () -- loadRowsEither path = produceTextLines path >-> pipeTableEitherOpt defaultParserOptions {- |Load rows and errors when it can't load a specific line -} eitherProcessed :: (ReadRec a, MonadSafe m) => FilePath -> Producer (Record a) m () eitherProcessed path = produceTextLines path >-> pipeTableEitherOpt defaultParserOptions >-> P.map fromEither where -- fromEither :: Rec (Either Text :. ElField) (RecordColumns Packet) -> Packet fromEither x = case recEither x of Left _txt -> error ( "eitherProcessed failure : " ++ T.unpack _txt) Right pkt -> pkt recEither = rtraverse getCompose -- | Undistribute 'Maybe' from a 'Rec' 'Maybe'. This is just a -- specific usage of 'rtraverse', but it is quite common. -- recEither :: Rec (Either Text :. ElField) cs -> Either Text (Record cs) -- recEither = rtraverse getCompose -- data TsharkPrefs = TsharkPrefs { -- analyzeTcpSeq :: Bool -- , analyzeMptcp :: Bool -- , mptcpRelSeq :: Bool -- , analyzeMptcp :: Bool -- } deriving Show {- -} getTcpFrame :: FrameRec HostCols -> StreamId Tcp -> Either String (FrameFiltered TcpConnection Packet) getTcpFrame = buildTcpConnectionFromStreamId -- | For now assume the packet is the first syn from client to server -- TODO this is wrong, assumes source ip is client, convert to return a TcpConnectionOriented buildTcpConnectionFromRecord :: ( IpFields rs, TcpSrcPort ∈ rs, TcpDestPort ∈ rs, TcpStream ∈ rs ) => Record rs -> TcpConnection buildTcpConnectionFromRecord r = TcpConnection { conTcpClientIp = r ^. ipSource , conTcpServerIp = r ^. ipDest , conTcpClientPort = r ^. tcpSrcPort , conTcpServerPort = r ^. tcpDestPort , conTcpStreamId = r ^. tcpStream } buildTcpConnectionTupleFromRecord :: ( IpFields rs, TcpSrcPort ∈ rs, TcpDestPort ∈ rs, TcpStream ∈ rs ) => Record rs -> TcpConnectionOriented buildTcpConnectionTupleFromRecord r = TcpConnectionOriented { conTcpSourceIp = r ^. ipSource , conTcpDestinationIp = r ^. ipDest , conTcpSourcePort = r ^. tcpSrcPort , conTcpDestinationPort = r ^. tcpDestPort -- , conTcpStreamId = r ^. tcpStream } {- Builds a Tcp connection from a non filtered frame -} buildTcpConnectionFromStreamId :: FrameRec HostCols -> StreamId Tcp -> Either String (FrameFiltered TcpConnection Packet) buildTcpConnectionFromStreamId frame streamId = if frameLength synPackets < 1 then Left $ "No packet with any SYN flag for tcp.stream " ++ show streamId else -- TODO check who is client Right $ FrameTcp (buildTcpConnectionFromRecord $ frameRow synPackets 0) streamPackets where streamPackets = filterFrame (\x -> x ^. tcpStream == streamId) frame synPackets = filterFrame (\x -> TcpFlagSyn `elem` (x ^. tcpFlags)) streamPackets -- | -- buildMasterSubflowFromRecord :: -- | Builds -- should expect a filteredFrame with MPTCP -- buildSubflowFromTcpStreamId :: FrameFiltered TcpConnection Packet -> StreamId Tcp -> Either String (FrameFiltered MptcpSubflow Packet) buildSubflowFromRecord :: Packet -> MptcpSubflow buildSubflowFromRecord row = MptcpSubflow { sfConn = sfCon -- TODO ignore if it's master token , sfJoinToken = row ^. mptcpRecvToken , sfPriority = Nothing -- TODO , sfLocalId = 0 , sfRemoteId = 0 -- todo load it from row , sfInterface = Nothing } where sfCon = buildTcpConnectionFromRecord row buildSubflowFromTcpStreamId :: ( rs ⊆ HostCols , I.RecVec rs , TcpFlags ∈ rs , TcpStream ∈ rs, MptcpRecvToken ∈ rs , IpSource ∈ rs, IpDest ∈ rs, TcpSrcPort ∈ rs, TcpDestPort ∈ rs, TcpStream ∈ rs ) => FrameRec rs -> StreamId Tcp -> Either String (FrameFiltered MptcpSubflow (Record rs)) buildSubflowFromTcpStreamId frame streamId = if frameLength synPackets < 1 then Left $ "No packet with any SYN flag for tcp.stream " ++ show streamId else -- TODO check who is client Right $ FrameTcp sf streamPackets where syn0 = frameRow synPackets 0 streamPackets = filterFrame (\x -> x ^. tcpStream == streamId) frame synPackets = filterFrame (\x -> TcpFlagSyn `elem` (x ^. tcpFlags)) streamPackets sfCon = buildTcpConnectionFromRecord syn0 -- rcvToken sf = MptcpSubflow { sfConn = sfCon -- TODO ignore if it's master token , sfJoinToken = syn0 ^. mptcpRecvToken , sfPriority = Nothing , sfLocalId = 0 , sfRemoteId = 0 , sfInterface = Nothing } -- | Sets mptcp role column -- TODO maybe je devrais juste generer un addMptcpDest :: ( -- Frames.InCore.RecVec rs, -- HostCols ⊆ rs -- MptcpStream ∈ rs, TcpStream ∈ rs, IpSource ∈ rs, IpDest ∈ rs, TcpSrcPort ∈ rs, TcpDestPort ∈ rs -- rs = HostCols ) => Frame (Record HostCols) -> MptcpConnection -> FrameRec ( MptcpDest ': TcpDest ': HostCols ) addMptcpDest frame con = -- foldl' (\tframe sf -> addDestToFrame tframe sf) startingFrame subflows mconcat subflowFrames where -- filteredFrame = filterFrame (\x -> x ^. mptcpStream == Just (mpconStreamId con)) frame -- filteredFrame = filterFrame (\x -> (rgetField @MptcpStream x) == Just (mpconStreamId con)) frame subflowFrames = map addDestsToSubflowFrames subflows addDestsToSubflowFrames sf = addMptcpDestToFrame' (addTcpDestToFrame frame (sfConn sf)) sf addMptcpDest' role x = Col role :& x addMptcpDestToFrame' frame' sf = fmap (addMptcpDest' (getMptcpDest con sf)) frame' startingFrame = fmap setTempDests frame setTempDests :: Record rs -> Record ( MptcpDest ': TcpDest ': rs) setTempDests x = Col RoleClient :& Col RoleClient :& x addMptcpDestToRec x role = Col role :& x subflows = Set.toList $ _mpconSubflows con addMptcpDestToFrame :: MptcpConnection -> FrameFiltered MptcpSubflow Packet -> FrameRec '[MptcpDest] addMptcpDestToFrame mpcon (FrameTcp sf frame) = fmap (addMptcpDest' (getMptcpDest mpcon sf)) frame where addMptcpDest' role x = Col role :& RNil getMptcpDest :: MptcpConnection -> MptcpSubflow -> ConnectionRole getMptcpDest mptcpCon sf = case sfJoinToken sf of -- master subflow, dest is by definition the server Nothing -> RoleServer Just token -> if token == (_mecToken . _mpconServerConfig) mptcpCon then RoleServer else RoleClient -- | Sets TCP role column -- append a column with a value role -- Todo accept a 'FrameFiltered' -- I want to check it is included -- TODO add an unsafe version ? addTcpDestToFrame :: ( I.RecVec rs ,IpSource ∈ rs, IpDest ∈ rs , IpDest ∈ rs, TcpSrcPort ∈ rs, TcpDestPort ∈ rs , TcpStream ∈ rs ) => FrameRec rs -> TcpConnection -> FrameRec ( TcpDest ': rs ) addTcpDestToFrame frame con = do assert -- check that they all belong to the same stream (length ( L.fold L.nub (view tcpStream <$> frame)) == 1) fmap (\x -> addTcpDestToRec x (computeTcpDest x con)) streamFrame where streamFrame = frame -- | Generates a frame with a single column containing the TcpDest genTcpDestFrame :: ( I.RecVec rs , IpSource ∈ rs, IpDest ∈ rs , TcpSrcPort ∈ rs, TcpDestPort ∈ rs , TcpStream ∈ rs ) => FrameRec rs -> TcpConnection -> FrameRec '[TcpDest] genTcpDestFrame frame con = fmap (\x -> Col (computeTcpDest x con) :& RNil) streamFrame where streamFrame = filterFrame (\x -> rgetField @TcpStream x == conTcpStreamId con) frame genTcpDestFrameFromAFrame :: ( I.RecVec rs , IpSource ∈ rs, IpDest ∈ rs , TcpSrcPort ∈ rs, TcpDestPort ∈ rs , TcpStream ∈ rs ) => FrameFiltered TcpConnection (Record rs) -> FrameRec '[TcpDest] genTcpDestFrameFromAFrame aframe = genTcpDestFrame (ffFrame aframe) (ffCon aframe) computeTcpDest :: ( TcpStream ∈ rs , IpFields rs , TcpSrcPort ∈ rs , TcpDestPort ∈ rs ) => Record rs -> TcpConnection -> ConnectionRole computeTcpDest x con = if rgetField @IpSource x == conTcpClientIp con && rgetField @IpDest x == conTcpServerIp con && rgetField @TcpSrcPort x == conTcpClientPort con && rgetField @TcpDestPort x == conTcpServerPort con && rgetField @TcpDestPort x == conTcpServerPort con -- TODO should error if not the same streamId -- && (rgetField @TcpStream x) == (conTcpStreamId con) then RoleServer else RoleClient -- | TODO -- See @addTcpDestToFrame@ addTcpDestinationsToAFrame :: ( -- HostCols ⊆ rs, I.RecVec rs -- , HostCols <: rs -- , HostCols ∈ rs , IpFields rs , TcpFields rs) => FrameFiltered TcpConnection (Record rs) -> FrameFiltered TcpConnection (Record (TcpDest ': rs)) addTcpDestinationsToAFrame aframe = aframe { ffFrame = addDestinationsToFrame' (ffCon aframe)} where frame = ffFrame aframe addDestinationsToFrame' con = addTcpDestToFrame frame con -- append a field with a value role addTcpDestToRec :: (TcpStream ∈ rs, IpSource ∈ rs, IpDest ∈ rs, TcpSrcPort ∈ rs, TcpDestPort ∈ rs) => Record rs -> ConnectionRole -> Record ( TcpDest ': rs ) addTcpDestToRec x role = (Col role) :& x -- TODO take into account the different mptcp versions ? genMptcpEndpointConfigFromRow :: Packet -> Maybe MptcpEndpointConfiguration genMptcpEndpointConfigFromRow synAckPacket = case (synAckPacket ^. mptcpSendKey, synAckPacket ^. mptcpExpectedToken, synAckPacket ^. mptcpVersion) of (Just key, Just token, Just version) -> Just $ MptcpEndpointConfiguration key token version _ -> Nothing -- error $ "Could not find key/token/version " ++ show synAckPacket -- retreiveMptcpServerTokenFromRow :: Packet -> Maybe (Word64, Word32) -- retreiveMptcpServerTokenFromRow synAckPacket = -- case (synAckPacket ^. mptcpSendKey, synAckPacket ^. mptcpExpectedToken) of -- (Just key, Just token) -> Just (key, token) -- _ -> error "Could not generate" -- TODO buildMptcpConnectionFromStreamId :: FrameRec HostCols -> StreamId Mptcp -> Either String (FrameFiltered MptcpConnection Packet) buildMptcpConnectionFromStreamId frame streamId = do -- Right $ frameLength synPackets if frameLength streamPackets < 1 then Left $ "No packet with mptcp.stream == " ++ show streamId else if frameLength synAckPackets < 1 then Left $ "No syn/ack packet found for stream" ++ show streamId ++ " First packet: " -- ++ show streamPackets else if lefts subflows /= [] then Left $ concat (lefts subflows) else if mbServerConfig == Nothing then Left $ "Could not find MPTCP server config in " ++ show synAckPacket else case buildTcpConnectionFromStreamId streamPackets (synPacket ^. tcpStream) of Left err -> Left err Right aframe -> let clientFrame = filterFrame (\x -> ((not . isNothing) (x ^. mptcpSendKey))) (ffFrame aframe) mbClientConfig = genMptcpEndpointConfigFromRow (frameRow clientFrame 0) in if frameLength clientFrame == 0 then Left $ "Could not find mptcp client key" else -- TODO now add a check on abstime -- if ds.loc[server_id, "abstime"] < ds.loc[client_id, "abstime"]: -- log.error("Clocks are not synchronized correctly") -- update temporary fframe with the computed subflows Right $ FrameTcp { ffCon = tempMptcpConn mbClientConfig , ffFrame = streamPackets } where streamPackets :: FrameRec HostCols streamPackets = filterFrame (\x -> x ^. mptcpStream == Just streamId) frame -- -- |Just for the time tempMptcpConn clientConfig = MptcpConnection { mpconStreamId = streamId -- kinda risky, assumes we have the server key always , _mpconServerConfig = fromJust mbServerConfig , _mpconClientConfig = fromJust clientConfig -- , mptcpNegotiatedVersion = fromIntegral $ fromJust clientMptcpVersion :: Word8 , _mpconSubflows = Set.fromList $ map ffCon (rights subflows) } -- suppose tcpflags is a list of flags, check if it is in the list -- of type FrameRec [(Symbol, *)] -- Looking for synack packets synPackets = filterFrame (\x -> TcpFlagSyn `elem` (x ^. tcpFlags)) streamPackets synAckPackets = filterFrame (\x -> TcpFlagSyn `elem` (x ^. tcpFlags) && TcpFlagAck `elem` (x ^. tcpFlags)) streamPackets synPacket = frameRow synPackets 0 synAckPacket = frameRow synAckPackets 0 mbServerConfig = genMptcpEndpointConfigFromRow synAckPacket -- clientConfig :: Maybe MptcpEndpointConfiguration -- clientConfig = case mbServerConfig of -- Nothing -> Nothing -- Just serverConfig -> -- if mecVersion == 0 then genMptcpEndpointConfigFromRow synPacket -- else genMptcpEndpointConfigFromRow masterTcpstreamId = synPacket ^. tcpStream clientMptcpVersion = synPacket ^. mptcpVersion -- subflows = map (buildSubflowFromTcpStreamId frame) (getTcpStreams streamPackets) -- filterFrame / buildFrameFromStreamId {- Common interface to work with TCP and MPTCP connections -} class StreamConnection a b | a -> b where -- | How -- type ConnectionType :: Type showConnectionText :: a -> Text -- describeConnection :: a -> Text buildFrameFromStreamId :: Frame Packet -> StreamId b -> Either String (FrameFiltered a Packet) -- type Needs a :: Constraint -- type toto = Int -- | Compare two conection and give a similarityScore similarityScore :: a -> a -> Int -- listConnections :: FrameFiltered () [a] -- summarize :: a -> Text -- GetLabel ? -- | Compares 2 TCP connections and gives a score -- The higher the score, the more similar the 2 connections are. scoreTcpCon :: TcpConnection -> TcpConnection -> Int scoreTcpCon con1 con2 = -- If every parameter is equal, returns +oo else 0 -- TODO also match on isn in case ports got reused foldl (\acc toAdd -> acc + 10 * fromEnum toAdd) (0 :: Int) [ conTcpClientIp con1 == conTcpClientIp con2 , conTcpClientPort con1 == conTcpClientPort con2 , conTcpServerIp con1 == conTcpServerIp con2 , conTcpServerPort con1 == conTcpServerPort con2 ] instance StreamConnection TcpConnection Tcp where showConnectionText = showTcpConnectionText buildFrameFromStreamId = buildTcpConnectionFromStreamId similarityScore = scoreTcpCon -- | Computes a score scoreMptcpCon :: MptcpConnection -> MptcpConnection -> Int scoreMptcpCon con1 con2 = let keyScore = if con1 ^. mpconServerConfig ^. mecKey == con2 ^. mpconServerConfig ^. mecKey && con1 ^. mpconClientConfig ^. mecKey == con2 ^. mpconClientConfig ^. mecKey then 200 else 0 in keyScore instance StreamConnection MptcpConnection Mptcp where showConnectionText = showMptcpConnectionText buildFrameFromStreamId = buildMptcpConnectionFromStreamId similarityScore = scoreMptcpCon instance StreamConnection MptcpSubflow Tcp where showConnectionText = showMptcpSubflowText buildFrameFromStreamId = buildSubflowFromTcpStreamId -- TODO use score as well similarityScore sf1 sf2 = similarityScore (sfConn sf1) (sfConn sf2) -- |Show the subflow (ids) showMptcpSubflowText :: MptcpSubflow -> Text showMptcpSubflowText sf = showConnectionText (sfConn sf) <> " (Local/Remote ids: " <> tshow (sfLocalId sf) <> "/" <> tshow (sfRemoteId sf) <> ", token " <> tshow (sfJoinToken sf) <> ")" -- TODO add sthg in case it's the master subflow ? showConnection :: StreamConnection a b => a -> String showConnection = T.unpack . showConnectionText