diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,12 @@ +0.0.3-dev: +- add --filter flag to filter connections from a json file +- add a --log-level flag -0.0.2-dev: +0.0.2: +- saves to .json (--out argument) +- accepts path to run a 3rd-party program (--optimizer) +- can filter connections +- addition of 0.0.1: - addition of 100s of bugs diff --git a/Net/Bitset.hs b/Net/Bitset.hs new file mode 100644 --- /dev/null +++ b/Net/Bitset.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE DefaultSignatures #-} +module Net.Bitset +where +import Data.Bits +import Control.Monad + +class ToBitMask a where + toBitMask :: a -> Int + -- | Using a DefaultSignatures extension to declare a default signature with + -- an `Enum` constraint without affecting the constraints of the class itself. + default toBitMask :: Enum a => a -> Int + toBitMask = shiftL 1 . fromEnum + +instance ( ToBitMask a ) => ToBitMask [a] where + toBitMask = foldr (.|.) 0 . map toBitMask + +-- | Not making this a typeclass, since it already generalizes over all +-- imaginable instances with help of `MonadPlus`. +fromBitMask :: + ( MonadPlus m, Enum a, Bounded a, ToBitMask a ) => + Int -> m a +fromBitMask bm = msum $ map asInBM $ enumFrom minBound + where + asInBM a = if isInBitMask bm a then return a else mzero + +isInBitMask :: ( ToBitMask a ) => Int -> a -> Bool +isInBitMask bm a = let aBM = toBitMask a in aBM == aBM .&. bm diff --git a/Net/IPAddress.hs b/Net/IPAddress.hs --- a/Net/IPAddress.hs +++ b/Net/IPAddress.hs @@ -1,8 +1,4 @@ -- | --- Module : Ip --- Copyright : teto 2019 --- License : GPL3 --- -- Description -- {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -13,25 +9,11 @@ import Net.IPv6 import Data.Serialize.Get import Data.Serialize.Put --- import Data.Word (Word32) -import Data.ByteString (ByteString) --- import Data.Either (fromRight) +import Data.ByteString import System.Linux.Netlink.Constants as NLC --- for replicateM import Control.Monad - --- check ip link / localhost seems to be 1 --- global interface index --- TODO should remove --- localhostIntfIdx :: Word32 --- localhostIntfIdx = 1 - --- TODO should consult --- getInterfaceIdFromIP :: IP -> Word32 --- getInterfaceIdFromIP ip = --- 1 getIPv4FromByteString :: ByteString -> Either String IPv4 getIPv4FromByteString val = diff --git a/Net/Mptcp.hs b/Net/Mptcp.hs --- a/Net/Mptcp.hs +++ b/Net/Mptcp.hs @@ -39,19 +39,14 @@ import Net.IPv4 import Net.IPv6 import Net.Mptcp.Constants --- import Data.Text --- import Data.Set () import qualified Data.Set as Set --- in package Unique-0.4.7.6 --- import Data.List.Unique import Data.Aeson import GHC.Generics --- import Data.Default +import Control.Monad.Trans.State () --- how can I retreive the word16 without pattern matching ? data MptcpSocket = MptcpSocket NetlinkSocket Word16 instance Show MptcpSocket where - show sock = let (MptcpSocket nlSock fid) = sock in ("Mptcp netlink socket: " ++ show fid) + show sock = let (MptcpSocket _ fid) = sock in ("Mptcp netlink socket: " ++ show fid) type MptcpPacket = GenlPacket NoData @@ -62,22 +57,17 @@ -- , metrics :: [SockDiagExtension] -- } --- |Data to hold MPTCP level information --- TODO use Data.Set +-- |Holds MPTCP level information data MptcpConnection = MptcpConnection { connectionToken :: MptcpToken -- use SubflowWithMetrics instead ?! -- , subflows :: Set.Set [TcpConnection] , subflows :: Set.Set TcpConnection - -- TODO convert to Data.Set ? - -- , localIds :: [Word8] -- ^ Announced addresses - -- , remoteIds :: [Word8] -- ^ Announced addresses , localIds :: Set.Set Word8 -- ^ Announced addresses , remoteIds :: Set.Set Word8 -- ^ Announced addresses -- Might be reworked/moved in an Enriched/Tracker structure afterwards - -- , tcpMetrics :: Maybe [SockDiagExtension] -- ^Metrics retrieved from kernel - , get_caps_prog :: FilePath + , get_caps_prog :: Maybe FilePath } deriving (Show, Generic) -- | Remote port @@ -88,13 +78,11 @@ } --- data MptcpAttributes = Map.Map MptcpAttr MptcpAttribute - remoteIdFromAttributes :: Attributes -> RemoteId remoteIdFromAttributes attrs = let (SubflowDestPort dport) = fromJust $ makeAttributeFromMaybe MPTCP_ATTR_DPORT attrs - (SubflowFamily family) = fromJust $ makeAttributeFromMaybe MPTCP_ATTR_FAMILY attrs + -- (SubflowFamily _) = fromJust $ makeAttributeFromMaybe MPTCP_ATTR_FAMILY attrs SubflowDestAddress destIp = ipFromAttributes False attrs -- (SubflowDestPort dport) = fromJust $ makeAttributeFromMaybe MPTCP_ATTR_DPORT attrs @@ -121,33 +109,13 @@ ] --- --- instance ToJSON SubflowWithMetrics where --- toJSON sf = object [ --- (pack (nameFromTcpConnection $ subflowSubflow sf) .= object [ - --- "cwnd" .= toJSON (20 :: Int), --- -- for now hardcode mss ? we could set it to one to make --- "mss" .= toJSON (1500 :: Int), --- "var" .= toJSON (10 :: Int), --- "fowd" .= toJSON (10 :: Int), --- "bowd" .= toJSON (10 :: Int), --- "loss" .= toJSON (0.5 :: Float) --- -- This is an user preference, that should be pushed when calling mptcpnumerics --- -- , "contribution": 0.5 --- ]) --- ] - - -- |Adds a subflow to the connection --- use sets instead ? -- TODO compose with mptcpConnAddLocalId mptcpConnAddSubflow :: MptcpConnection -> TcpConnection -> MptcpConnection mptcpConnAddSubflow mptcpConn sf = -- trace ("Adding subflow" ++ show sf) mptcpConnAddLocalId (mptcpConnAddRemoteId - -- (mptcpConn { subflows = sf : subflows mptcpConn }) (mptcpConn { subflows = Set.insert sf (subflows mptcpConn) }) (remoteId sf) ) @@ -166,7 +134,6 @@ -- |Add remote id --- Le remote id doit etre associee a une addresse / TODO test protocol mptcpConnAddRemoteId :: MptcpConnection -> Word8 -- ^Remote id to add -> MptcpConnection @@ -191,7 +158,7 @@ -- The message type/ flag / sequence number / pid (0 => from the kernel) -- https://elixir.bootlin.com/linux/latest/source/include/uapi/linux/netlink.h#L54 fixHeader :: MptcpSocket -> Bool -> MptcpPacket -> MptcpPacket -fixHeader (MptcpSocket _ fid) dump pkt = let +fixHeader _ dump pkt = let myHeader = Header 0 (flags .|. fNLM_F_ACK) 0 0 flags = if dump then fNLM_F_REQUEST .|. fNLM_F_MATCH .|. fNLM_F_ROOT else fNLM_F_REQUEST in @@ -310,7 +277,7 @@ w32 = getIPv4 ip genV6SubflowAddress :: MptcpAttr -> IPv6 -> (Int, ByteString) -genV6SubflowAddress addr = undefined +genV6SubflowAddress _addr = undefined mptcpListToAttributes :: [MptcpAttribute] -> Attributes mptcpListToAttributes attrs = Map.fromList $Prelude.map attrToPair attrs @@ -379,21 +346,9 @@ e2M (Right x) = Just x e2M _ = Nothing --- un peu bidon --- convertAttributesIntoList :: Attributes -> [MptcpAttribute] --- convertAttributesIntoList attrs = let --- customMakeAttribute key val accum = [fromJust (makeAttribute key val)] ++ accum --- in --- -- foldrWithKey." => (k -> a -> b -> b) -> b -> Map k a -> b --- Map.foldrWithKey (customMakeAttribute) [] attrs - convertAttributesIntoMap :: Attributes -> Map.Map MptcpAttr MptcpAttribute convertAttributesIntoMap attrs = let --- traverseWithKey --- fromJust customFn k val = fromJust (makeAttribute k val) - -- fromJust $ makeAttribute - -- (k -> a -> b) -> Map k a -> Map k b newMap = Map.mapWithKey (customFn) attrs in Map.mapKeys (toEnum) newMap @@ -467,20 +422,17 @@ -- REQUIRES: LOC_ID / TOKEN -- TODO pass TcpConnection resetConnectionPkt :: MptcpSocket -> [MptcpAttribute] -> MptcpPacket -resetConnectionPkt (MptcpSocket sock fid) attrs = let - cmd = MPTCP_CMD_REMOVE +resetConnectionPkt (MptcpSocket _sock fid) attrs = let + _cmd = MPTCP_CMD_REMOVE in assert (hasLocAddr attrs) $ genMptcpRequest fid MPTCP_CMD_REMOVE False attrs --- TODO map an IP to an interface -- pass token ? --- TODO can we retreive ips as well ?! subflowAttrs :: TcpConnection -> [MptcpAttribute] subflowAttrs con = [ LocalLocatorId $ localId con , RemoteLocatorId $ remoteId con - -- TODO adapt , SubflowFamily $ getAddressFamily (dstIp con) , SubflowDestAddress $ dstIp con , SubflowDestPort $ dstPort con @@ -492,17 +444,13 @@ ] -- |Generate a request to create a new subflow --- TODO capCwndPkt :: MptcpSocket -> MptcpConnection -> Word32 -- ^Limit to apply to congestion window -> TcpConnection -> MptcpPacket -capCwndPkt (MptcpSocket sock fid) mptcpCon limit sf = +capCwndPkt (MptcpSocket _ fid) mptcpCon limit sf = assert (hasFamily attrs) pkt where oldPkt = genMptcpRequest fid MPTCP_CMD_SND_CLAMP_WINDOW False attrs - -- TODO maybe cleanup interface after that: try to update Header - -- messageSeqNum = - -- messagePID pkt = oldPkt { packetHeader = (packetHeader oldPkt) { messagePID = 42 } } attrs = connectionAttrs mptcpCon ++ [ SubflowMaxCwnd limit ] @@ -513,17 +461,11 @@ connectionAttrs con = [ MptcpAttrToken $ connectionToken con ] -- sport/backup/intf are optional --- family /loc id/remid/daddr/dport --- TODO pass new subflow ? --- should get rid of MptcpSocket [MptcpAttribute] -> newSubflowPkt :: MptcpSocket -> MptcpConnection -> TcpConnection -> MptcpPacket -newSubflowPkt (MptcpSocket sock fid) mptcpCon sf = let - cmd = MPTCP_CMD_SUB_CREATE +newSubflowPkt (MptcpSocket _ fid) mptcpCon sf = let + _cmd = MPTCP_CMD_SUB_CREATE attrs = connectionAttrs mptcpCon ++ subflowAttrs sf pkt = genMptcpRequest fid MPTCP_CMD_SUB_CREATE False attrs in assert (hasFamily attrs) pkt - --- announceLocalIdPkt :: --- announceLocalIdPkt = diff --git a/Net/Mptcp/PathManager.hs b/Net/Mptcp/PathManager.hs --- a/Net/Mptcp/PathManager.hs +++ b/Net/Mptcp/PathManager.hs @@ -35,7 +35,7 @@ import System.Linux.Netlink as NL import Debug.Trace import Control.Concurrent -import System.Linux.Netlink.Constants (eRTM_NEWADDR) +-- import System.Linux.Netlink.Constants (eRTM_NEWADDR) import System.Linux.Netlink.Constants as NLC -- import qualified System.Linux.Netlink.Simple as NLS import Data.ByteString (ByteString, empty) diff --git a/Net/SockDiag.hs b/Net/SockDiag.hs --- a/Net/SockDiag.hs +++ b/Net/SockDiag.hs @@ -19,6 +19,8 @@ , loadExtension , showExtension , connectionFromDiag + -- WARN dont use it will be removed + , enumsToWord ) where -- import Generated @@ -41,15 +43,13 @@ import qualified Data.Bits as B import Data.Bits ((.|.)) import qualified Data.Map as Map -import Data.ByteString () +import Data.ByteString (ByteString, pack) import Data.ByteString.Char8 as C8 (unpack, init) import Net.IPAddress import Net.IP () -- import Net.IPv4 import Net.Tcp -import Net.Tcp.Constants import Net.SockDiag.Constants -import Data.ByteString (ByteString, pack, ) -- -- import Data.BitSet.Word @@ -97,7 +97,7 @@ shiftL state = B.shiftL 1 (fromEnum state) instance Enum2Bits SockDiagExtensionId where - shiftL state = B.shiftL 1 ((fromEnum state) - 1) + shiftL state = B.shiftL 1 (fromEnum state - 1) @@ -124,7 +124,6 @@ , idiag_inode :: Word32 } deriving (Eq, Show) --- see https://stackoverflow.com/questions/8633470/illegal-instance-declaration-when-declaring-instance-of-isstring {-# LANGUAGE FlexibleInstances #-} -- TODO this generates the error "Orphan instance: instance Convertable [TcpState]" @@ -180,7 +179,7 @@ states <- getWord32host _sockid <- getInetDiagSockid -- TODO reestablish states - return $ SockDiagRequest addressFamily protocol + return $ SockDiagRequest addressFamily protocol (wordToEnums extended :: [SockDiagExtensionId]) (wordToEnums states :: [TcpState]) _sockid -- |'Put' function for 'GenlHeader' @@ -281,9 +280,11 @@ {-| Different answers described in include/uapi/linux/inet_diag.h +Please keep the spacing the same as -} data SockDiagExtension = -- | Exact copy of kernel's struct tcp_info + -- tcp_diag_get_info DiagTcpInfo { tcpi_state :: Word8, tcpi_ca_state :: Word8, @@ -291,10 +292,10 @@ tcpi_probes :: Word8, tcpi_backoff :: Word8, tcpi_options :: Word8, - tcpi_wscales :: Word8, - -- tcpi_snd_wscale : 4, tcpi_rcv_wscale : 4 :: Word8, + tcpi_wscales :: Word8 -- ^both sender and receiver on 4 bits + , tcpi_delivery_rate_app_limited :: Word8 -- ^but only first bit used - tcpi_rto :: Word32, + , tcpi_rto :: Word32, tcpi_ato :: Word32, tcpi_snd_mss :: Word32, tcpi_rcv_mss :: Word32, @@ -307,12 +308,11 @@ -- Time tcpi_last_data_sent :: Word32, - -- Not remembered, sorr tcpi_last_ack_sent :: Word32, tcpi_last_data_recv :: Word32, tcpi_last_ack_recv :: Word32, - -- Metric + -- Metric tcpi_pmtu :: Word32, tcpi_rcv_ssthresh :: Word32, tcpi_rtt :: Word32, @@ -321,19 +321,48 @@ tcpi_snd_cwnd :: Word32, tcpi_advmss :: Word32, tcpi_reordering :: Word32, + tcpi_rcv_rtt :: Word32, - tcpi_rcv_space :: Word32, - tcpi_total_retrans :: Word32, + tcpi_rcv_space :: Word32 + , tcpi_total_retrans :: Word32 + + , tcpi_pacing_rate :: Word64 + , tcpi_max_pacing_rate :: Word64 + , tcpi_bytes_acked :: Word64 + , tcpi_bytes_received :: Word64 + , tcpi_segs_out :: Word32 + , tcpi_segs_in :: Word32 + + , tcpi_notsent_bytes :: Word32 + , tcpi_min_rtt :: Word32 + , tcpi_data_segs_in :: Word32 + , tcpi_data_segs_out :: Word32 + + , tcpi_delivery_rate :: Word64 + + , tcpi_busy_time :: Word64 + , tcpi_rwnd_limited :: Word64 + , tcpi_sndbuf_limited :: Word64 + + , tcpi_delivered :: Word32 + , tcpi_delivered_ce :: Word32 + + , tcpi_bytes_sent :: Word64 + , tcpi_bytes_retrans :: Word64 + , tcpi_dsack_dups :: Word32 + , tcpi_reord_seen :: Word32 + -- Extended version, hoping it doesn't break too much stuff - tcpi_fowd :: Word32, - tcpi_bowd :: Word32 + , tcpi_snd_cwnd_clamp :: Word32 + , tcpi_fowd :: Word32 + , tcpi_bowd :: Word32 } | DiagExtensionMemInfo { - idiag_rmem :: Word32 -, idiag_wmem :: Word32 -, idiag_fmem :: Word32 -, idiag_tmem :: Word32 + idiag_rmem :: Word32 -- ^ Amount of data in the receive queue. +, idiag_wmem :: Word32 -- ^ amount of data that is queued by TCP but not yet sent. +, idiag_fmem :: Word32 -- ^ amount of memory scheduled for future use +, idiag_tmem :: Word32 -- ^ amount of data in send queue. } | -- | Not exclusive to Vegas unlike the name indicates, mirrors tcpvegas_info TcpVegasInfo { @@ -375,12 +404,43 @@ getDiagTcpInfo :: Get SockDiagExtension -getDiagTcpInfo = - DiagTcpInfo <$> getWord8 <*> getWord8 <*> getWord8 <*> getWord8 <*> getWord8 <*> getWord8 <*> getWord8 - <*> getWord32host <*>getWord32host <*>getWord32host <*>getWord32host <*>getWord32host <*>getWord32host <*>getWord32host <*>getWord32host <*>getWord32host <*>getWord32host <*>getWord32host <*>getWord32host <*>getWord32host <*>getWord32host <*>getWord32host <*>getWord32host <*>getWord32host <*>getWord32host <*>getWord32host <*>getWord32host <*>getWord32host <*>getWord32host <*>getWord32host <*>getWord32host - -- these 2 are to read the owds, it's an extra that can be removed depending on the kernel - <*>getWord32host<*>getWord32host +getDiagTcpInfo = DiagTcpInfo <$> getWord8 <*> getWord8 <*> getWord8 <*> getWord8 <*> getWord8 <*> getWord8 <*> getWord8 <*> getWord8 + <*> getWord32host <*> getWord32host <*> getWord32host <*> getWord32host + <*> getWord32host <*> getWord32host <*> getWord32host <*> getWord32host <*> getWord32host + -- times + <*> getWord32host <*> getWord32host <*> getWord32host <*> getWord32host + -- metrics + <*> getWord32host <*> getWord32host <*> getWord32host <*> getWord32host + <*> getWord32host <*> getWord32host <*> getWord32host <*> getWord32host + + <*> getWord32host <*> getWord32host + + -- tcpi_total_retrans + <*> getWord32host + + -- starts at tcpi_pacing_rate + <*> getWord64host <*> getWord64host <*> getWord64host <*> getWord64host + <*> getWord32host <*> getWord32host + + -- starts at tcpi_notsent_bytes + <*> getWord32host <*> getWord32host <*> getWord32host <*> getWord32host + + -- tpci_delivery_rate + <*> getWord64host + + <*> getWord64host <*> getWord64host<*> getWord64host + + -- tcpi_delivered + <*> getWord32host <*> getWord32host + + -- tcpi_bytes_sent + <*> getWord64host<*> getWord64host <*> getWord32host <*> getWord32host + + -- My custom addition to read the owds, it's an extra that should be removed + -- for a vanilla kernel + <*> getWord32host <*> getWord32host <*> getWord32host + -- Sends a SockDiagRequest -- expects INetDiag -- TODO should take an Mptcp connection into account @@ -449,9 +509,6 @@ InetDiagCong -> Just getCongInfo -- InetDiagNone -> Nothing InetDiagInfo -> Just getDiagTcpInfo - -- InetDiagInfo -> case runGet (getGet 42) value of - -- Right x -> Just x - -- _ -> Nothing InetDiagVegasinfo -> Just getTcpVegasInfo -- InetDiagTos -> Nothing -- InetDiagTclass -> Nothing @@ -481,5 +538,4 @@ Just getFn -> case runGet getFn value of Right x -> Just $ x Left err -> error $ "error decoding " ++ show eExtId ++ ":\n" ++ err - diff --git a/Net/Tcp.hs b/Net/Tcp.hs --- a/Net/Tcp.hs +++ b/Net/Tcp.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} {-| Module : TCP Description : Implementation of mptcp netlink path manager @@ -6,64 +7,14 @@ Portability : Linux -} -{-# LANGUAGE DeriveGeneric #-} module Net.Tcp ( - TcpConnection (..) - , Net.Tcp.reverse - , Net.Tcp.nameFromTcpConnection + module Net.Tcp.Definitions + , module Net.Tcp.Constants ) where - -import Net.IP -import Data.Aeson -import Data.Word (Word8, Word16, Word32) -import GHC.Generics - -{- - Hold informations - The equality implementation ignores several fields --} -data TcpConnection = TcpConnection { - -- TODO use libraries to deal with that ? filter from the command line for instance ? - srcIp :: IP -- ^Source ip - , dstIp :: IP -- ^Destination ip - , srcPort :: Word16 -- ^ Source port - , dstPort :: Word16 -- ^Destination port - , priority :: Maybe Word8 -- ^subflow priority - , localId :: Word8 -- ^ Convert to AddressFamily - , remoteId :: Word8 - -- TODO remove could be deduced from srcIp / dstIp ? - , subflowInterface :: Maybe Word32 -- ^Interface of Maybe ? why a maybe ? - -- add TcpMetrics member - -- , tcpMetrics :: Maybe [SockDiagExtension] -- ^Metrics retrieved from kernel - -} deriving (Show, Generic, Ord) - - -nameFromTcpConnection :: TcpConnection -> String -nameFromTcpConnection con = - show (srcIp con) ++ ":" ++ show (srcPort con) ++ " -> " ++ show (dstIp con) ++ ":" ++ show (dstPort con) - - -reverse :: TcpConnection -> TcpConnection -reverse con = TcpConnection { - srcIp = dstIp con - , dstIp = srcIp con - , srcPort = dstPort con - , dstPort = srcPort con - , priority = Nothing - , localId = remoteId con - , remoteId = localId con - , subflowInterface = Nothing -} +import Net.Tcp.Definitions +import Net.Tcp.Constants +import Net.Bitset -instance FromJSON TcpConnection -instance ToJSON TcpConnection - --- ignore the rest -instance Eq TcpConnection where - x == y = srcIp x == srcIp y && dstIp x == dstIp y - && srcPort x == srcPort y && dstPort x == dstPort y - -- /= = not == - +instance ToBitMask TcpFlag diff --git a/Net/Tcp/Definitions.hs b/Net/Tcp/Definitions.hs new file mode 100644 --- /dev/null +++ b/Net/Tcp/Definitions.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module Net.Tcp.Definitions ( + TcpConnection (..) + , ConnectionRole (..) + , reverseTcpConnection + , showTcpConnection +) + +where + +import Prelude +import Net.IP +import Data.Aeson +import Data.Word (Word8, Word16, Word32) +import GHC.Generics +import qualified Data.Text as TS + +{- Describe a TCP connection, possibly an Mptcp subflow + The equality implementation ignores several fields +-} +data TcpConnection = TcpConnection { + -- TODO use libraries to deal with that ? filter from the command line for instance ? + srcIp :: IP -- ^Source ip + , dstIp :: IP -- ^Destination ip + , srcPort :: Word16 -- ^ Source port + , dstPort :: Word16 -- ^Destination port + , priority :: Maybe Word8 -- ^subflow priority + , localId :: Word8 -- ^ Convert to AddressFamily + , remoteId :: Word8 + -- TODO remove could be deduced from srcIp / dstIp ? + , subflowInterface :: Maybe Word32 -- ^Interface of Maybe ? why a maybe ? + -- add TcpMetrics member + -- , tcpMetrics :: Maybe [SockDiagExtension] -- ^Metrics retrieved from kernel + +} deriving (Show, Generic, Ord) + +tshow :: Show a => a -> TS.Text +tshow = TS.pack . Prelude.show + +data ConnectionRole = Server | Client deriving (Show, Eq) + + +showTcpConnectionText :: TcpConnection -> TS.Text +showTcpConnectionText con = + showIp ( srcIp con) <> ":" <> tshow (srcPort con) <> " -> " <> showIp (dstIp con) <> ":" <> tshow (dstPort con) + where + showIp = Net.IP.encode + +showTcpConnection :: TcpConnection -> String +showTcpConnection = TS.unpack . showTcpConnectionText + + +reverseTcpConnection :: TcpConnection -> TcpConnection +reverseTcpConnection con = con { + srcIp = dstIp con + , dstIp = srcIp con + , srcPort = dstPort con + , dstPort = srcPort con + , priority = Nothing + , localId = remoteId con + , remoteId = localId con + , subflowInterface = Nothing +} + +instance FromJSON TcpConnection +instance ToJSON TcpConnection + +-- TODO create a specific function for it +-- ignore the rest +instance Eq TcpConnection where + x == y = srcIp x == srcIp y && dstIp x == dstIp y + && srcPort x == srcPort y && dstPort x == dstPort y + -- /= = not == + + diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,109 +1,55 @@ - -This is a rewrite in haskell of the python netlink module. -nix-shell -p 'haskellPackages.ghcWithHoogle(p: with p; [netlink optparse-applicative ])' - - -The netlink module asks for GENL_ADMIN_PERM => The operation requires the CAP_NET_ADMIN privilege - -sudo setcap cap_net_admin+ep hs/dist-newstyle/build/x86_64-linux/ghc-8.6.3/netlink-pm-1.0.0/x/daemon/build/daemon/daemon - -# Netlink explanation - -To fetch TCP diagnostics: -Creates a socket with family eNETLINK_INET_DIAG (really NETLINK_SOCK_DIAG) with value 4 -AF_INET => netlink family 2 +This is a userspace path manager for the [linux multipath TCP +kernel][mptcp-fork], starting from version v0.95. +This allows to monitor MPTCP connections and control what subflows to create and +with a custom kernel it can even set specific values for the congestion windows. # Compilation +For now we need a custom version of netlink With a custom netlink and kernel Compile the custom netlink library with ``` $ cabal configure --enable-library-profiling ``` +You may need some headers as well (NOTE: reference cabal.project instead): ``` kernel $ make headers_install -$ cabal configure --package-db /home/teto/netlink-hs/dist/package.conf.inplace --extra-include-dirs=/home/teto/mptcp2/build/usr/include -v3 --enable-profiling +$ cabal configure --package-db ~/netlink-hs/dist/package.conf.inplace --extra-include-dirs=~/mptcp/build/usr/include -v3 --enable-profiling ``` - -To compile the doc (and understand why HIE fails displaying anything) +To compile the doc (and understand why HLS fails displaying anything) `cabal haddock --all` # Usage -Enter the nix-shell shell-test.nix and start the daemon: - -$ cabal run daemon - -or -$ buildNRun -To print a stacktrace -cabal run daemon toto -- +RTS -xc - -In a shell: -`$ nix run nixpkgs.iperf -c iperf -s` - -In another: -`$ nix run nixpkgs.iperf -c iperf -c localhost -b 1KiB -t 4 --cport 5500 -4 -C -cubic` - - -Script to reload module - +The netlink module asks for `GENL_ADMIN_PERM` which requires the `CAP_NET_ADMIN` privilege. +You can assign this privilege via: ``` -reload_mod() { - newMod="$1" - - if [ -z "${newMod}" ]; then - echo "Use: " - echo "possibly /home/teto/mptcp2/build/net/mptcp/mptcp_netlink.ko" - fi -# 1. change to another scheduler - mppm "fullmesh" - sleep 1 -# 2. rmmod the current one - sudo rmmod "mptcp_netlink" - -# 3. Insert our new module - sleep 1 - sudo insmod "$1" - -# 4. restore path manager - mppm "netlink" - -} +sudo setcap cap_net_admin+ep hs/dist-newstyle/build/x86_64-linux/ghc-8.6.3/netlink-pm-1.0.0/x/daemon/build/daemon/daemon ``` - -# Testsuite -`$ ss -t -4 -i` - ss -o state established '( dport = :ssh or sport = :ssh )' -https://unix.stackexchange.com/questions/499190/where-is-the-official-documentation-debian-package-iproute-doc - -sudo insmod ~/mptcp/build/net/ipv4/tcp_cubic.ko +Enter the development shell and start the daemon: -# BUGS -- conversion of SockDiagExtensionId is bad everywhere ? req.r.idiag_ext |= (1<<(INET_DIAG_INFO-1)); +``` +$ nix develop +$ cabal run daemon +``` # TODO - remove the need for MptcpSocket everywhere: it's just needed to write the header, which could be added/modifier later instead ! (to increase purity in the library) -- replace Enum2Bits wordToEnums function, especially to fix getSockDiagRequestHeader -(with bitset package once it's fixed) - we need to better keep track of subflow status (established vs WIP) ? - pass local/server IPs as commands to the PM ? - generate completion scripts via --zsh-completion-script -Note: -ss package sends by default --- #define SS_ALL ((1 << SS_MAX) - 1) --- #define SS_CONN (SS_ALL & ~((1< + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version + * 2 of the License, or (at your option) any later version. + */ + +#ifndef _LINUX_MPTCP_H +#define _LINUX_MPTCP_H + +#define MPTCP_GENL_NAME "mptcp" +#define MPTCP_GENL_EV_GRP_NAME "mptcp_events" +#define MPTCP_GENL_CMD_GRP_NAME "mptcp_commands" +#define MPTCP_GENL_VER 0x1 + +/* + * ATTR types defined for MPTCP + */ +enum { + MPTCP_ATTR_UNSPEC = 0, + + MPTCP_ATTR_TOKEN, /* u32 */ + MPTCP_ATTR_FAMILY, /* u16 */ + MPTCP_ATTR_LOC_ID, /* u8 */ + MPTCP_ATTR_REM_ID, /* u8 */ + MPTCP_ATTR_SADDR4, /* u32 */ + MPTCP_ATTR_SADDR6, /* struct in6_addr */ + MPTCP_ATTR_DADDR4, /* u32 */ + MPTCP_ATTR_DADDR6, /* struct in6_addr */ + MPTCP_ATTR_SPORT, /* u16 */ + MPTCP_ATTR_DPORT, /* u16 */ + MPTCP_ATTR_BACKUP, /* u8 */ + MPTCP_ATTR_ERROR, /* u8 */ + MPTCP_ATTR_FLAGS, /* u16 */ + MPTCP_ATTR_TIMEOUT, /* u32 */ + MPTCP_ATTR_IF_IDX, /* s32 */ + MPTCP_ATTR_CWND, /* u32 */ + + __MPTCP_ATTR_AFTER_LAST +}; + +#define MPTCP_ATTR_MAX (__MPTCP_ATTR_AFTER_LAST - 1) + +/* + * Events generated by MPTCP: + * - MPTCP_EVENT_CREATED: token, family, saddr4 | saddr6, daddr4 | daddr6, + * sport, dport + * A new connection has been created. It is the good time to allocate + * memory and send ADD_ADDR if needed. Depending on the traffic-patterns + * it can take a long time until the MPTCP_EVENT_ESTABLISHED is sent. + * + * - MPTCP_EVENT_ESTABLISHED: token, family, saddr4 | saddr6, daddr4 | daddr6, + * sport, dport + * A connection is established (can start new subflows). + * + * - MPTCP_EVENT_CLOSED: token + * A connection has stopped. + * + * - MPTCP_EVENT_ANNOUNCED: token, rem_id, family, daddr4 | daddr6 [, dport] + * A new address has been announced by the peer. + * + * - MPTCP_EVENT_REMOVED: token, rem_id + * An address has been lost by the peer. + * + * - MPTCP_EVENT_SUB_ESTABLISHED: token, family, saddr4 | saddr6, + * daddr4 | daddr6, sport, dport, backup, + * if_idx [, error] + * A new subflow has been established. 'error' should not be set. + * + * - MPTCP_EVENT_SUB_CLOSED: token, family, saddr4 | saddr6, daddr4 | daddr6, + * sport, dport, backup, if_idx [, error] + * A subflow has been closed. An error (copy of sk_err) could be set if an + * error has been detected for this subflow. + * + * - MPTCP_EVENT_SUB_PRIORITY: token, family, saddr4 | saddr6, daddr4 | daddr6, + * sport, dport, backup, if_idx [, error] + * The priority of a subflow has changed. 'error' should not be set. + * + * Commands for MPTCP: + * - MPTCP_CMD_ANNOUNCE: token, loc_id, family, saddr4 | saddr6 [, sport] + * Announce a new address to the peer. + * + * - MPTCP_CMD_REMOVE: token, loc_id + * Announce that an address has been lost to the peer. + * + * - MPTCP_CMD_SUB_CREATE: token, family, loc_id, rem_id, [saddr4 | saddr6, + * daddr4 | daddr6, dport [, sport, backup, if_idx]] + * Create a new subflow. + * + * - MPTCP_CMD_SUB_DESTROY: token, family, saddr4 | saddr6, daddr4 | daddr6, + * sport, dport + * Close a subflow. + * + * - MPTCP_CMD_SUB_PRIORITY: token, family, saddr4 | saddr6, daddr4 | daddr6, + * sport, dport, backup + * Change the priority of a subflow. + * + * - MPTCP_CMD_SET_FILTER: flags + * Set the filter on events. Set MPTCPF_* flags to only receive specific + * events. Default is to receive all events. + * + * - MPTCP_CMD_EXIST: token + * Check if this token is linked to an existing socket. + */ +enum { + MPTCP_CMD_UNSPEC = 0, + + MPTCP_EVENT_CREATED, + MPTCP_EVENT_ESTABLISHED, + MPTCP_EVENT_CLOSED, + + MPTCP_CMD_ANNOUNCE, + MPTCP_CMD_REMOVE, + MPTCP_EVENT_ANNOUNCED, + MPTCP_EVENT_REMOVED, + + MPTCP_CMD_SUB_CREATE, + MPTCP_CMD_SUB_DESTROY, + MPTCP_EVENT_SUB_ESTABLISHED, + MPTCP_EVENT_SUB_CLOSED, + + MPTCP_CMD_SUB_PRIORITY, + MPTCP_EVENT_SUB_PRIORITY, + + MPTCP_CMD_SET_FILTER, + + MPTCP_CMD_EXIST, + MPTCP_CMD_SND_CLAMP_WINDOW, + + __MPTCP_CMD_AFTER_LAST +}; + +#define MPTCP_CMD_MAX (__MPTCP_CMD_AFTER_LAST - 1) + +enum { + MPTCPF_EVENT_CREATED = (1 << 1), + MPTCPF_EVENT_ESTABLISHED = (1 << 2), + MPTCPF_EVENT_CLOSED = (1 << 3), + MPTCPF_EVENT_ANNOUNCED = (1 << 4), + MPTCPF_EVENT_REMOVED = (1 << 5), + MPTCPF_EVENT_SUB_ESTABLISHED = (1 << 6), + MPTCPF_EVENT_SUB_CLOSED = (1 << 7), + MPTCPF_EVENT_SUB_PRIORITY = (1 << 8), +}; + +#endif /* _LINUX_MPTCP_H */ diff --git a/hs/daemon.hs b/hs/daemon.hs --- a/hs/daemon.hs +++ b/hs/daemon.hs @@ -4,82 +4,47 @@ Stability : testing Portability : Linux -Monitors new MPTCP connections and runs a specific monitor instance - -To interact -GENL_ADMIN_PERM -The operation requires the CAP_NET_ADMIN privilege - -Helpful links: +This userspace program is a complement to the linux MPTCP kernel developed at +https://github.com/multipath-tcp/mptcp -- inspired by https://stackoverflow.com/questions/6009384/exception-handling-in-haskell -- super nice tutorial on optparse applicative: https://github.com/pcapriotti/optparse-applicative#regular-options -- How to use Map https://lotz84.github.io/haskellbyexample/ex/maps -= How to update a single field https://stackoverflow.com/questions/14955627/shorthand-way-for-assigning-a-single-field-in-a-record-while-copying-the-rest-o -- get tcp stats via netlink https://www.vividcortex.com/blog/2014/09/22/using-netlink-to-optimize-socket-statistics/ -eNETLINK_INET_DIAG +The main daemon monitors MPTCP connections and for each new connection assigns a thread +to mino. -Concurrent values -- https://www.oreilly.com/library/view/parallel-and-concurrent/9781449335939/ch07.html -- https://stackoverflow.com/questions/22171895/using-tchan-with-timeout -- https://www.reddit.com/r/haskellquestions/comments/5rh1d4/concurrency_and_shared_state/ - -Mutable states: -- https://blog.jakuba.net/2014/07/20/Mutable-State-in-Haskell/ -- http://mainisusuallyafunction.blogspot.com/2011/10/safe-top-level-mutable-variables-for.html - -http://kristrev.github.io/2013/07/26/passive-monitoring-of-sockets-on-linux +The daemon main thread has 2 roles: +- monitors interface change (network interface addition/deletion) +- listens to +Monitors new MPTCP connections and runs a specific monitor instance +To interact +GENL_ADMIN_PERM +The operation requires the CAP_NET_ADMIN privilege iproute2/misc/ss.c to see how `ss` utility interacts with the kernel --- https://downloads.haskell.org/~ghc/latest/docs/html/libraries/process-1.6.5.0/System-Process.html - -Aeson tutorials: --- https://haskell.fpcomplete.com/library/aeson -- https://lotz84.github.io/haskellbyexample/ex/timers - -- https://lotz84.github.io/haskellbyexample/ex/maps - - -Useful functions in Map -- member / elemes / keys / assocs / keysSet / toList -} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Main where -import Prelude hiding (concat, init) -import Options.Applicative hiding (value, ErrorMsg, empty) -import qualified Options.Applicative (value) - --- For TcpState, FFI generated import Net.SockDiag import Net.Mptcp --- hiding(mapIPtoInterfaceIdx) import Net.Mptcp.PathManager import Net.Mptcp.PathManager.Default import Net.Tcp import Net.IP -import Net.IPv4 hiding (print) --- import Net.IPAddress - import Net.SockDiag.Constants -import Net.Tcp.Constants import Net.Mptcp.Constants - --- for readList -import Text.Read --- pack +import Text.Read (readMaybe) import Data.Text () - --- for replicateM +import Prelude hiding (concat, init) +import Options.Applicative hiding (value, ErrorMsg, empty) +import qualified Options.Applicative (value) +import Control.Monad.Trans (liftIO) +import Control.Monad.Trans.State (State, StateT, put, get, + execStateT) import Control.Monad (foldM) --- fromMaybe, import Data.Maybe (catMaybes) --- import Data.Foldable (concat) import Foreign.C.Types (CInt) -- for eOK, ePERM import Foreign.C.Error @@ -89,126 +54,68 @@ import System.Linux.Netlink.Constants as NLC -- import System.Linux.Netlink.Constants (eRTM_NEWADDR) -- import System.Linux.Netlink.Helpers -import System.Log.FastLogger +-- import System.Log.FastLogger import System.Linux.Netlink.GeNetlink.Control import qualified System.Linux.Netlink.Simple as NLS import qualified System.Linux.Netlink.Route as NLR import System.Process import System.Exit -import Data.Word (Word16, Word32) +import Data.Word (Word32) -- import qualified Data.Bits as Bits -- (shiftL, ) -- import Data.Bits ((.|.)) import Data.Serialize.Get (runGet) import Data.Serialize.Put -- import Data.Either (fromRight) import Data.ByteString (ByteString) -import Data.ByteString.Lazy (writeFile) --- import Data.ByteString.Char8 (unpack, init) --- import System.Posix. - --- import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy as BL import qualified Data.Map as Map import qualified Data.Set as Set - -import qualified Data.Text +-- import qualified Data.Text import Data.Bits (Bits(..)) - --- https://hackage.haskell.org/package/bytestring-conversion-0.1/candidate/docs/Data-ByteString-Conversion.html#t:ToByteString --- contains ToByteString / FromByteString --- import Data.ByteString.Conversion import Debug.Trace --- import Control.Exception - import Control.Concurrent --- import Control.Exception (assert) --- import Control.Concurrent.Chan --- import Data.IORef --- import Control.Concurrent.Async -import System.IO.Unsafe +-- import System.IO.Unsafe import System.IO.Temp () --- for takeFilename import System.FilePath () - --- , Handle +import Numeric.Natural import System.IO (stderr) import Data.Aeson -- to merge MptcpConnection export and Metrics import Data.Aeson.Extra.Merge (lodashMerge) - -import Data.Aeson.Encode.Pretty (encodePretty) --- import GHC.Generics +import GHC.List (init) -- for getEnvDefault, to get TMPDIR value. -- we could pass it as an argument -- import System.Environment.Blank(getEnvDefault) --- trying hslogger import System.Log.Logger ( - -- rootLoggerName infoM , debugM + , errorM , Priority(DEBUG) , Priority(INFO) , setLevel, updateGlobalLogger + , setHandlers + , rootLoggerName + -- , saveGlobalLogger + -- , addHandler ) import System.Log.Handler.Simple ( - streamHandler - -- , GenericHandler + verboseStreamHandler ) --- for writeUTF8File --- import Distribution.Simple.Utils --- import Distribution.Utils.Generic --- import System.Log.Handler (setFormatter) --- STM = State Thread Monad ST monad --- import Data.IORef --- MVar can be empty contrary to IORef ! --- globalMptcpSock :: IORef MptcpSocket --- from unordered containers --- import qualified Data.HashMap.Lazy as HML -import qualified Data.HashMap.Strict as HM -{-# NOINLINE globalMptcpSock #-} -globalMptcpSock :: MVar MptcpSocket -globalMptcpSock = unsafePerformIO newEmptyMVar --- du coup cette socket n'aurait meme plus besoin d'etre globale en fait ? - --- TODO remove --- globalMetricsSock :: MVar NetlinkSocket --- globalMetricsSock = unsafePerformIO newEmptyMVar - --- {-# NOINLINE globalInterfaces #-} --- globalInterfaces :: MVar AvailablePaths --- globalInterfaces = unsafePerformIO newEmptyMVar - -iperfClientPort :: Word16 -iperfClientPort = 5500 - -iperfServerPort :: Word16 -iperfServerPort = 5201 - --- | -onSuccessSleepingDelay :: Int -onSuccessSleepingDelay = 300 +-- |Delay between 2 successful loggings +onSuccessSleepingDelayMs :: Natural +onSuccessSleepingDelayMs = 300 --- When it couldn't set the correct value -onFailureSleepingDelay :: Int +-- | When it couldn't set the correct value +onFailureSleepingDelay :: Natural onFailureSleepingDelay = 100 --- should be able to ignore based on regex --- TODO see interfacesToIgnore --- interfacesToIgnore :: [String] --- interfacesToIgnore = [ --- "virbr0" --- , "virbr1" --- , "nlmon0" --- , "ppp0" --- , "lo" --- ] - --- |the path manager used in the +-- |the default path manager pathManager :: PathManager pathManager = meshPathManager @@ -219,81 +126,50 @@ , connections :: Map.Map MptcpToken (ThreadId, MVar MptcpConnection) -- |Arguments passed to the program , cliArguments :: CLIArguments -} --- https://stackoverflow.com/questions/51407547/how-to-update-a-field-of-a-json-object -addJsonKey :: Data.Text.Text -> Value -> Value -> Value -addJsonKey key val (Object xs) = Object $ HM.insert key val xs -addJsonKey _ _ xs = xs - -authorizedCon1 :: TcpConnection -authorizedCon1 = TcpConnection { - srcIp = fromIPv4 $ Net.IPv4.ipv4 192 168 0 128 - , dstIp = fromIPv4 $ Net.IPv4.ipv4 202 214 86 51 - , srcPort = iperfClientPort - , dstPort = iperfServerPort - , priority = Nothing - , subflowInterface = Nothing - , localId = 0 - , remoteId = 0 - } + -- |Connections to accept, loaded via cli's --filter + , filteredConnections :: Maybe [TcpConnection] +} -authorizedCon2 :: TcpConnection -authorizedCon2 = authorizedCon1 { srcIp = fromIPv4 $ Net.IPv4.ipv4 192 168 0 130 } + -- https://stackoverflow.com/questions/3640120/combine-state-with-io-actions +type GState a = State MyState a -filteredConnections :: [TcpConnection] -filteredConnections = [ - authorizedCon1 - ] +-- https://stackoverflow.com/questions/51407547/how-to-update-a-field-of-a-json-object +-- addJsonKey :: Data.Text.Text -> Value -> Value -> Value +-- addJsonKey key val (Object xs) = Object $ HM.insert key val xs +-- addJsonKey _ _ xs = xs --- inspired by CtrlPacket - -- token :: MptcpToken --- MptcpNewConnection --- data MptcpPacket = MptcpPacket { --- mptcpHeader :: Header --- , mptcpGeHeader :: GenlHeader --- , mptcpData :: MptcpData - --- data MptcpData = MptcpData { --- mptcpAttributes :: [MptcpAttr] --- } deriving (Eq) - --- TODO are they generated dumpCommand :: MptcpGenlEvent -> String dumpCommand x = show x ++ " = " ++ show (fromEnum x) --- dumpCommand MPTCP_CMD_UNSPEC = " MPTCP_CMD_UNSPEC 0" --- dumpCommand MPTCP_EVENT_SUB_ERROR = show MPTCP_EVENT_SUB_ERROR + show fromEnum MPTCP_EVENT_SUB_ERROR dumpMptcpCommands :: MptcpGenlEvent -> String dumpMptcpCommands MPTCP_CMD_EXIST = dumpCommand MPTCP_CMD_EXIST dumpMptcpCommands x = dumpCommand x ++ "\n" ++ dumpMptcpCommands (succ x) --- todo use it as a filter data CLIArguments = CLIArguments { - -- | useless - command :: String - , serverIP :: IPv4 -- | Path to a program in charge of generating congestion window limits on a -- per path basis -- The program will be called with a json file as input and must echo on stdout -- an array of the form [ 10, 30, 40] - , optimizer :: FilePath + optimizer :: Maybe FilePath + -- | to filter + , filter :: Maybe FilePath + -- | Folder where to log files , out :: FilePath -- , clientIP :: IPv4 , quiet :: Bool - , enthusiasm :: Int + + -- Priority + , logLevel :: Priority } --- TODO use 3rd party library levels --- data Verbosity = Normal | Debug - loggerName :: String loggerName = "main" @@ -301,7 +177,7 @@ dumpSystemInterfaces = do putStrLn "Dumping interfaces" -- isEmptyMVar globalInterfaces - res <- tryReadMVar globalInterfaces + res <- tryReadMVar globalInterfaces case res of Nothing -> putStrLn "No interfaces" Just interfaces -> Prelude.print interfaces @@ -309,30 +185,17 @@ putStrLn "End of dump" --- TODO register subcommands instead --- see https://stackoverflow.com/questions/31318643/optparse-applicative-how-to-handle-no-arguments-situation-in-arrow-syntax --- ( command "add" (info addOptions ( progDesc "Add a file to the repository" )) - -- <> command "commit" (info commitOptions ( progDesc "Record changes to the repository" )) --- can use several constructors depending on the PM ? --- ByteString sample :: Parser CLIArguments sample = CLIArguments - <$> argument str - ( metavar "CMD" - <> help "What to do" ) - -- TODO should accept hostname etc - <*> argument (eitherReader $ \x -> case (Net.IPv4.decodeString x) of - Nothing -> Left "could not parse" - Just ip -> Right ip) - ( metavar "ServerIP" - <> help "ServerIP to let through (e.g.: 202.214.86.51 )" ) - <*> strOption + <$> (optional $ strOption ( long "optimizer" <> short 'p' <> help "Path to the userspace program" - <> showDefault - <> Options.Applicative.value "fake_solver" - <> metavar "PROGRAM" ) + <> metavar "PROGRAM" )) + <*> (optional $ strOption + ( long "filter" + <> help "Path to a json file describing a TCP connection" + <> metavar "Filter" )) <*> strOption ( long "out" <> short 'o' @@ -345,11 +208,11 @@ <> short 'v' <> help "Whether to be quiet" ) <*> option auto - ( long "enthusiasm" - <> help "How enthusiastically to greet" + ( long "log-level" + <> help "Log level" <> showDefault - <> Options.Applicative.value 1 - <> metavar "INT" ) + <> Options.Applicative.value INFO + <> metavar "LOG_LEVEL" ) opts :: ParserInfo CLIArguments @@ -374,104 +237,113 @@ Just fid -> return (MptcpSocket sock (trace ("family id"++ show fid ) fid)) --- Used tuples --- sock <- makeSocket + makeMetricsSocket :: IO NetlinkSocket -makeMetricsSocket = do - -- NETLINK_SOCK_DIAG == NETLINK_INET_DIAG - sock <- makeSocketGeneric eNETLINK_SOCK_DIAG - return sock +makeMetricsSocket = makeSocketGeneric eNETLINK_SOCK_DIAG --- used in tests -startMonitorExternalProcess :: MptcpToken -> CreateProcess -startMonitorExternalProcess token = - let - params = proc "daemon" [ show token ] - -- todo pass the token via the environment - newParams = params { - -- cmdspec = RawCommand "monitor" [ show token ] - new_session = True - -- cwd - -- env - } - in - -- return "toto" - newParams -- A utility function - threadDelay takes microseconds, which is slightly annoying. -sleepMs :: Int -> IO() -sleepMs n = threadDelay (n * 1000) +sleepMs :: Natural -> IO() +sleepMs n = threadDelay $ (fromIntegral n :: Int) * 1000 + -- | here we may want to run mptcpnumerics to get some results updateSubflowMetrics :: NetlinkSocket -> TcpConnection -> IO SockDiagMetrics updateSubflowMetrics sockMetrics subflow = do putStrLn "Updating subflow metrics" let queryPkt = genQueryPacket (Right subflow) [TcpListen, TcpEstablished] + [InetDiagCong, InetDiagInfo, InetDiagMeminfo] sendPacket sockMetrics queryPkt - putStrLn "Sent the TCP SS request" - -- exported from my own version !! - -- TODO display number of answers + putStrLn "Sent the TCP SS request" putStrLn "Starting inspecting answers" + answers <- recvMulti sockMetrics let metrics_m = inspectIdiagAnswers answers -- filter ? keep only valud ones ? return $ head (catMaybes metrics_m) - -- putStrLn "Finished inspecting answers" +isFlagSet :: Bits a => a -> a -> Bool +isFlagSet f v = (f .&. v) == f +-- Copy/pasted from System.Linux.Netlink +-- |Internal function to receive multiple netlink messages +recvMulti :: (Convertable a, Eq a, Show a) => NetlinkSocket -> IO [Packet a] +recvMulti sock = do + pkts <- recvOne sock + if isMulti (first pkts) + then if isDone (last pkts) + -- This is fine because first would have complained before + then return $ init pkts + else (pkts ++) <$> recvMulti sock + else return pkts + where + isMulti = isFlagSet fNLM_F_MULTI . messageFlags . packetHeader + isDone = (== eNLMSG_DONE) . messageType . packetHeader + first (x:_) = x + first [] = error "Got empty list from recvOne in recvMulti, this shouldn't happen" + {- | Starts monitoring a specific MPTCP connection Maybe should expect a pathManager instance (and logger FilePath -- ^Path towards the program to get cwnd limits -} -startMonitorConnection :: FilePath -- ^ Where to write files +startMonitorConnection :: CLIArguments + -- | elapsed time since starting the thread (very coarse approximation) + -> Natural -> MptcpSocket -> NetlinkSocket -> MVar MptcpConnection -> IO () -startMonitorConnection tmpdir mptcpSock sockMetrics mConn = do - let (MptcpSocket sock familyId) = mptcpSock +startMonitorConnection cliArgs elapsed mptcpSock sockMetrics mConn = do + let (MptcpSocket sock _) = mptcpSock myId <- myThreadId - putStr $ show myId ++ "Start monitoring connection..." + putStr $ show myId ++ ": monitoring connection at *time* " ++ show elapsed ++ " ..." -- as long as conn is not empty we keep going ? -- for this connection -- query metrics for the whole MPTCP connection - con <- readMVar mConn + mptcpConn <- readMVar mConn putStrLn "Showing MPTCP connection" - putStrLn $ show con ++ "..." - let token = connectionToken con + putStrLn $ show mptcpConn ++ "..." + let _token = connectionToken mptcpConn + let tmpdir = out cliArgs -- TODO this is the issue -- not sure it's the master with a set - let masterSf = Set.elemAt 0 (subflows con) + let _masterSf = Set.elemAt 0 (subflows mptcpConn) -- Get updated metrics - lastMetrics <- mapM (updateSubflowMetrics sockMetrics) (Set.toList $ subflows con) + lastMetrics <- mapM (updateSubflowMetrics sockMetrics) (Set.toList $ subflows mptcpConn) + let filename = tmpdir ++ "/" ++ "mptcp_" ++ show (connectionToken mptcpConn) ++ "_" ++ show elapsed ++ ".json" + -- logStatistics filename elapsed mptcpConn lastMetrics - putStrLn "Running mptcpnumerics" + duration <- case optimizer cliArgs of + Nothing -> return onSuccessSleepingDelayMs + Just program -> do - -- Then refresh the cwnd objective - cwnds_m <- getCapsForConnection tmpdir con lastMetrics - case cwnds_m of - Nothing -> do - putStrLn "Couldn't fetch the values" - sleepMs onFailureSleepingDelay - Just cwnds -> do + debugM "main" "Calling third party program" - putStrLn $ "Requesting to set cwnds..." ++ show cwnds - -- TODO fix - -- KISS for now (capCwndPkt mptcpSock ) - let cwndPackets = map (\(cwnd, sf) -> capCwndPkt mptcpSock con cwnd sf) (zip cwnds (Set.toList $ subflows con)) + cwnds_m <- getCapsForConnection filename program mptcpConn lastMetrics + -- rename to waitingTime ? delay + case cwnds_m of + Nothing -> do + errorM "main" "Couldn't fetch the values" + return onFailureSleepingDelay + Just cwnds -> do - mapM_ (sendPacket sock) cwndPackets + debugM "main" $ "Requesting to set cwnds..." ++ show cwnds + -- TODO fix + -- KISS for now (capCwndPkt mptcpSock ) + let cwndPackets = map (\(cwnd, sf) -> capCwndPkt mptcpSock mptcpConn cwnd sf) (zip cwnds (Set.toList $ subflows mptcpConn)) - sleepMs onSuccessSleepingDelay - putStrLn "Finished monitoring token " + mapM_ (sendPacket sock) cwndPackets - -- call ourself again - startMonitorConnection tmpdir mptcpSock sockMetrics mConn + return onSuccessSleepingDelayMs + debugM "main" $ "Finished monitoring token. Waiting " ++ show duration + sleepMs duration + -- call ourself again + startMonitorConnection cliArgs (elapsed + duration) mptcpSock sockMetrics mConn @@ -480,44 +352,21 @@ 1. save the connection to a JSON file and pass it to mptcpnumerics -} -getCapsForConnection :: FilePath +getCapsForConnection :: FilePath -- ^Statistics file + -> FilePath -- ^Path towards the PM optimizer -> MptcpConnection -> [SockDiagMetrics] -> IO (Maybe [Word32]) -getCapsForConnection tmpdir mptcpConn metrics = do - -- returns a bytestring - -- let (MptcpConnectionWithMetrics mptcpConn metrics) = conWithMetrics - let jsonConn = (toJSON mptcpConn) - let merged = lodashMerge jsonConn (object [ "subflows" .= metrics ]) - -- (toJSON jsonConn) ++ (toJSON metrics) +getCapsForConnection filename program mptcpConn metrics = do - -- let jsonBs = Data.Aeson.encode merged - let jsonBs = encodePretty merged - -- let bs = Data.Aeson.encode jsonConn let subflowCount = length $ subflows mptcpConn - -- TODO either pass it via env or via args - -- let tmpdir = "/tmp" - -- let tmpdir = getEnvDefault "TMPDIR" "/tmp" - - let filename = tmpdir ++ "/" ++ "mptcp_" ++ (show $ connectionToken mptcpConn) ++ "_" ++ (show $ subflowCount) ++ ".json" - infoM "main" $ "Saving to " ++ filename - - -- tempdir <- getCanonicalTemporaryDirectory - -- see https://github.com/feuerbach/temporary/blob/2ebee43b92b878f0093b3ce66d613d553f82152f/tests/test.hs#L63 - -- for an example - -- takeDirectory fp `equalFilePath` sys_tmp_dir - -- fp <- withSystemTempDirectory tempdir "toto" $ \fp -> do - -- let fn = takeFileName fp - -- Data.ByteString.Lazy.writeFile fn - - Data.ByteString.Lazy.writeFile filename jsonBs + -- Data.ByteString.Lazy.writeFile filename jsonBs - -- TODO to keep it simple it should return a list of CWNDs to apply -- readProcessWithExitCode binary / args / stdin - (exitCode, stdout, stderrContent) <- readProcessWithExitCode (get_caps_prog mptcpConn) [filename, show subflowCount] "" + (exitCode, stdout, stderrContent) <- readProcessWithExitCode program [filename, show subflowCount] "" - putStrLn $ "exitCode: " ++ show exitCode + infoM "main" $ "exitCode: " ++ show exitCode putStrLn $ "stdout:\n" ++ stdout -- http://hackage.haskell.org/package/base/docs/Text-Read.html let values = (case exitCode of @@ -527,7 +376,6 @@ ) return values --- type Attributes = Map Int ByteString -- the library contains showAttrs / showNLAttrs showAttributes :: Attributes -> String showAttributes attrs = @@ -539,8 +387,6 @@ putW32 :: Word32 -> ByteString putW32 x = runPut (putWord32host x) --- removeSubflow :: MptcpSocket -> MptcpToken -> LocId -> IO [GenlPacket NoData] --- removeSubflow (MptcpSocket socket fid) token locId = let -- I want to override the GenlHeader version newtype GenlHeaderMptcp = GenlHeaderMptcp GenlHeader @@ -552,7 +398,7 @@ inspectAnswers :: [GenlPacket NoData] -> IO () inspectAnswers packets = do mapM_ inspectAnswer packets - putStrLn "Finished inspecting answers" + debugM "main" "Finished inspecting answers" -- showPacketCustom :: GenlPacket NoData -> String -- showPacketCustom pkt = let @@ -566,13 +412,12 @@ inspectAnswer (Packet _ (GenlData hdr NoData) attributes) = let cmd = genlCmd hdr in - putStrLn $ "Inspecting answer custom:\n" ++ showHeaderCustom hdr + debugM "main" $ "Inspecting answer custom:\n" ++ showHeaderCustom hdr ++ "Supposing it's a mptcp command: " ++ dumpCommand ( toEnum $ fromIntegral cmd) inspectAnswer pkt = putStrLn $ "Inspecting answer:\n" ++ showPacket pkt - -- should have this running in parallel queryAddrs :: NLR.RoutePacket queryAddrs = NL.Packet @@ -583,27 +428,15 @@ -- |Deal with events for already registered connections -- Warn: MPTCP_EVENT_ESTABLISHED registers a "null" interface --- TODO return a Maybe ? -- or a list of packets to send --- TODO return the MVar ? --- --- availablePaths <- readMVar globalInterfaces --- TODO put globalInterfaces in MyState ? - -- let (MptcpSocket mptcpSockRaw fid) = mptcpSock - -- let pkts = (onMasterEstablishement pathManager) mptcpSock mptcpConn availablePaths - -- putStrLn "List of requests made on new master:" - -- mapM_ (sendPacket $ mptcpSockRaw) pkts - -- TODO maybe the path manager should be part of the MptcpConnection dispatchPacketForKnownConnection :: MptcpSocket -> MptcpConnection -> MptcpGenlEvent -> Attributes -> AvailablePaths - -- -> Map.Map MptcpAttr MptcpAttribute - -- -> MptcpConnection -> (Maybe MptcpConnection, [MptcpPacket]) dispatchPacketForKnownConnection mptcpSock con event attributes availablePaths = let token = connectionToken con @@ -623,7 +456,6 @@ MPTCP_EVENT_ANNOUNCED -> let -- what if it's local remId = remoteIdFromAttributes attributes - -- TODO -- newConn = mptcpConnAddRemoteId con remId newConn = con in @@ -649,13 +481,17 @@ (Just newCon, []) -- MPTCP_CMD_EXIST -> con - _ -> error $ "should not happen " ++ show event -acceptConnection :: TcpConnection -> Bool --- acceptConnection subflow = subflow `notElem` filteredConnections -acceptConnection subflow = True +-- |Filter connections +-- This should be configurable in some way +acceptConnection :: TcpConnection -> Maybe [TcpConnection] -> Bool +acceptConnection subflow mFilteredConnections = + case mFilteredConnections of + Nothing -> True + -- or notElem + Just filtered -> subflow `elem` filtered -- | mapSubflowToInterfaceIdx :: IP -> IO (Maybe Word32) @@ -668,56 +504,43 @@ --- TODO reestablish later on --- open additionnal subflows --- createNewSubflows :: MptcpSocket -> MptcpConnection -> IO () --- createNewSubflows mptcpSock mptcpConn = do --- availablePaths <- readMVar globalInterfaces --- let (MptcpSocket mptcpSockRaw fid) = mptcpSock --- let pkts = (onMasterEstablishement pathManager) mptcpSock mptcpConn availablePaths - --- putStrLn "List of requests made on new master:" --- mapM_ (sendPacket $ mptcpSockRaw) pkts - - --- Maybe -registerMptcpConnection :: MyState -> MptcpToken -> TcpConnection -> IO MyState -registerMptcpConnection oldState token subflow = let - (MyState mptcpSock conns cliArgs) = oldState - in - if acceptConnection subflow == False - then do - putStrLn $ "filtered out connection" ++ show subflow - return oldState - else (do - -- should we add the subflow yet ? it doesn't have the correct interface idx - mappedInterface <- mapSubflowToInterfaceIdx (srcIp subflow) - let fixedSubflow = subflow { subflowInterface = mappedInterface } - -- let newMptcpConn = (MptcpConnection token [] Set.empty Set.empty) - let newMptcpConn = mptcpConnAddSubflow ( - MptcpConnection token Set.empty Set.empty Set.empty (optimizer cliArgs) - ) fixedSubflow +registerMptcpConnection :: MptcpToken -> TcpConnection -> StateT MyState IO () +registerMptcpConnection token subflow = (do + oldState <- get + let (MyState mptcpSock conns cliArgs filtered) = oldState + if acceptConnection subflow filtered == False + then do + -- infoM "main" $ "filtered out connection:" ++ show subflow + return () + else (do + -- putStrLn $ "accepted connection :" ++ show subflow + -- should we add the subflow yet ? it doesn't have the correct interface idx + mappedInterface <- liftIO $ mapSubflowToInterfaceIdx (srcIp subflow) + let fixedSubflow = subflow { subflowInterface = mappedInterface } + -- let newMptcpConn = (MptcpConnection token [] Set.empty Set.empty) + let newMptcpConn = mptcpConnAddSubflow ( + MptcpConnection token Set.empty Set.empty Set.empty (optimizer cliArgs) + ) fixedSubflow - newConn <- newMVar newMptcpConn - putStrLn $ "Connection established !!\n" + newConn <- liftIO $ newMVar newMptcpConn + -- putStrLn $ "Connection established !!\n" - -- create a new - sockMetrics <- makeMetricsSocket - -- start monitoring connection - threadId <- forkOS (startMonitorConnection (out cliArgs) mptcpSock sockMetrics newConn) + -- create a new + sockMetrics <- liftIO $ makeMetricsSocket + -- start monitoring connection + threadId <- liftIO $ forkOS (startMonitorConnection cliArgs 0 mptcpSock sockMetrics newConn) - putStrLn $ "Inserting new MVar " - let newState = oldState { - connections = Map.insert token (threadId, newConn) (connections oldState) - } - return newState) + -- putStrLn $ "Inserting new MVar " + put (oldState { + connections = Map.insert token (threadId, newConn) (connections oldState) + }) + )) -- |Treat MPTCP events depending on if the connection is known or not --- dispatchPacket :: MyState -> MptcpPacket -> IO MyState dispatchPacket oldState (Packet hdr (GenlData genlHeader NoData) attributes) = let cmd = toEnum $ fromIntegral $ genlCmd genlHeader - (MyState mptcpSock conns _) = oldState + (MyState mptcpSock conns _ _) = oldState (MptcpSocket mptcpSockRaw fid) = mptcpSock -- i suppose token is always available right ? @@ -737,14 +560,14 @@ case cmd of MPTCP_EVENT_ESTABLISHED -> do - putStrLn "Ignoring Creating EVENT" + -- putStrLn "Ignoring Creating EVENT" -- let newMptcpConn = (MptcpConnection token [] Set.empty Set.empty) return oldState MPTCP_EVENT_CREATED -> let subflow = subflowFromAttributes attributes in - registerMptcpConnection oldState token subflow + execStateT (registerMptcpConnection token subflow) oldState _ -> return oldState Just (threadId, mvarConn) -> do @@ -848,22 +671,17 @@ doDumpLoop :: MyState -> IO MyState doDumpLoop myState = do let (MptcpSocket simpleSock fid) = socket myState - results <- recvOne' simpleSock :: IO [Either String MptcpPacket] - -- TODO retrieve packets -- here we should update the state according -- mapM_ (inspectResult myState) results -- (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m b modifiedState <- foldM inspectResult myState results - doDumpLoop modifiedState --- regarder dans query/joinMulticastGroup/recvOne + listenToEvents :: MyState -> CtrlAttrMcastGroup -> IO () listenToEvents state my_group = do - -- joinMulticastGroup returns IO () - -- TODO should check it works correctly ! joinMulticastGroup sock (grpId my_group) putStrLn $ "Joined grp " ++ grpName my_group _ <- doDumpLoop state @@ -885,24 +703,6 @@ -- globalState = MyState mptcpSocket Map.empty -createLogger :: IO LoggerSet -createLogger = newStdoutLoggerSet defaultBufSize - - --- for big endian --- https://mail.haskell.org/pipermail/beginners/2010-October/005571.html --- foldl' :: (b -> a -> b) -> b -> Maybe a -> b --- fromOctetsBE :: [Word8] -> Word32 --- fromOctetsBE = foldl' accum 0 --- where --- accum a o = (a `Bits.shiftL` 8) .|. fromIntegral o --- -- maybe I could use putIArrayOf instead - --- fromOctetsLE :: [Word8] -> Word32 --- fromOctetsLE = fromOctetsBE . reverse - - - dumpExtensionAttribute :: Int -> ByteString -> SockDiagExtension dumpExtensionAttribute attrId value = let eExtId = (toEnum attrId :: SockDiagExtensionId) @@ -916,7 +716,6 @@ loadExtensionsFromAttributes :: Attributes -> [SockDiagExtension] loadExtensionsFromAttributes attrs = let - -- $ loadExtension mapped = Map.foldrWithKey (\k v -> ([dumpExtensionAttribute k v] ++ )) [] attrs in mapped @@ -947,28 +746,42 @@ , sockdiagMetrics :: [SockDiagExtension] } --- type SockDiagExtension2 = SockDiagExtension +-- type SockDiagExtension2 = SockDiagExtension instance ToJSON SockDiagExtension where - -- tcpi_rtt / tcpi_rttvar / tcpi_snd_ssthresh / tcpi_snd_cwnd - -- tcpi_state , tcpi_rto - -- rename arg to tcp_info - toJSON (tcp_info@DiagTcpInfo {} ) = let - rtt = tcpi_rtt tcp_info + toJSON (tcpInfo@DiagTcpInfo {} ) = let + -- rtt = tcpi_rtt tcpInfo + tcpState = toEnum $ fromIntegral ( tcpi_state tcpInfo) :: TcpState + -- TODO could log ca_state ? + in object [ - "rttvar" .= tcpi_rttvar tcp_info - , "rtt" .= rtt - , "rto" .= tcpi_rto tcp_info - , "snd_cwnd" .= tcpi_snd_cwnd tcp_info - , "snd_ssthresh" .= tcpi_snd_ssthresh tcp_info - , "reordering" .= tcpi_reordering tcp_info + "rttvar" .= tcpi_rttvar tcpInfo + , "rtt_us" .= tcpi_rtt tcpInfo + , "rto_us" .= tcpi_rto tcpInfo + , "snd_cwnd" .= tcpi_snd_cwnd tcpInfo + , "snd_cwnd_clamp" .= tcpi_snd_cwnd_clamp tcpInfo + , "snd_ssthresh" .= tcpi_snd_ssthresh tcpInfo + , "reordering" .= tcpi_reordering tcpInfo + , "tcp_state" .= show tcpState + , "pacing" .= tcpi_pacing_rate tcpInfo + , "delivery_rate" .= tcpi_delivery_rate tcpInfo + , "app_limited" .= tcpi_delivery_rate_app_limited tcpInfo + -- there is also a delivered_ce ? + , "delivered" .= tcpi_delivered tcpInfo + , "lost" .= tcpi_lost tcpInfo + , "retrans" .= tcpi_retrans tcpInfo + , "min_rtt" .= tcpi_min_rtt tcpInfo + , "mtu" .= tcpi_pmtu tcpInfo + -- TODO try converting it to str + , "ca_state" .= tcpi_ca_state tcpInfo + -- bytes_sent -- needs kernel patching -- , "fowd" .= toJSON ( (fromIntegral rtt/2) :: Float) -- , "bowd" .= toJSON ( (fromIntegral rtt/2) :: Float) - , "fowd" .= tcpi_fowd tcp_info - , "bowd" .= tcpi_bowd tcp_info + , "fowd" .= tcpi_fowd tcpInfo + , "bowd" .= tcpi_bowd tcpInfo -- , "total_retrans" .= tcpi_total_retrans arg @@ -982,8 +795,7 @@ ] toJSON _ = object [] --- TODO merge --- + instance ToJSON SockDiagMetrics where -- attributes of array -- foldr over array of extensions @@ -991,11 +803,13 @@ sf = connectionFromDiag msg tcpState = toEnum $ fromIntegral ( idiag_state msg) :: TcpState - -- extensions = loadExtensionsFromAttributes attrs initialValue = object [ - "srcIp" .= toJSON (srcIp sf), - "dstIp" .= toJSON (dstIp sf), - "state" .= show tcpState + "srcIp" .= toJSON (srcIp sf) + , "dstIp" .= toJSON (dstIp sf) + , "srcPort" .= toJSON (srcPort sf) + , "dstPort" .= toJSON (dstPort sf) + -- doesnt work as subflow id + -- , "subflow_id" .= idiag_uid msg ] fn x y = lodashMerge (toJSON x) y @@ -1021,58 +835,46 @@ inspectIdiagAnswers packets = map inspectIDiagAnswer packets -{-| The MptcpSocket doesn't need to be global --} --- withFormatter :: GenericHandler Handle -> GenericHandler Handle --- withFormatter handler = setFormatter handler formatter --- -- http://hackage.haskell.org/packages/archive/hslogger/1.1.4/doc/html/System-Log-Formatter.html --- where formatter = simpleLogFormatter "[$time $loggername $prio] $msg" --- s'inspirer de --- https://github.com/vdorr/linux-live-netinfo/blob/24ead3dd84d6847483aed206ec4b0e001bfade02/System/Linux/NetInfo.hs main :: IO () main = do -- SETUP LOGGING (https://gist.github.com/ijt/1052896) - myStreamHandler <- streamHandler stderr INFO - -- let myStreamHandler' = withFormatter myStreamHandler - -- let rootLog = rootLoggerName - -- updateGlobalLogger rootLog (setLevel INFO) - updateGlobalLogger "main" (setLevel DEBUG) + -- streamHandler vs verboseStreamHandler + myStreamHandler <- verboseStreamHandler stderr INFO + updateGlobalLogger rootLoggerName (setLevel DEBUG . setHandlers [myStreamHandler]) infoM "main" "Parsing command line..." options <- execParser opts - infoM "main" "Creating MPTCP netlink socket..." - -- let jsonConn = toJSON $ MptcpConnection 32 Set.empty Set.empty Set.empty - -- let objToMerge = object [ "toto" .= toJSON ("value" :: Value) ] - -- let merged = lodashMerge jsonConn objToMerge - -- let bs = Data.Aeson.encode $ merged - -- putStrLn $ show bs - - -- add the socket too to an MVar ? - (MptcpSocket sock fid) <- makeMptcpSocket - putMVar globalMptcpSock (MptcpSocket sock fid) - infoM "main" "Now Tracking system interfaces..." putMVar globalInterfaces Map.empty routeNl <- forkIO trackSystemInterfaces debugM "main" "socket created. MPTCP Family id " - -- >> Prelude.print fid - -- putStr "socket created. tcp_metrics Family id " >> print fidMetrics - -- That's what I should use in fact !! (Word16, [CtrlAttrMcastGroup]) - -- (mid, mcastGroup ) <- getFamilyWithMulticasts sock mptcpGenlEvGrpName - -- Each netlink family has a set of 32 multicast groups + + mptcpSocket <- makeMptcpSocket + let (MptcpSocket sock fid) = mptcpSocket mcastMptcpGroups <- getMulticastGroups sock fid mapM_ Prelude.print mcastMptcpGroups - let mptcpSocket = (MptcpSocket sock fid) - let globalState = MyState mptcpSocket Map.empty options + filteredConns <- case Main.filter options of + Nothing -> return Nothing + Just filename -> do + infoM "main" ("Loading connections whitelist from " ++ filename ++ "...") + filteredConnectionsStr <- BL.readFile filename + case Data.Aeson.eitherDecode filteredConnectionsStr of + -- case Data.Aeson.eitherDecode "[]" of + Left errMsg -> error ("Failed loading " ++ filename ++ ":\n" ++ errMsg) + Right list -> return list + + infoM "main" ("Loading connections whitelisted connections..." ++ (show filteredConns)) + + let globalState = MyState mptcpSocket Map.empty options filteredConns + mapM_ (listenToEvents globalState) mcastMptcpGroups -- putStrLn $ " Groups: " ++ unwords ( map grpName mcastMptcpGroups ) putStrLn "finished" - diff --git a/mptcp-pm.cabal b/mptcp-pm.cabal --- a/mptcp-pm.cabal +++ b/mptcp-pm.cabal @@ -1,112 +1,126 @@ -cabal-version: 2.2 +cabal-version: 3.0 name: mptcp-pm -version: 0.0.2 +version: 0.0.3 license: GPL-3.0-only license-file: LICENSE build-type: Simple Maintainer: teto Category: Network -Synopsis: A work in progress Multipath TCP path manager +Synopsis: A Multipath TCP path manager Homepage: https://github.com/teto/netlink_pm Description: - Multipath TCP (www.multipath-tcp.org) starting from version 0.95 provides a - netlink path manager module. This package implements the userspace part to allow - userspace daemons to control MPTCP behavior. -Extra-source-files: - headers/*.h README.md CHANGELOG + Multipath TCP (www.multipath-tcp.org) starting from version 0.95 provides a + netlink path manager module. This package implements the userspace component + in charge of controlling MPTCP subflow establishement and various behaviors. +data-files: +extra-source-files: headers/*.h headers/linux/*.h README.md CHANGELOG Source-repository head type: git - location: https://github.com/teto/netlink_pm + location: https://github.com/teto/mptcp-pm -Flag Dev { - Description: Develop with a local netlink library - Default: True -} +-- Flag Dev { +-- Description: Develop with a local netlink library +-- Default: True +-- } --- iproute/network-info bad --- bitset, very interesting but broken --- aeson to (de)serialize to json --- brittany for formatting (does not work) --- use containers for Data.Set ? --- text is used to convert from string and in aeson --- http://hackage.haskell.org/package/bitset-1.4.8/docs/Data-BitSet-Word.html common shared-properties - build-depends: base >= 4.12 && < 4.20, optparse-applicative, - containers, bytestring, fast-logger, process, cereal, ip, - netlink >= 1.1.1.0, bytestring-conversion, c2hsc, text, hslogger - -- for merge - , aeson - , aeson-pretty - , aeson-extra - -- to help with merging json content - , unordered-containers - -- to create temp folder/files - , temporary - , filepath - -- haddocset lookds kinda unmaintained, won't work with ghc 8.5 - -- , haddocset - -- , bitset - -- haskus-binary default-language: Haskell2010 - -- -fno-warn-unused-imports + -- -fno-warn-unused-imports -- -fforce-recomp makes it build twice - ghc-options: -Wall -fno-warn-unused-binds -fno-warn-unused-matches -threaded -fprof-auto -rtsopts + ghc-options: -Wall -fno-warn-unused-binds -fno-warn-unused-matches + build-depends: netlink >= 1.1.2.0 - if flag(Dev) - build-depends: netlink>= 1.1.1.1 - -- for the generated.hsc , c2hs seems good to generate headers - Build-tools: hsc2hs, c2hs + +library + import: shared-properties + default-language: Haskell2010 + -- for the .chs => c2hs -- apparently this just helps getting a better error messages Includes: tcp_states.h, linux/sock_diag.h, linux/inet_diag.h, linux/mptcp.h - Other-modules: Net.SockDiag, Net.Tcp, Net.Mptcp, Net.IPAddress, - Net.Mptcp.PathManager, Net.Mptcp.Constants, Net.SockDiag.Constants, Net.Tcp.Constants - , Net.Mptcp.PathManager.Default -- TODO try to pass it from CLI instead , Net.TcpInfo include-dirs: headers + default-extensions: DeriveGeneric autogen-modules: Net.Mptcp.Constants, Net.SockDiag.Constants, Net.Tcp.Constants - + build-depends: base >= 4.12 && < 4.17, + containers + , bytestring + -- , fast-logger + , katip + , process + , cereal + , enumset + , ip + , bytestring-conversion + , text + -- todo get rid of it + , mtl + -- for merge + , aeson + , aeson-pretty + , aeson-extra + -- to help with merging json content + , unordered-containers + -- to create temp folder/files + , transformers + hs-source-dirs: . + build-tool-depends: c2hs:c2hs + Exposed-Modules: + Net.SockDiag + , Net.Tcp + , Net.Bitset + , Net.Mptcp + , Net.IPAddress + , Net.Tcp.Definitions + , Net.Tcp.Constants + , Net.Mptcp.Constants, Net.SockDiag.Constants + -- TODO let it high level + , Net.Mptcp.PathManager + , Net.Mptcp.PathManager.Default -- monitor new mptcp connections -- and delegate the behavior to a monitor -executable mptcp-pm +executable mptcp-manager import: shared-properties + default-language: Haskell2010 -- ghc-options: -prof - main-is: hs/daemon.hs - hs-source-dirs: . - --- MyCustomLibrary --- library --- Build-tools: hsc2hs, c2hs --- ghc-options: -Wall -fno-warn-unused-binds -fno-warn-unused-matches --- default-language: Haskell2010 --- -- apparently this just helps getting a better error messages --- Includes: tcp_states.h, linux/sock_diag.h, linux/inet_diag.h --- include-dirs: . , headers - + build-depends: + aeson + , aeson-pretty + , aeson-extra + , base >= 4.12 && < 4.17 + , bytestring + , containers + , mptcp-pm + , optparse-applicative + , transformers + -- , fast-logger + , hslogger + , ip + , text + , mtl + , cereal + , process + , temporary + , filepath + -- to use Simple module. Try to do without + , netlink >= 1.1.2.0 + default-extensions: DeriveGeneric + main-is: daemon.hs + hs-source-dirs: hs/ + ghc-options: -threaded -rtsopts --- Test-Suite test --- -- 2 types supported, exitcode is based on ... exit codes .... --- type: exitcode-stdio-1.0 --- main-is: test/Main.hs --- -- test-module: Detailed --- hs-source-dirs: . --- default-language: Haskell2010 --- -- import: shared-properties --- Build-tools: hsc2hs, c2hs --- Includes: tcp_states.h, linux/sock_diag.h, linux/inet_diag.h --- Other-modules: Net.SockDiag, Net.Mptcp, Net.IPAddress, Net.Mptcp.Constants, Net.SockDiag.Constants, --- Net.SockDiag.Constants, Net.Tcp.Constants --- autogen-modules: Net.Mptcp.Constants, Net.SockDiag.Constants --- include-dirs: headers --- build-depends: base >=4.12 && <4.20 --- , HUnit --- , netlink --- , cereal --- , ip --- , bytestring --- , containers --- , aeson +Test-Suite test-tcp + -- 2 types supported, exitcode is based on ... exit codes .... + type: exitcode-stdio-1.0 + default-language: Haskell2010 + main-is: Main.hs + hs-source-dirs: test + ghc-options: -threaded -rtsopts + build-depends: base >=4.12 + , HUnit + , mptcp-pm + , ip, text diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| +https://stackoverflow.com/questions/32913552/why-does-my-hunit-test-suite-pass-when-my-tests-fail +-} +module Main where + +import System.Exit +import Test.HUnit +import Net.SockDiag +import Net.Mptcp +import Net.Tcp +import Net.IP +import Net.Bitset + +import Net.IPv4 (localhost) +import Numeric (readHex) +import Data.Text (Text) +import qualified Data.Text as T + +-- TODO reestablish this +testEmpty = TestCase $ assertEqual + "Check" + 1 + ( enumsToWord [TcpEstablished] ) + +testCombo = TestCase $ assertEqual + "Check" + 513 + ( enumsToWord [TcpEstablished, TcpListen] ) + +testComboReverse = TestCase $ assertEqual + "Check" + 513 + ( enumsToWord [TcpEstablished, TcpListen] ) + + +iperfConnection = TcpConnection { + srcIp = fromIPv4 localhost + , dstIp = fromIPv4 localhost + , srcPort = 5000 + , dstPort = 1000 + -- placeholder values + , priority = Nothing + , subflowInterface = Nothing + , localId = 0 + , remoteId = 0 + } + +modifiedConnection = iperfConnection { subflowInterface = Just 0 } + +filteredConnections :: [TcpConnection] +filteredConnections = [ iperfConnection ] + + +connectionFilter = TestCase $ assertBool + "Check connection is in the list" + (iperfConnection `elem` filteredConnections) + + + + +-- check we can read an hex from tshark +-- 0x00000012 +-- returns a list of possible parses as (a,String) pairs. +loadTcpFlagsFromHex :: Text -> [TcpFlag] +loadTcpFlagsFromHex text = case readHex (T.unpack $ T.drop 2 text) of + [(n, "")] -> fromBitMask n + _ -> error $ "TcpFlags: could not parse " ++ T.unpack text + + +-- connectionFilter = TestCase $ assertEqual +-- "Check connection is in the list" +-- True +-- ( iperfConnection `elem` filteredConnections) + +-- main :: IO Count +main = do + + results <- runTestTT $ TestList [ + TestLabel "subflow is correctly filtered" connectionFilter + , TestCase $ assertBool "connection should be equal" (iperfConnection == iperfConnection) + , TestCase $ assertEqual "connection should be equal despite different interfaces" + iperfConnection modifiedConnection + , TestCase $ assertBool "connection should be considered as in list" + (modifiedConnection `elem` filteredConnections) + -- , TestCase $ assertBool "connection should not be considered as in list" + -- (modifiedConnection `notElem` filteredConnections) + , TestList [ + TestCase $ assertEqual "to bitset " 2 (toBitMask [TcpFlagSyn]) + , TestCase $ assertEqual "Check tcp syn flags" [TcpFlagSyn] + (loadTcpFlagsFromHex "0x00000002") + , TestCase $ assertEqual "Check tcp syn/ack flags" [TcpFlagSyn, TcpFlagAck] + (loadTcpFlagsFromHex "0x00000012") + ] + ] + if errors results + failures results == 0 then + exitSuccess + else + exitWith (ExitFailure 1)