mptcp-pm 0.0.2 → 0.0.3
raw patch · 14 files changed
+810/−759 lines, 14 filesdep +HUnitdep +enumsetdep +katipdep −c2hscdep −fast-loggerdep ~basedep ~netlinksetup-changednew-component:exe:mptcp-manager
Dependencies added: HUnit, enumset, katip, mptcp-pm, mtl, transformers
Dependencies removed: c2hsc, fast-logger
Dependency ranges changed: base, netlink
Files
- CHANGELOG +8/−1
- Net/Bitset.hs +27/−0
- Net/IPAddress.hs +1/−19
- Net/Mptcp.hs +12/−70
- Net/Mptcp/PathManager.hs +1/−1
- Net/SockDiag.hs +84/−28
- Net/Tcp.hs +7/−56
- Net/Tcp/Definitions.hs +76/−0
- README.md +20/−74
- Setup.hs +0/−2
- headers/linux/mptcp.h +151/−0
- hs/daemon.hs +229/−427
- mptcp-pm.cabal +95/−81
- test/Main.hs +99/−0
CHANGELOG view
@@ -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
+ Net/Bitset.hs view
@@ -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
Net/IPAddress.hs view
@@ -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 =
Net/Mptcp.hs view
@@ -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 =
Net/Mptcp/PathManager.hs view
@@ -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)
Net/SockDiag.hs view
@@ -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-
Net/Tcp.hs view
@@ -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
+ Net/Tcp/Definitions.hs view
@@ -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 ==++
README.md view
@@ -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: <path to new module>"- 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<<SS_LISTEN)|(1<<SS_CLOSE)|(1<<SS_TIME_WAIT)|(1<<SS_SYN_RECV)))--- #define TIPC_SS_CONN ((1<<SS_ESTABLISHED)|(1<<SS_LISTEN)|(1<<SS_CLOSE))-+# Acknowledgements +This work is sponsored by [NGI][ngi]. +[mptcp-fork]: http://multipath-tcp.org/+[ngi]: https://www.ngi.eu/
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
+ headers/linux/mptcp.h view
@@ -0,0 +1,151 @@+/* SPDX-License-Identifier: GPL-2.0 WITH Linux-syscall-note */+/*+ * Netlink API for Multipath TCP+ *+ * Author: Gregory Detal <gregory.detal@tessares.net>+ *+ * 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 */
hs/daemon.hs view
@@ -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"-
mptcp-pm.cabal view
@@ -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
+ test/Main.hs view
@@ -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)